1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
|
## -*- tcl -*-
# # ## ### ##### ######## ############# #####################
## Copyright (c) 2007 Andreas Kupries.
#
# This software is licensed as described in the file LICENSE, which
# you should have received as part of this distribution.
#
# This software consists of voluntary contributions made by many
# individuals. For exact contribution history, see the revision
# history and logs, available at http://fossil-scm.hwaci.com/fossil
# # ## ### ##### ######## ############# #####################
## Pass manager. All passes register here, with code, description, and
## callbacks (... setup, run, finalize). Option processing and help
## query this manager to dynamically create the relevant texts.
# # ## ### ##### ######## ############# #####################
## Requirements
package require Tcl 8.4 ; # Required runtime.
package require snit ; # OO system.
package require vc::fossil::import::cvs::state ; # State storage
package require vc::fossil::import::cvs::integrity ; # State integrity checks.
package require vc::tools::misc ; # Text formatting
package require vc::tools::trouble ; # Error reporting.
package require vc::tools::log ; # User feedback.
package require struct::list ; # Portable lassign
# # ## ### ##### ######## ############# #####################
##
snit::type ::vc::fossil::import::cvs::pass {
# # ## ### ##### ######## #############
## Public API, Methods (Setup, query)
typemethod define {name description command} {
integrity assert {
![info exists mydesc($name)]
} {Multiple definitions for pass code '$name'}
lappend mypasses $name
set mydesc($name) $description
set mycmd($name) $command
return
}
typemethod help {} {
trouble info ""
trouble info "Conversion passes:"
trouble info ""
set n 0
set clen [max [struct::list map $mypasses {string length}]]
set cfmt %-${clen}s
set nfmt %[string length [llength $mypasses]]s
foreach code $mypasses {
trouble info " [format $nfmt $n]: [format $cfmt $code] : $mydesc($code)"
incr n
}
trouble info ""
return
}
# # ## ### ##### ######## #############
## Public API, Methods (Execution)
typemethod select {passdef} {
set pl [split $passdef :]
if {[llength $pl] > 2} {
trouble fatal "Bad pass definition '$passdef'"
trouble fatal "Expected at most one ':'"
} elseif {[llength $pl] == 2} {
struct::list assign $pl start end
if {($start eq "") && ($end eq "")} {
trouble fatal "Specify at least one of start- or end-pass"
set ok 0
} else {
set ok 1
Ok? $start start ok
Ok? $end end ok
}
if {$ok} {
set mystart [Convert $start 0]
set myend [Convert $end [expr {[llength $mypasses] - 1}]]
if {$mystart > $myend} {
trouble fatal "Start pass is after end pass"
}
}
} elseif {[llength $pl] < 2} {
set start [lindex $pl 0]
Ok? $start "" __dummy__ 0
set mystart [Id $start]
set myend $mystart
}
}
typemethod run {} {
if {$mystart < 0} {set mystart 0}
if {$myend < 0} {set myend [expr {[llength $mypasses] - 1}]}
set skipped [lrange $mypasses 0 [expr {$mystart - 1}]]
set run [lrange $mypasses $mystart $myend]
set defered [lrange $mypasses [expr {$myend + 1}] end]
foreach p $skipped {
log write 0 pass "Skip $p"
Call $p load
}
foreach p $run {
log write 0 pass "Setup $p"
Call $p setup
}
foreach p $run {
log write 0 pass "Begin $p"
set secbegin [clock seconds]
Call $p run
set secstop [clock seconds]
log write 0 pass "Done $p"
Time $p [expr {$secstop - $secbegin}]
trouble abort?
}
foreach p $defered {
log write 0 pass "Defer $p"
Call $p discard
}
state release
ShowTimes
return
}
typemethod current {} { return $mycurrentpass }
# # ## ### ##### ######## #############
## Internal methods
proc Time {pass seconds} {
::variable mytime
lappend mytime $pass $seconds
ShowTime $pass $seconds
return
}
proc ShowTimes {} {
::variable mytime
set total 0
foreach {pass seconds} $mytime {
ShowTime $pass $seconds
incr total $seconds
}
ShowTime Total $total
return
}
proc ShowTime {pass seconds} {
if {$seconds > 3600} {
set hr [expr {$seconds / 3600}]
set min [expr {$seconds % 3600}]
set sec [expr {$min % 60}]
set min [expr {$min / 60}]
log write 0 pass "[format %8d $seconds] sec/$pass ([nsp $hr hour] [nsp $min minute] [nsp $sec second])"
} elseif {$seconds > 60} {
set min [expr {$seconds / 60}]
set sec [expr {$seconds % 60}]
log write 0 pass "[format %8d $seconds] sec/$pass ([nsp $min minute] [nsp $sec second])"
} else {
log write 0 pass "[format %8d $seconds] sec/$pass"
}
return
}
proc Ok? {code label ov {emptyok 1}} {
upvar 1 $ov ok
::variable mydesc
if {$emptyok && ($code eq "")} return
if {[info exists mydesc($code)]} return
if {$label ne ""} {append label " "}
trouble fatal "Bad ${label}pass code $code"
set ok 0
return
}
proc Convert {code default} {
::variable mypasses
return [expr {($code eq "") ? $default : [Id $code]}]
}
proc Id {code} {
::variable mypasses
return [lsearch -exact $mypasses $code]
}
proc Call {code args} {
::variable mycmd
set cmd $mycmd($code)
foreach a $args { lappend cmd $a }
eval $cmd
return
}
# # ## ### ##### ######## #############
## Internal, state
typevariable mypasses {} ; # List of registered passes (codes).
typevariable mydesc -array {} ; # Pass descriptions (one line).
typevariable mycmd -array {} ; # Pass callback command.
typevariable mystart -1
typevariable myend -1
typevariable mytime {} ; # Timing data for each executed pass.
typevariable mycurrentpass {} ; # Pass currently running.
# # ## ### ##### ######## #############
## Configuration
pragma -hasinstances no ; # singleton
pragma -hastypeinfo no ; # no introspection
pragma -hastypedestroy no ; # immortal
# # ## ### ##### ######## #############
}
namespace eval ::vc::fossil::import::cvs {
namespace export pass
namespace eval pass {
namespace import ::vc::fossil::import::cvs::state
namespace import ::vc::fossil::import::cvs::integrity
namespace import ::vc::tools::misc::*
namespace import ::vc::tools::trouble
namespace import ::vc::tools::log
log register pass
}
}
# # ## ### ##### ######## ############# #####################
## Ready
package provide vc::fossil::import::cvs::pass 1.0
return
|
