Fossil SCM

Redid the logging system aka user feedback completely. Verbosity levels, influenced by the new -v switch. Indentations in the output removed, parsing by tools easier, still human readable. Adapted all users of the previous feedback code to use the new system.

aku 2007-09-08 05:35 trunk
Commit be32ebcb41cfeabaf07dcc60ebbb2166fff76483
Parent 8469631cc984252…
6 files changed +30 -48 +33 -47 +10 -26 +98 +1 +45 -41
~ tools/import-cvs.tcl ~ tools/lib/cvs.tcl ~ tools/lib/fossil.tcl + tools/lib/log.tcl ~ tools/lib/pkgIndex.tcl ~ tools/lib/rcsparser.tcl
M tools/import-cvs.tcl
+30 -48
--- tools/import-cvs.tcl
+++ tools/import-cvs.tcl
@@ -42,63 +42,64 @@
4242
 # Requirements
4343
4444
 package require Tcl 8.4
4545
 package require cvs ; # Frontend, reading from source repository
4646
 package require fossil ; # Backend, writing to destination repository.
47
+package require tools::log
48
+
49
+::tools::log::system import
4750
4851
 # -----------------------------------------------------------------------------
4952
5053
 proc main {} {
51
- global argv tot nto cvs fossil ntrunk stopat
54
+ global argv tot nto cvs fossil ntrunk stopat nmax ntfmt nmfmt
5255
5356
 commandline
5457
55
- fossil::feedback Write ; # Setup progress feedback from the libraries
56
- cvs::feedback Write
57
-
5858
 cvs::at $cvs ; # Define location of CVS repository
5959
 cvs::scan ; # Gather revision data from the archives
6060
 cvs::csets ; # Group changes into sets
6161
 cvs::rtree ; # Build revision tree (trunk only right now).
6262
6363
 set tot 0.0
6464
 set nto 0
6565
66
- Write info {Importing ...}
67
- Write info { Setting up cvs workspace and temporary fossil repository}
66
+ ::tools::log::write 0 import {Begin conversion}
67
+ ::tools::log::write 0 import {Setting up workspaces}
6868
6969
 cvs::workspace ; # cd's to workspace
7070
 fossil::new ; # Uses cwd as workspace to connect to.
7171
72
- set ntrunk [cvs::ntrunk]
72
+ set ntrunk [cvs::ntrunk] ; set ntfmt %[string length $ntrunk]s
73
+ set nmax [cvs::ncsets] ; set nmfmt %[string length $nmax]s
74
+
7375
 cvs::foreach_cset cset [cvs::root] {
7476
 import $cset
7577
 if {$stopat == $cset} exit
7678
 }
7779
 cvs::wsclear
7880
79
- Write info " ========= [string repeat = 61]"
80
- Write info " Imported $nto [expr {($nto == 1) ? "changeset" : "changesets"}]"
81
- Write info " Within [format %.2f $tot] seconds (avg [format %.2f [expr {$tot/$nto}]] seconds/changeset)"
82
-
83
- Write info { Moving to final destination}
81
+ ::tools::log::write 0 import "========= [string repeat = 61]"
82
+ ::tools::log::write 0 import "Imported $nto [expr {($nto == 1) ? "changeset" : "changesets"}]"
83
+ ::tools::log::write 0 import "Within [format %.2f $tot] seconds (avg [format %.2f [expr {$tot/$nto}]] seconds/changeset)"
8484
8585
 fossil::destination $fossil
8686
87
- Write info Ok.
87
+ ::tools::log::write 0 import Ok.
8888
 return
8989
 }
9090
9191
9292
 # -----------------------------------------------------------------------------
9393
9494
 proc commandline {} {
95
- global argv cvs fossil nosign log debugcommit stopat
95
+ global argv cvs fossil nosign debugcommit stopat
9696
9797
 set nosign 0
9898
 set debugcommit 0
9999
 set stopat {}
100
+ set verbosity 0
100101
101102
 while {[string match "-*" [set opt [lindex $argv 0]]]} {
102103
 if {$opt eq "--nosign"} {
103104
 set nosign 1
104105
 set argv [lrange $argv 1 end]
@@ -111,10 +112,16 @@
111112
 }
112113
 if {$opt eq "--stopat"} {
113114
 set stopat [lindex $argv 1]
114115
 set argv [lrange $argv 2 end]
115116
 continue
117
+ }
118
+ if {$opt eq "-v"} {
119
+ incr verbosity
120
+ ::tools::log::verbosity $verbosity
121
+ set argv [lrange $argv 1 end]
122
+ continue
116123
 }
117124
 usage
118125
 }
119126
 if {[llength $argv] != 2} usage
120127
 foreach {cvs fossil} $argv break
@@ -127,12 +134,10 @@
127134
 usage "CVS directory missing, not readable, or not a directory."
128135
 } elseif {[file exists $fossil]} {
129136
 usage "Fossil destination repository exists already."
130137
 }
131138
132
- set log [open ${fossil}.log w]
133
-
134139
 fossil::debugcommit $debugcommit
135140
 return
136141
 }
137142
138143
 proc usage {{text {}}} {
@@ -142,19 +147,18 @@
142147
 puts stderr " $text"
143148
 exit
144149
 }
145150
146151
 proc import {cset} {
147
- global tot nto nosign ntrunk stopat
148
- Write info " Importing $cset [string repeat = [expr {60 - [string length $cset]}]]"
149
- Write info " At $nto/$ntrunk ([format %.2f [expr {$nto*100.0/$ntrunk}]]%)"
152
+ global tot nto nosign ntrunk stopat ntfmt nmfmt
153
+ ::tools::log::write 0 import "ChangeSet [format $nmfmt $cset] @ [format $ntfmt $nto]/$ntrunk ([format %6.2f [expr {$nto*100.0/$ntrunk}]]%)"
150154
151155
 if {$stopat == $cset} {
152156
 fossil::commit 1 cvs2fossil $nosign \
153157
 [cvs::wssetup $cset] \
154158
 ::cvs::wsignore
155
- Write info " %% STOP"
159
+ ::tools::log::write 1 import {%% STOP}
156160
 return
157161
 }
158162
159163
 set usec [lindex [time {
160164
 foreach {uuid ad rm ch} [fossil::commit 0 cvs2fossil $nosign \
@@ -165,45 +169,23 @@
165169
166170
 set sec [expr {$usec/1e6}]
167171
 set tot [expr {$tot + $sec}]
168172
 incr nto
169173
170
- Write info " == $uuid +${ad}-${rm}*${ch}"
171
- Write info " in $sec seconds"
174
+ ::tools::log::write 2 import "== $uuid +${ad}-${rm}*${ch}"
175
+ ::tools::log::write 2 import "st in [format %.2f $sec] sec"
172176
173177
 set avg [expr {$tot/$nto}]
174178
 set max [expr {$ntrunk * $avg}]
175179
 set rem [expr {$max - $tot}]
176180
177
- Write info " st avg [format %.2f $avg]"
178
- Write info " st run [format %7.2f $tot] sec [format %6.2f [expr {$tot/60}]] min [format %5.2f [expr {$tot/3600}]] hr"
179
- Write info " st end [format %7.2f $max] sec [format %6.2f [expr {$max/60}]] min [format %5.2f [expr {$max/3600}]] hr"
180
- Write info " st rem [format %7.2f $rem] sec [format %6.2f [expr {$rem/60}]] min [format %5.2f [expr {$rem/3600}]] hr"
181
- return
182
-}
183
-
184
-# -----------------------------------------------------------------------------
185
-
186
-array set fl {
187
- debug {DEBUG }
188
- info { }
189
- warning {Warning}
190
- error {ERROR }
191
-}
192
-
193
-proc Write {l t} {
194
- global fl log
195
-
196
- if {[string index $t 0] eq "\r"} {
197
- puts -nonewline stdout "\r$fl($l) [string range $t 0 end-1]"
198
- } else {
199
- puts stdout "$fl($l) $t"
200
- puts $log "$fl($l) $t"
201
- }
202
- flush stdout
181
+ ::tools::log::write 3 import "st avg [format %.2f $avg] sec"
182
+ ::tools::log::write 3 import "st run [format %7.2f $tot] sec [format %6.2f [expr {$tot/60}]] min [format %5.2f [expr {$tot/3600}]] hr"
183
+ ::tools::log::write 3 import "st end [format %7.2f $max] sec [format %6.2f [expr {$max/60}]] min [format %5.2f [expr {$max/3600}]] hr"
184
+ ::tools::log::write 3 import "st rem [format %7.2f $rem] sec [format %6.2f [expr {$rem/60}]] min [format %5.2f [expr {$rem/3600}]] hr"
203185
 return
204186
 }
205187
206188
 # -----------------------------------------------------------------------------
207189
208190
 main
209191
 exit
210192
--- tools/import-cvs.tcl
+++ tools/import-cvs.tcl
@@ -42,63 +42,64 @@
42 # Requirements
43
44 package require Tcl 8.4
45 package require cvs ; # Frontend, reading from source repository
46 package require fossil ; # Backend, writing to destination repository.
 
 
 
47
48 # -----------------------------------------------------------------------------
49
50 proc main {} {
51 global argv tot nto cvs fossil ntrunk stopat
52
53 commandline
54
55 fossil::feedback Write ; # Setup progress feedback from the libraries
56 cvs::feedback Write
57
58 cvs::at $cvs ; # Define location of CVS repository
59 cvs::scan ; # Gather revision data from the archives
60 cvs::csets ; # Group changes into sets
61 cvs::rtree ; # Build revision tree (trunk only right now).
62
63 set tot 0.0
64 set nto 0
65
66 Write info {Importing ...}
67 Write info { Setting up cvs workspace and temporary fossil repository}
68
69 cvs::workspace ; # cd's to workspace
70 fossil::new ; # Uses cwd as workspace to connect to.
71
72 set ntrunk [cvs::ntrunk]
 
 
73 cvs::foreach_cset cset [cvs::root] {
74 import $cset
75 if {$stopat == $cset} exit
76 }
77 cvs::wsclear
78
79 Write info " ========= [string repeat = 61]"
80 Write info " Imported $nto [expr {($nto == 1) ? "changeset" : "changesets"}]"
81 Write info " Within [format %.2f $tot] seconds (avg [format %.2f [expr {$tot/$nto}]] seconds/changeset)"
82
83 Write info { Moving to final destination}
84
85 fossil::destination $fossil
86
87 Write info Ok.
88 return
89 }
90
91
92 # -----------------------------------------------------------------------------
93
94 proc commandline {} {
95 global argv cvs fossil nosign log debugcommit stopat
96
97 set nosign 0
98 set debugcommit 0
99 set stopat {}
 
100
101 while {[string match "-*" [set opt [lindex $argv 0]]]} {
102 if {$opt eq "--nosign"} {
103 set nosign 1
104 set argv [lrange $argv 1 end]
@@ -111,10 +112,16 @@
111 }
112 if {$opt eq "--stopat"} {
113 set stopat [lindex $argv 1]
114 set argv [lrange $argv 2 end]
115 continue
 
 
 
 
 
 
116 }
117 usage
118 }
119 if {[llength $argv] != 2} usage
120 foreach {cvs fossil} $argv break
@@ -127,12 +134,10 @@
127 usage "CVS directory missing, not readable, or not a directory."
128 } elseif {[file exists $fossil]} {
129 usage "Fossil destination repository exists already."
130 }
131
132 set log [open ${fossil}.log w]
133
134 fossil::debugcommit $debugcommit
135 return
136 }
137
138 proc usage {{text {}}} {
@@ -142,19 +147,18 @@
142 puts stderr " $text"
143 exit
144 }
145
146 proc import {cset} {
147 global tot nto nosign ntrunk stopat
148 Write info " Importing $cset [string repeat = [expr {60 - [string length $cset]}]]"
149 Write info " At $nto/$ntrunk ([format %.2f [expr {$nto*100.0/$ntrunk}]]%)"
150
151 if {$stopat == $cset} {
152 fossil::commit 1 cvs2fossil $nosign \
153 [cvs::wssetup $cset] \
154 ::cvs::wsignore
155 Write info " %% STOP"
156 return
157 }
158
159 set usec [lindex [time {
160 foreach {uuid ad rm ch} [fossil::commit 0 cvs2fossil $nosign \
@@ -165,45 +169,23 @@
165
166 set sec [expr {$usec/1e6}]
167 set tot [expr {$tot + $sec}]
168 incr nto
169
170 Write info " == $uuid +${ad}-${rm}*${ch}"
171 Write info " in $sec seconds"
172
173 set avg [expr {$tot/$nto}]
174 set max [expr {$ntrunk * $avg}]
175 set rem [expr {$max - $tot}]
176
177 Write info " st avg [format %.2f $avg]"
178 Write info " st run [format %7.2f $tot] sec [format %6.2f [expr {$tot/60}]] min [format %5.2f [expr {$tot/3600}]] hr"
179 Write info " st end [format %7.2f $max] sec [format %6.2f [expr {$max/60}]] min [format %5.2f [expr {$max/3600}]] hr"
180 Write info " st rem [format %7.2f $rem] sec [format %6.2f [expr {$rem/60}]] min [format %5.2f [expr {$rem/3600}]] hr"
181 return
182 }
183
184 # -----------------------------------------------------------------------------
185
186 array set fl {
187 debug {DEBUG }
188 info { }
189 warning {Warning}
190 error {ERROR }
191 }
192
193 proc Write {l t} {
194 global fl log
195
196 if {[string index $t 0] eq "\r"} {
197 puts -nonewline stdout "\r$fl($l) [string range $t 0 end-1]"
198 } else {
199 puts stdout "$fl($l) $t"
200 puts $log "$fl($l) $t"
201 }
202 flush stdout
203 return
204 }
205
206 # -----------------------------------------------------------------------------
207
208 main
209 exit
210
--- tools/import-cvs.tcl
+++ tools/import-cvs.tcl
@@ -42,63 +42,64 @@
42 # Requirements
43
44 package require Tcl 8.4
45 package require cvs ; # Frontend, reading from source repository
46 package require fossil ; # Backend, writing to destination repository.
47 package require tools::log
48
49 ::tools::log::system import
50
51 # -----------------------------------------------------------------------------
52
53 proc main {} {
54 global argv tot nto cvs fossil ntrunk stopat nmax ntfmt nmfmt
55
56 commandline
57
 
 
 
58 cvs::at $cvs ; # Define location of CVS repository
59 cvs::scan ; # Gather revision data from the archives
60 cvs::csets ; # Group changes into sets
61 cvs::rtree ; # Build revision tree (trunk only right now).
62
63 set tot 0.0
64 set nto 0
65
66 ::tools::log::write 0 import {Begin conversion}
67 ::tools::log::write 0 import {Setting up workspaces}
68
69 cvs::workspace ; # cd's to workspace
70 fossil::new ; # Uses cwd as workspace to connect to.
71
72 set ntrunk [cvs::ntrunk] ; set ntfmt %[string length $ntrunk]s
73 set nmax [cvs::ncsets] ; set nmfmt %[string length $nmax]s
74
75 cvs::foreach_cset cset [cvs::root] {
76 import $cset
77 if {$stopat == $cset} exit
78 }
79 cvs::wsclear
80
81 ::tools::log::write 0 import "========= [string repeat = 61]"
82 ::tools::log::write 0 import "Imported $nto [expr {($nto == 1) ? "changeset" : "changesets"}]"
83 ::tools::log::write 0 import "Within [format %.2f $tot] seconds (avg [format %.2f [expr {$tot/$nto}]] seconds/changeset)"
 
 
84
85 fossil::destination $fossil
86
87 ::tools::log::write 0 import Ok.
88 return
89 }
90
91
92 # -----------------------------------------------------------------------------
93
94 proc commandline {} {
95 global argv cvs fossil nosign debugcommit stopat
96
97 set nosign 0
98 set debugcommit 0
99 set stopat {}
100 set verbosity 0
101
102 while {[string match "-*" [set opt [lindex $argv 0]]]} {
103 if {$opt eq "--nosign"} {
104 set nosign 1
105 set argv [lrange $argv 1 end]
@@ -111,10 +112,16 @@
112 }
113 if {$opt eq "--stopat"} {
114 set stopat [lindex $argv 1]
115 set argv [lrange $argv 2 end]
116 continue
117 }
118 if {$opt eq "-v"} {
119 incr verbosity
120 ::tools::log::verbosity $verbosity
121 set argv [lrange $argv 1 end]
122 continue
123 }
124 usage
125 }
126 if {[llength $argv] != 2} usage
127 foreach {cvs fossil} $argv break
@@ -127,12 +134,10 @@
134 usage "CVS directory missing, not readable, or not a directory."
135 } elseif {[file exists $fossil]} {
136 usage "Fossil destination repository exists already."
137 }
138
 
 
139 fossil::debugcommit $debugcommit
140 return
141 }
142
143 proc usage {{text {}}} {
@@ -142,19 +147,18 @@
147 puts stderr " $text"
148 exit
149 }
150
151 proc import {cset} {
152 global tot nto nosign ntrunk stopat ntfmt nmfmt
153 ::tools::log::write 0 import "ChangeSet [format $nmfmt $cset] @ [format $ntfmt $nto]/$ntrunk ([format %6.2f [expr {$nto*100.0/$ntrunk}]]%)"
 
154
155 if {$stopat == $cset} {
156 fossil::commit 1 cvs2fossil $nosign \
157 [cvs::wssetup $cset] \
158 ::cvs::wsignore
159 ::tools::log::write 1 import {%% STOP}
160 return
161 }
162
163 set usec [lindex [time {
164 foreach {uuid ad rm ch} [fossil::commit 0 cvs2fossil $nosign \
@@ -165,45 +169,23 @@
169
170 set sec [expr {$usec/1e6}]
171 set tot [expr {$tot + $sec}]
172 incr nto
173
174 ::tools::log::write 2 import "== $uuid +${ad}-${rm}*${ch}"
175 ::tools::log::write 2 import "st in [format %.2f $sec] sec"
176
177 set avg [expr {$tot/$nto}]
178 set max [expr {$ntrunk * $avg}]
179 set rem [expr {$max - $tot}]
180
181 ::tools::log::write 3 import "st avg [format %.2f $avg] sec"
182 ::tools::log::write 3 import "st run [format %7.2f $tot] sec [format %6.2f [expr {$tot/60}]] min [format %5.2f [expr {$tot/3600}]] hr"
183 ::tools::log::write 3 import "st end [format %7.2f $max] sec [format %6.2f [expr {$max/60}]] min [format %5.2f [expr {$max/3600}]] hr"
184 ::tools::log::write 3 import "st rem [format %7.2f $rem] sec [format %6.2f [expr {$rem/60}]] min [format %5.2f [expr {$rem/3600}]] hr"
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
185 return
186 }
187
188 # -----------------------------------------------------------------------------
189
190 main
191 exit
192
M tools/lib/cvs.tcl
+33 -47
--- tools/lib/cvs.tcl
+++ tools/lib/cvs.tcl
@@ -3,59 +3,56 @@
33
44
 # -----------------------------------------------------------------------------
55
 # Requirements
66
77
 package require Tcl 8.4
8
-package require fileutil ; # Tcllib (cat)
9
-package require rcsparser ; # Handling the RCS archive files.
8
+package require fileutil ; # Tcllib (traverse directory hierarchy)
9
+package require rcsparser ; # Handling the RCS archive files.
10
+package require tools::log ; # User feedback
1011
 package require struct::tree
1112
12
-namespace eval ::cvs {}
13
+namespace eval ::cvs {
14
+ tools::log::system cvs
15
+ namespace import ::tools::log::write
16
+}
1317
1418
 # -----------------------------------------------------------------------------
1519
 # API
1620
1721
 # Define repository directory.
1822
1923
 proc ::cvs::at {path} {
2024
 variable base [file normalize $path]
25
+ write 0 cvs "Base: $base"
2126
 return
2227
 }
2328
2429
 namespace eval ::cvs {
2530
 # Toplevel repository directory
2631
 variable base {}
2732
 }
2833
29
-# Define logging callback command
30
-
31
-proc ::cvs::feedback {logcmd} {
32
- variable lc $logcmd
33
- ::rcsparser::feedback $logcmd
34
- return
35
-}
36
-
3734
 # Scan repository, collect archives, parse them, and collect revision
3835
 # information (file, revision -> date, author, commit message)
3936
4037
 proc ::cvs::scan {} {
4138
 variable base
4239
 variable npaths
4340
 variable rpaths
4441
 variable timeline
4542
46
- Log info "Scanning CVS tree $base"
43
+ write 0 cvs {Scanning directory hierarchy}
4744
4845
 set n 0
4946
 foreach rcs [fileutil::findByPattern $base -glob *,v] {
5047
 set rcs [fileutil::stripPath $base $rcs]
5148
 # Now rcs is relative to base
5249
53
- Log info " Parsing archive $rcs"
50
+ write 1 cvs "Archive $rcs"
5451
5552
 if {[string match CVSROOT* $rcs]} {
56
- Log info " => Ignoring admin file"
53
+ write 2 cvs {Ignored. Administrative file}
5754
 continue
5855
 }
5956
6057
 # Derive the regular path from the rcs path. Meaning: Chop of
6158
 # the ",v" suffix, and remove a possible "Attic".
@@ -64,11 +61,12 @@
6461
 set f [file join [file dirname [file dirname $f]] [file tail $f]]
6562
 if {[file exists $base/$f,v]} {
6663
 # We have a regular archive and an Attic archive
6764
 # refering to the same user visible file. Ignore the
6865
 # file in the Attic.
69
- Log info " => Ignoring attic for regular archive"
66
+
67
+ write 2 cvs "Ignored. Attic superceded by regular archive"
7068
7169
 # TODO/CHECK. My method of co'ing exact file revisions
7270
 # per the info in the collected csets has the flaw
7371
 # that I may have to know exactly when what archive
7472
 # file to use, see above. It might be better to use
@@ -85,12 +83,10 @@
8583
 }
8684
8785
 # Get the meta data we need (revisions, timeline, messages).
8886
 set meta [::rcsparser::process $base/$rcs]
8987
90
- Log info " => $f"
91
-
9288
 set npaths($rcs) $f
9389
 set rpaths($f) $rcs
9490
9591
 array set p $meta
9692
@@ -103,11 +99,11 @@
10399
 # seems to exist only! on its branch. The branches
104100
 # information is set on the revision (extend rcsparser!),
105101
 # symbols has a tag, refering to a branch, possibly magic.
106102
107103
 if {($rev eq "1.1") && ($op eq "R")} {
108
- Log info " => Dead first"
104
+ write 2 cvs {Dead root revision}
109105
 }
110106
111107
 lappend timeline($ts) [list $op $ts $a $rev $f $cm]
112108
 }
113109
@@ -115,11 +111,11 @@
115111
 #parray p
116112
117113
 incr n
118114
 }
119115
120
- Log info "Processed $n [expr {($n == 1) ? "file" : "files"}]"
116
+ write 0 cvs "Processed $n [expr {($n == 1) ? "file" : "files"}]"
121117
 return
122118
 }
123119
124120
 namespace eval ::cvs {
125121
 # Path mappings. npaths: rcs file -> user file
@@ -143,11 +139,11 @@
143139
144140
 array unset csets * ; array set csets {}
145141
 array unset cmap * ; array set cmap {}
146142
 set ncs 0
147143
148
- Log info "Processing timeline"
144
+ write 0 cvs "Processing timeline"
149145
150146
 set n 0
151147
 CSClear
152148
 foreach ts [lsort -dict [array names timeline]] {
153149
@@ -167,13 +163,14 @@
167163
 CSAdd $entry
168164
 incr n
169165
 }
170166
 }
171167
172
- Log info "Processed $n [expr {($n == 1) ? "entry" : "entries"}]"
168
+ write 0 cvs "Processed $n [expr {($n == 1) ? "entry" : "entries"}]"
169
+
173170
 set n [array size csets]
174
- Log info "Found $n [expr {($n == 1) ? "changeset" : "changesets"}]"
171
+ write 0 cvs "Found $n [expr {($n == 1) ? "changeset" : "changesets"}]"
175172
 return
176173
 }
177174
178175
179176
 namespace eval ::cvs {
@@ -192,11 +189,11 @@
192189
 proc ::cvs::rtree {} {
193190
 variable csets
194191
 variable rtree {}
195192
 variable ntrunk 0
196193
197
- Log info "Extracting the trunk"
194
+ write 0 cvs "Extracting the trunk"
198195
199196
 set rtree [struct::tree ::cvs::RT]
200197
 $rtree rename root 0 ; # Root is first changeset, always.
201198
 set trunk 0
202199
 set ntrunk 1 ; # Root is on the trunk.
@@ -218,12 +215,12 @@
218215
 $rtree insert $trunk end $c
219216
 set trunk $c
220217
 incr ntrunk
221218
 }
222219
223
- Log info "Processed $ntrunk trunk [expr {($ntrunk == 1) ? "changeset" : "changesets"}]"
224
- Log info "Ignored $b branch [expr {($b == 1) ? "changeset" : "changesets"}]"
220
+ write 0 cvs "Processed $ntrunk trunk [expr {($ntrunk == 1) ? "changeset" : "changesets"}]"
221
+ write 0 cvs "Ignored $b branch [expr {($b == 1) ? "changeset" : "changesets"}]"
225222
 return
226223
 }
227224
228225
 namespace eval ::cvs {
229226
 # Tree holding trunk and branch information (struct::tree).
@@ -237,11 +234,11 @@
237234
 variable cwd [pwd]
238235
 variable workspace [fileutil::tempfile importF_cvs_ws_]
239236
 file delete $workspace
240237
 file mkdir $workspace
241238
242
- Log info " Workspace: $workspace"
239
+ write 0 cvs "Workspace: $workspace"
243240
244241
 cd $workspace ; # Checkouts go here.
245242
 return $workspace
246243
 }
247244
@@ -266,19 +263,19 @@
266263
267264
 # pwd = workspace
268265
269266
 foreach {u cm s e rd fs} $csets($c) break
270267
271
- Log info " @ $s"
268
+ write 1 cvs "@ $s"
272269
273270
 foreach l [split [string trim $cm] \n] {
274
- Log info " | $l"
271
+ write 1 cvs "| $l"
275272
 }
276273
277274
 foreach {f or} $fs {
278275
 foreach {op r} $or break
279
- Log info " -- $op $f $r"
276
+ write 2 cvs "$op $f $r"
280277
281278
 if {$op eq "R"} {
282279
 # Remove file from workspace. Prune empty directories.
283280
 #
284281
 # NOTE: A dead-first file (rev 1.1 dead) will never have
@@ -312,11 +309,11 @@
312309
 # a consequence the fossil repository will not
313310
 # contain the full history of the named file. By
314311
 # ignoring the problem we however get as much as
315312
 # is possible.
316313
317
- Log info " EE Corrupted archive file. Inaccessible revision."
314
+ write 0 cvs "EE Corrupted archive file. Inaccessible revision."
318315
 continue
319316
 }
320317
 return -code error $msg
321318
 }
322319
 }
@@ -345,11 +342,11 @@
345342
 set code [catch {uplevel 1 $script} res]
346343
347344
 # 0 - ok, 1 - error, 2 - return, 3 - break, 4 - continue
348345
 switch -- $code {
349346
 0 {}
350
- 1 { return -errorcode $::errorcode -code error $res }
347
+ 1 { return -errorcode $::errorCode -errorinfo $::errorInfo -code error $res }
351348
 2 {}
352349
 3 { return }
353350
 4 {}
354351
 default {
355352
 return -code $code $result
@@ -373,10 +370,15 @@
373370
374371
 proc ::cvs::ntrunk {} {
375372
 variable ntrunk
376373
 return $ntrunk
377374
 }
375
+
376
+proc ::cvs::ncsets {} {
377
+ variable ncs
378
+ return $ncs
379
+}
378380
379381
 proc ::cvs::uuid {c uuid} {
380382
 variable rtree
381383
 $rtree set $c uuid $uuid
382384
 return
@@ -472,26 +474,10 @@
472474
 puts "$b $o $f $r"
473475
 }
474476
 return
475477
 }
476478
477
-# -----------------------------------------------------------------------------
478
-# Internal helper commands
479
-
480
-proc ::cvs::Log {level text} {
481
- variable lc
482
- uplevel #0 [linsert $lc end $level $text]
483
- return
484
-}
485
-
486
-proc ::cvs::Nop {args} {}
487
-
488
-namespace eval ::cvs {
489
- # Logging callback. No logging by default.
490
- variable lc ::cvs::Nop
491
-}
492
-
493479
 # -----------------------------------------------------------------------------
494480
 # Ready
495481
496482
 package provide cvs 1.0
497483
 return
498484
--- tools/lib/cvs.tcl
+++ tools/lib/cvs.tcl
@@ -3,59 +3,56 @@
3
4 # -----------------------------------------------------------------------------
5 # Requirements
6
7 package require Tcl 8.4
8 package require fileutil ; # Tcllib (cat)
9 package require rcsparser ; # Handling the RCS archive files.
 
10 package require struct::tree
11
12 namespace eval ::cvs {}
 
 
 
13
14 # -----------------------------------------------------------------------------
15 # API
16
17 # Define repository directory.
18
19 proc ::cvs::at {path} {
20 variable base [file normalize $path]
 
21 return
22 }
23
24 namespace eval ::cvs {
25 # Toplevel repository directory
26 variable base {}
27 }
28
29 # Define logging callback command
30
31 proc ::cvs::feedback {logcmd} {
32 variable lc $logcmd
33 ::rcsparser::feedback $logcmd
34 return
35 }
36
37 # Scan repository, collect archives, parse them, and collect revision
38 # information (file, revision -> date, author, commit message)
39
40 proc ::cvs::scan {} {
41 variable base
42 variable npaths
43 variable rpaths
44 variable timeline
45
46 Log info "Scanning CVS tree $base"
47
48 set n 0
49 foreach rcs [fileutil::findByPattern $base -glob *,v] {
50 set rcs [fileutil::stripPath $base $rcs]
51 # Now rcs is relative to base
52
53 Log info " Parsing archive $rcs"
54
55 if {[string match CVSROOT* $rcs]} {
56 Log info " => Ignoring admin file"
57 continue
58 }
59
60 # Derive the regular path from the rcs path. Meaning: Chop of
61 # the ",v" suffix, and remove a possible "Attic".
@@ -64,11 +61,12 @@
64 set f [file join [file dirname [file dirname $f]] [file tail $f]]
65 if {[file exists $base/$f,v]} {
66 # We have a regular archive and an Attic archive
67 # refering to the same user visible file. Ignore the
68 # file in the Attic.
69 Log info " => Ignoring attic for regular archive"
 
70
71 # TODO/CHECK. My method of co'ing exact file revisions
72 # per the info in the collected csets has the flaw
73 # that I may have to know exactly when what archive
74 # file to use, see above. It might be better to use
@@ -85,12 +83,10 @@
85 }
86
87 # Get the meta data we need (revisions, timeline, messages).
88 set meta [::rcsparser::process $base/$rcs]
89
90 Log info " => $f"
91
92 set npaths($rcs) $f
93 set rpaths($f) $rcs
94
95 array set p $meta
96
@@ -103,11 +99,11 @@
103 # seems to exist only! on its branch. The branches
104 # information is set on the revision (extend rcsparser!),
105 # symbols has a tag, refering to a branch, possibly magic.
106
107 if {($rev eq "1.1") && ($op eq "R")} {
108 Log info " => Dead first"
109 }
110
111 lappend timeline($ts) [list $op $ts $a $rev $f $cm]
112 }
113
@@ -115,11 +111,11 @@
115 #parray p
116
117 incr n
118 }
119
120 Log info "Processed $n [expr {($n == 1) ? "file" : "files"}]"
121 return
122 }
123
124 namespace eval ::cvs {
125 # Path mappings. npaths: rcs file -> user file
@@ -143,11 +139,11 @@
143
144 array unset csets * ; array set csets {}
145 array unset cmap * ; array set cmap {}
146 set ncs 0
147
148 Log info "Processing timeline"
149
150 set n 0
151 CSClear
152 foreach ts [lsort -dict [array names timeline]] {
153
@@ -167,13 +163,14 @@
167 CSAdd $entry
168 incr n
169 }
170 }
171
172 Log info "Processed $n [expr {($n == 1) ? "entry" : "entries"}]"
 
173 set n [array size csets]
174 Log info "Found $n [expr {($n == 1) ? "changeset" : "changesets"}]"
175 return
176 }
177
178
179 namespace eval ::cvs {
@@ -192,11 +189,11 @@
192 proc ::cvs::rtree {} {
193 variable csets
194 variable rtree {}
195 variable ntrunk 0
196
197 Log info "Extracting the trunk"
198
199 set rtree [struct::tree ::cvs::RT]
200 $rtree rename root 0 ; # Root is first changeset, always.
201 set trunk 0
202 set ntrunk 1 ; # Root is on the trunk.
@@ -218,12 +215,12 @@
218 $rtree insert $trunk end $c
219 set trunk $c
220 incr ntrunk
221 }
222
223 Log info "Processed $ntrunk trunk [expr {($ntrunk == 1) ? "changeset" : "changesets"}]"
224 Log info "Ignored $b branch [expr {($b == 1) ? "changeset" : "changesets"}]"
225 return
226 }
227
228 namespace eval ::cvs {
229 # Tree holding trunk and branch information (struct::tree).
@@ -237,11 +234,11 @@
237 variable cwd [pwd]
238 variable workspace [fileutil::tempfile importF_cvs_ws_]
239 file delete $workspace
240 file mkdir $workspace
241
242 Log info " Workspace: $workspace"
243
244 cd $workspace ; # Checkouts go here.
245 return $workspace
246 }
247
@@ -266,19 +263,19 @@
266
267 # pwd = workspace
268
269 foreach {u cm s e rd fs} $csets($c) break
270
271 Log info " @ $s"
272
273 foreach l [split [string trim $cm] \n] {
274 Log info " | $l"
275 }
276
277 foreach {f or} $fs {
278 foreach {op r} $or break
279 Log info " -- $op $f $r"
280
281 if {$op eq "R"} {
282 # Remove file from workspace. Prune empty directories.
283 #
284 # NOTE: A dead-first file (rev 1.1 dead) will never have
@@ -312,11 +309,11 @@
312 # a consequence the fossil repository will not
313 # contain the full history of the named file. By
314 # ignoring the problem we however get as much as
315 # is possible.
316
317 Log info " EE Corrupted archive file. Inaccessible revision."
318 continue
319 }
320 return -code error $msg
321 }
322 }
@@ -345,11 +342,11 @@
345 set code [catch {uplevel 1 $script} res]
346
347 # 0 - ok, 1 - error, 2 - return, 3 - break, 4 - continue
348 switch -- $code {
349 0 {}
350 1 { return -errorcode $::errorcode -code error $res }
351 2 {}
352 3 { return }
353 4 {}
354 default {
355 return -code $code $result
@@ -373,10 +370,15 @@
373
374 proc ::cvs::ntrunk {} {
375 variable ntrunk
376 return $ntrunk
377 }
 
 
 
 
 
378
379 proc ::cvs::uuid {c uuid} {
380 variable rtree
381 $rtree set $c uuid $uuid
382 return
@@ -472,26 +474,10 @@
472 puts "$b $o $f $r"
473 }
474 return
475 }
476
477 # -----------------------------------------------------------------------------
478 # Internal helper commands
479
480 proc ::cvs::Log {level text} {
481 variable lc
482 uplevel #0 [linsert $lc end $level $text]
483 return
484 }
485
486 proc ::cvs::Nop {args} {}
487
488 namespace eval ::cvs {
489 # Logging callback. No logging by default.
490 variable lc ::cvs::Nop
491 }
492
493 # -----------------------------------------------------------------------------
494 # Ready
495
496 package provide cvs 1.0
497 return
498
--- tools/lib/cvs.tcl
+++ tools/lib/cvs.tcl
@@ -3,59 +3,56 @@
3
4 # -----------------------------------------------------------------------------
5 # Requirements
6
7 package require Tcl 8.4
8 package require fileutil ; # Tcllib (traverse directory hierarchy)
9 package require rcsparser ; # Handling the RCS archive files.
10 package require tools::log ; # User feedback
11 package require struct::tree
12
13 namespace eval ::cvs {
14 tools::log::system cvs
15 namespace import ::tools::log::write
16 }
17
18 # -----------------------------------------------------------------------------
19 # API
20
21 # Define repository directory.
22
23 proc ::cvs::at {path} {
24 variable base [file normalize $path]
25 write 0 cvs "Base: $base"
26 return
27 }
28
29 namespace eval ::cvs {
30 # Toplevel repository directory
31 variable base {}
32 }
33
 
 
 
 
 
 
 
 
34 # Scan repository, collect archives, parse them, and collect revision
35 # information (file, revision -> date, author, commit message)
36
37 proc ::cvs::scan {} {
38 variable base
39 variable npaths
40 variable rpaths
41 variable timeline
42
43 write 0 cvs {Scanning directory hierarchy}
44
45 set n 0
46 foreach rcs [fileutil::findByPattern $base -glob *,v] {
47 set rcs [fileutil::stripPath $base $rcs]
48 # Now rcs is relative to base
49
50 write 1 cvs "Archive $rcs"
51
52 if {[string match CVSROOT* $rcs]} {
53 write 2 cvs {Ignored. Administrative file}
54 continue
55 }
56
57 # Derive the regular path from the rcs path. Meaning: Chop of
58 # the ",v" suffix, and remove a possible "Attic".
@@ -64,11 +61,12 @@
61 set f [file join [file dirname [file dirname $f]] [file tail $f]]
62 if {[file exists $base/$f,v]} {
63 # We have a regular archive and an Attic archive
64 # refering to the same user visible file. Ignore the
65 # file in the Attic.
66
67 write 2 cvs "Ignored. Attic superceded by regular archive"
68
69 # TODO/CHECK. My method of co'ing exact file revisions
70 # per the info in the collected csets has the flaw
71 # that I may have to know exactly when what archive
72 # file to use, see above. It might be better to use
@@ -85,12 +83,10 @@
83 }
84
85 # Get the meta data we need (revisions, timeline, messages).
86 set meta [::rcsparser::process $base/$rcs]
87
 
 
88 set npaths($rcs) $f
89 set rpaths($f) $rcs
90
91 array set p $meta
92
@@ -103,11 +99,11 @@
99 # seems to exist only! on its branch. The branches
100 # information is set on the revision (extend rcsparser!),
101 # symbols has a tag, refering to a branch, possibly magic.
102
103 if {($rev eq "1.1") && ($op eq "R")} {
104 write 2 cvs {Dead root revision}
105 }
106
107 lappend timeline($ts) [list $op $ts $a $rev $f $cm]
108 }
109
@@ -115,11 +111,11 @@
111 #parray p
112
113 incr n
114 }
115
116 write 0 cvs "Processed $n [expr {($n == 1) ? "file" : "files"}]"
117 return
118 }
119
120 namespace eval ::cvs {
121 # Path mappings. npaths: rcs file -> user file
@@ -143,11 +139,11 @@
139
140 array unset csets * ; array set csets {}
141 array unset cmap * ; array set cmap {}
142 set ncs 0
143
144 write 0 cvs "Processing timeline"
145
146 set n 0
147 CSClear
148 foreach ts [lsort -dict [array names timeline]] {
149
@@ -167,13 +163,14 @@
163 CSAdd $entry
164 incr n
165 }
166 }
167
168 write 0 cvs "Processed $n [expr {($n == 1) ? "entry" : "entries"}]"
169
170 set n [array size csets]
171 write 0 cvs "Found $n [expr {($n == 1) ? "changeset" : "changesets"}]"
172 return
173 }
174
175
176 namespace eval ::cvs {
@@ -192,11 +189,11 @@
189 proc ::cvs::rtree {} {
190 variable csets
191 variable rtree {}
192 variable ntrunk 0
193
194 write 0 cvs "Extracting the trunk"
195
196 set rtree [struct::tree ::cvs::RT]
197 $rtree rename root 0 ; # Root is first changeset, always.
198 set trunk 0
199 set ntrunk 1 ; # Root is on the trunk.
@@ -218,12 +215,12 @@
215 $rtree insert $trunk end $c
216 set trunk $c
217 incr ntrunk
218 }
219
220 write 0 cvs "Processed $ntrunk trunk [expr {($ntrunk == 1) ? "changeset" : "changesets"}]"
221 write 0 cvs "Ignored $b branch [expr {($b == 1) ? "changeset" : "changesets"}]"
222 return
223 }
224
225 namespace eval ::cvs {
226 # Tree holding trunk and branch information (struct::tree).
@@ -237,11 +234,11 @@
234 variable cwd [pwd]
235 variable workspace [fileutil::tempfile importF_cvs_ws_]
236 file delete $workspace
237 file mkdir $workspace
238
239 write 0 cvs "Workspace: $workspace"
240
241 cd $workspace ; # Checkouts go here.
242 return $workspace
243 }
244
@@ -266,19 +263,19 @@
263
264 # pwd = workspace
265
266 foreach {u cm s e rd fs} $csets($c) break
267
268 write 1 cvs "@ $s"
269
270 foreach l [split [string trim $cm] \n] {
271 write 1 cvs "| $l"
272 }
273
274 foreach {f or} $fs {
275 foreach {op r} $or break
276 write 2 cvs "$op $f $r"
277
278 if {$op eq "R"} {
279 # Remove file from workspace. Prune empty directories.
280 #
281 # NOTE: A dead-first file (rev 1.1 dead) will never have
@@ -312,11 +309,11 @@
309 # a consequence the fossil repository will not
310 # contain the full history of the named file. By
311 # ignoring the problem we however get as much as
312 # is possible.
313
314 write 0 cvs "EE Corrupted archive file. Inaccessible revision."
315 continue
316 }
317 return -code error $msg
318 }
319 }
@@ -345,11 +342,11 @@
342 set code [catch {uplevel 1 $script} res]
343
344 # 0 - ok, 1 - error, 2 - return, 3 - break, 4 - continue
345 switch -- $code {
346 0 {}
347 1 { return -errorcode $::errorCode -errorinfo $::errorInfo -code error $res }
348 2 {}
349 3 { return }
350 4 {}
351 default {
352 return -code $code $result
@@ -373,10 +370,15 @@
370
371 proc ::cvs::ntrunk {} {
372 variable ntrunk
373 return $ntrunk
374 }
375
376 proc ::cvs::ncsets {} {
377 variable ncs
378 return $ncs
379 }
380
381 proc ::cvs::uuid {c uuid} {
382 variable rtree
383 $rtree set $c uuid $uuid
384 return
@@ -472,26 +474,10 @@
474 puts "$b $o $f $r"
475 }
476 return
477 }
478
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
479 # -----------------------------------------------------------------------------
480 # Ready
481
482 package provide cvs 1.0
483 return
484
M tools/lib/fossil.tcl
+10 -26
--- tools/lib/fossil.tcl
+++ tools/lib/fossil.tcl
@@ -3,12 +3,16 @@
33
44
 # -----------------------------------------------------------------------------
55
 # Requirements
66
77
 package require Tcl 8.4
8
+package require tools::log ; # User feedback
89
9
-namespace eval ::fossil {}
10
+namespace eval ::fossil {
11
+ tools::log::system fossil
12
+ namespace import ::tools::log::write
13
+}
1014
1115
 # -----------------------------------------------------------------------------
1216
 # API
1317
1418
 # Define repository file, and connect to workspace in CWD.
@@ -19,22 +23,15 @@
1923
2024
 # pwd = workspace
2125
 exec $fossil new $fr ; # create and
2226
 exec $fossil open $fr ; # connect
2327
24
- Log info " Fossil: $fr"
28
+ write 0 fossil "Repository: $fr"
2529
2630
 return $fr
2731
 }
2832
29
-# Define logging callback command
30
-
31
-proc ::fossil::feedback {logcmd} {
32
- variable lc $logcmd
33
- return
34
-}
35
-
3633
 # Move generated fossil repository to final destination
3734
3835
 proc ::fossil::destination {path} {
3936
 variable fr
4037
 file rename $fr $path
@@ -85,24 +82,24 @@
8582
 if {[IGNORE $ignore $path]} continue
8683
8784
 if {![file exists $path]} {
8885
 exec $fossil rm $path
8986
 incr removed
90
- Log info " ** - $path"
87
+ write 2 fossil "- $path"
9188
 } else {
9289
 incr changed
93
- Log info " ** * $path"
90
+ write 2 fossil "* $path"
9491
 }
9592
 }
9693
9794
 # Now look for unregistered added files.
9895
9996
 foreach path [split [exec $fossil extra] \n] {
10097
 if {[IGNORE $ignore $path]} continue
10198
 exec $fossil add $path
10299
 incr added
103
- Log info " ** + $path"
100
+ write 2 fossil "+ $path"
104101
 }
105102
106103
 # Now commit, using the provided meta data, and capture the uuid
107104
 # of the new baseline.
108105
@@ -136,11 +133,11 @@
136133
 # 'Nothing changed' can happen for changesets containing only
137134
 # dead-first revisions of one or more files. For fossil we
138135
 # re-use the last baseline. TODO: Mark them as branchpoint,
139136
 # and for what file.
140137
141
- Log info " UNCHANGED, keeping last"
138
+ write 1 fossil "UNCHANGED, keeping last"
142139
143140
 return [list $lastuuid 0 0 0]
144141
 }
145142
146143
 set line [string trim $line]
@@ -155,23 +152,10 @@
155152
156153
 proc ::fossil::IGNORE {ignore path} {
157154
 return [uplevel #0 [linsert $ignore end $path]]
158155
 }
159156
160
-proc ::fossil::Log {level text} {
161
- variable lc
162
- uplevel #0 [linsert $lc end $level $text]
163
- return
164
-}
165
-
166
-proc ::fossil::Nop {args} {}
167
-
168
-namespace eval ::fossil {
169
- # Logging callback. No logging by default.
170
- variable lc ::fossil::Nop
171
-}
172
-
173157
 # -----------------------------------------------------------------------------
174158
 # Ready
175159
176160
 package provide fossil 1.0
177161
 return
178162
179163
ADDED tools/lib/log.tcl
--- tools/lib/fossil.tcl
+++ tools/lib/fossil.tcl
@@ -3,12 +3,16 @@
3
4 # -----------------------------------------------------------------------------
5 # Requirements
6
7 package require Tcl 8.4
 
8
9 namespace eval ::fossil {}
 
 
 
10
11 # -----------------------------------------------------------------------------
12 # API
13
14 # Define repository file, and connect to workspace in CWD.
@@ -19,22 +23,15 @@
19
20 # pwd = workspace
21 exec $fossil new $fr ; # create and
22 exec $fossil open $fr ; # connect
23
24 Log info " Fossil: $fr"
25
26 return $fr
27 }
28
29 # Define logging callback command
30
31 proc ::fossil::feedback {logcmd} {
32 variable lc $logcmd
33 return
34 }
35
36 # Move generated fossil repository to final destination
37
38 proc ::fossil::destination {path} {
39 variable fr
40 file rename $fr $path
@@ -85,24 +82,24 @@
85 if {[IGNORE $ignore $path]} continue
86
87 if {![file exists $path]} {
88 exec $fossil rm $path
89 incr removed
90 Log info " ** - $path"
91 } else {
92 incr changed
93 Log info " ** * $path"
94 }
95 }
96
97 # Now look for unregistered added files.
98
99 foreach path [split [exec $fossil extra] \n] {
100 if {[IGNORE $ignore $path]} continue
101 exec $fossil add $path
102 incr added
103 Log info " ** + $path"
104 }
105
106 # Now commit, using the provided meta data, and capture the uuid
107 # of the new baseline.
108
@@ -136,11 +133,11 @@
136 # 'Nothing changed' can happen for changesets containing only
137 # dead-first revisions of one or more files. For fossil we
138 # re-use the last baseline. TODO: Mark them as branchpoint,
139 # and for what file.
140
141 Log info " UNCHANGED, keeping last"
142
143 return [list $lastuuid 0 0 0]
144 }
145
146 set line [string trim $line]
@@ -155,23 +152,10 @@
155
156 proc ::fossil::IGNORE {ignore path} {
157 return [uplevel #0 [linsert $ignore end $path]]
158 }
159
160 proc ::fossil::Log {level text} {
161 variable lc
162 uplevel #0 [linsert $lc end $level $text]
163 return
164 }
165
166 proc ::fossil::Nop {args} {}
167
168 namespace eval ::fossil {
169 # Logging callback. No logging by default.
170 variable lc ::fossil::Nop
171 }
172
173 # -----------------------------------------------------------------------------
174 # Ready
175
176 package provide fossil 1.0
177 return
178
179 DDED tools/lib/log.tcl
--- tools/lib/fossil.tcl
+++ tools/lib/fossil.tcl
@@ -3,12 +3,16 @@
3
4 # -----------------------------------------------------------------------------
5 # Requirements
6
7 package require Tcl 8.4
8 package require tools::log ; # User feedback
9
10 namespace eval ::fossil {
11 tools::log::system fossil
12 namespace import ::tools::log::write
13 }
14
15 # -----------------------------------------------------------------------------
16 # API
17
18 # Define repository file, and connect to workspace in CWD.
@@ -19,22 +23,15 @@
23
24 # pwd = workspace
25 exec $fossil new $fr ; # create and
26 exec $fossil open $fr ; # connect
27
28 write 0 fossil "Repository: $fr"
29
30 return $fr
31 }
32
 
 
 
 
 
 
 
33 # Move generated fossil repository to final destination
34
35 proc ::fossil::destination {path} {
36 variable fr
37 file rename $fr $path
@@ -85,24 +82,24 @@
82 if {[IGNORE $ignore $path]} continue
83
84 if {![file exists $path]} {
85 exec $fossil rm $path
86 incr removed
87 write 2 fossil "- $path"
88 } else {
89 incr changed
90 write 2 fossil "* $path"
91 }
92 }
93
94 # Now look for unregistered added files.
95
96 foreach path [split [exec $fossil extra] \n] {
97 if {[IGNORE $ignore $path]} continue
98 exec $fossil add $path
99 incr added
100 write 2 fossil "+ $path"
101 }
102
103 # Now commit, using the provided meta data, and capture the uuid
104 # of the new baseline.
105
@@ -136,11 +133,11 @@
133 # 'Nothing changed' can happen for changesets containing only
134 # dead-first revisions of one or more files. For fossil we
135 # re-use the last baseline. TODO: Mark them as branchpoint,
136 # and for what file.
137
138 write 1 fossil "UNCHANGED, keeping last"
139
140 return [list $lastuuid 0 0 0]
141 }
142
143 set line [string trim $line]
@@ -155,23 +152,10 @@
152
153 proc ::fossil::IGNORE {ignore path} {
154 return [uplevel #0 [linsert $ignore end $path]]
155 }
156
 
 
 
 
 
 
 
 
 
 
 
 
 
157 # -----------------------------------------------------------------------------
158 # Ready
159
160 package provide fossil 1.0
161 return
162
163 DDED tools/lib/log.tcl
A tools/lib/log.tcl
+98
--- a/tools/lib/log.tcl
+++ b/tools/lib/log.tcl
@@ -0,0 +1,98 @@
1
+# -----------------------------------------------------------------------------
2
+# Tool packages. Logging (aka User feedback).
3
+
4
+# -----------------------------------------------------------------------------
5
+# Requirements
6
+
7
+package require Tcl 8.4
8
+namespace eval ::tools::log {}
9
+
10
+# -----------------------------------------------------------------------------
11
+# API
12
+
13
+# Feedback generation.
14
+#
15
+# tools::log::write verbosity system text - Write message to the log.
16
+# tools::log::progress verbosity system n max -therwise a finite display.
17
+
18
+# Admitools::log::verbosity level - Set the verbosity ltools::log::verbosity? - Query the verbosity level of the application.
19
+# of the application.
20
+# vc::too callback for output
21
+# vc::tools::log::system name - Register a system (enables tabular log formatting).
22
+
23
+# Callback API ( Executed at the global level).
24
+#
25
+# cmdprefix 'write' system text
26
+# cmdprefix 'progress' system n max
27
+
28
+# Standard callbacks defined by the package itself write to stdout.
29
+
30
+# -----------------------------------------------------------------------------
31
+# API Implementation - Feedback generation.
32
+
33
+# Write the message 'text' to log, for the named 'system'. The message
34
+# is written if and only if the message verbosity is less or equal the
35
+# chosen verbositytools::log::write {verbosity system text} {
36
+ variable loglevel
37
+ variable logcmd
38
+ variable sysfmt
39
+ if {$verbosity > $loglevel} return
40
+ uplevel #0 [linsert $logcmd end write [format $sysfmt $system] $text]
41
+ return
42
+}
43
+
44
+# Similar to write, especially in the handling of the verbosity, to
45
+# drive progress displays. It signals that for some long running
46
+# operation we are at tick 'n' of attools::log::progress {verbosity system n max} {
47
+ variable loglevel
48
+ variable logcmd
49
+ variable sysfmt
50
+ if {$verbosity > $loglevel} r------------------------------------------------------------
51
+# API Imple---------
52
+# API Implementation - Administrative operations.
53
+
54
+# Set verbosity to the chosen 'level'. Only messages with a level less
55
+# or equal to this one will be shown.
56
+
57
+proc ::vc::tools::log::verbosity {level} {
58
+ variable loglevel
59
+ if {$level < 1} {set level 0}
60
+ stools::log::verbositypplication.
61
+# vc::tools::log::verbosity? - Query the verbosity level of the application.
62
+# vc::tools::log::setCmd cmdprefix - Set callback for otools::log::verbosity? {} {
63
+ variable loglevel
64
+ em (enables tabular log formatting).
65
+
66
+# Callback API ( Executed at the global level).
67
+#
68
+# cmd cmdprefix 'progress' system n max
69
+
70
+# Standard callbacks defined by the package itself write to stdout.
71
+
72
+# -----------------------------------------------------------------------------
73
+# API Implementation - Feedback generation.
74
+
75
+# Write the message 'text' to log, for t callback for outpu{name} {
76
+ variable f and only if the message verbosity is less or equal the
77
+# chosen verbosity. A message of verbosity 0 cannot be blocked.
78
+
79
+proc ::vc::tools::log::write {verbosity system text} {
80
+ variable loglevel
81
+ variable logcmd
82
+ variable sysfmt
83
+ if {$verbosity > $loglevel} return
84
+ uplevel #0 [linsert $logcmd end write [format $sysfmt $system] $text]
85
+ , especially in the handling ---------------- It signals that for some long running
86
+# operation we are at tick 'n----------------tick 'n' of at most 'max' ticks.
87
+
88
+proc ::vc::tools::log::progress {verbosity systemingel
89
+ variable logcmd
90
+ variable sysfmt
91
+ if {$verbosity > $loglevel} r--------------------------------------------------------
92
+# API Imple---------
93
+# API Implementation - Administrative operations.
94
+
95
+# Set verbosity to the chosen 'level'. Only messages with a level less
96
+# or equal to this oools::log::verbosity {leve# -----------------------------------------------------------------------------------------------------------------------------
97
+# Tool packages. Loggintools::log 1.0
98
+return
--- a/tools/lib/log.tcl
+++ b/tools/lib/log.tcl
@@ -0,0 +1,98 @@
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
--- a/tools/lib/log.tcl
+++ b/tools/lib/log.tcl
@@ -0,0 +1,98 @@
1 # -----------------------------------------------------------------------------
2 # Tool packages. Logging (aka User feedback).
3
4 # -----------------------------------------------------------------------------
5 # Requirements
6
7 package require Tcl 8.4
8 namespace eval ::tools::log {}
9
10 # -----------------------------------------------------------------------------
11 # API
12
13 # Feedback generation.
14 #
15 # tools::log::write verbosity system text - Write message to the log.
16 # tools::log::progress verbosity system n max -therwise a finite display.
17
18 # Admitools::log::verbosity level - Set the verbosity ltools::log::verbosity? - Query the verbosity level of the application.
19 # of the application.
20 # vc::too callback for output
21 # vc::tools::log::system name - Register a system (enables tabular log formatting).
22
23 # Callback API ( Executed at the global level).
24 #
25 # cmdprefix 'write' system text
26 # cmdprefix 'progress' system n max
27
28 # Standard callbacks defined by the package itself write to stdout.
29
30 # -----------------------------------------------------------------------------
31 # API Implementation - Feedback generation.
32
33 # Write the message 'text' to log, for the named 'system'. The message
34 # is written if and only if the message verbosity is less or equal the
35 # chosen verbositytools::log::write {verbosity system text} {
36 variable loglevel
37 variable logcmd
38 variable sysfmt
39 if {$verbosity > $loglevel} return
40 uplevel #0 [linsert $logcmd end write [format $sysfmt $system] $text]
41 return
42 }
43
44 # Similar to write, especially in the handling of the verbosity, to
45 # drive progress displays. It signals that for some long running
46 # operation we are at tick 'n' of attools::log::progress {verbosity system n max} {
47 variable loglevel
48 variable logcmd
49 variable sysfmt
50 if {$verbosity > $loglevel} r------------------------------------------------------------
51 # API Imple---------
52 # API Implementation - Administrative operations.
53
54 # Set verbosity to the chosen 'level'. Only messages with a level less
55 # or equal to this one will be shown.
56
57 proc ::vc::tools::log::verbosity {level} {
58 variable loglevel
59 if {$level < 1} {set level 0}
60 stools::log::verbositypplication.
61 # vc::tools::log::verbosity? - Query the verbosity level of the application.
62 # vc::tools::log::setCmd cmdprefix - Set callback for otools::log::verbosity? {} {
63 variable loglevel
64 em (enables tabular log formatting).
65
66 # Callback API ( Executed at the global level).
67 #
68 # cmd cmdprefix 'progress' system n max
69
70 # Standard callbacks defined by the package itself write to stdout.
71
72 # -----------------------------------------------------------------------------
73 # API Implementation - Feedback generation.
74
75 # Write the message 'text' to log, for t callback for outpu{name} {
76 variable f and only if the message verbosity is less or equal the
77 # chosen verbosity. A message of verbosity 0 cannot be blocked.
78
79 proc ::vc::tools::log::write {verbosity system text} {
80 variable loglevel
81 variable logcmd
82 variable sysfmt
83 if {$verbosity > $loglevel} return
84 uplevel #0 [linsert $logcmd end write [format $sysfmt $system] $text]
85 , especially in the handling ---------------- It signals that for some long running
86 # operation we are at tick 'n----------------tick 'n' of at most 'max' ticks.
87
88 proc ::vc::tools::log::progress {verbosity systemingel
89 variable logcmd
90 variable sysfmt
91 if {$verbosity > $loglevel} r--------------------------------------------------------
92 # API Imple---------
93 # API Implementation - Administrative operations.
94
95 # Set verbosity to the chosen 'level'. Only messages with a level less
96 # or equal to this oools::log::verbosity {leve# -----------------------------------------------------------------------------------------------------------------------------
97 # Tool packages. Loggintools::log 1.0
98 return
M tools/lib/pkgIndex.tcl
+1
--- tools/lib/pkgIndex.tcl
+++ tools/lib/pkgIndex.tcl
@@ -1,4 +1,5 @@
11
 if {![package vsatisfies [package require Tcl] 8.4]} return
22
 package ifneeded rcsparser 1.0 [list source [file join $dir rcsparser.tcl]]
33
 package ifneeded cvs 1.0 [list source [file join $dir cvs.tcl]]
44
 package ifneeded fossil 1.0 [list source [file join $dir fossil.tcl]]
5
+package ifneeded tools::log 1.0 [list source [file join $dir log.tcl]]
56
--- tools/lib/pkgIndex.tcl
+++ tools/lib/pkgIndex.tcl
@@ -1,4 +1,5 @@
1 if {![package vsatisfies [package require Tcl] 8.4]} return
2 package ifneeded rcsparser 1.0 [list source [file join $dir rcsparser.tcl]]
3 package ifneeded cvs 1.0 [list source [file join $dir cvs.tcl]]
4 package ifneeded fossil 1.0 [list source [file join $dir fossil.tcl]]
 
5
--- tools/lib/pkgIndex.tcl
+++ tools/lib/pkgIndex.tcl
@@ -1,4 +1,5 @@
1 if {![package vsatisfies [package require Tcl] 8.4]} return
2 package ifneeded rcsparser 1.0 [list source [file join $dir rcsparser.tcl]]
3 package ifneeded cvs 1.0 [list source [file join $dir cvs.tcl]]
4 package ifneeded fossil 1.0 [list source [file join $dir fossil.tcl]]
5 package ifneeded tools::log 1.0 [list source [file join $dir log.tcl]]
6
M tools/lib/rcsparser.tcl
+45 -41
--- tools/lib/rcsparser.tcl
+++ tools/lib/rcsparser.tcl
@@ -1,25 +1,53 @@
1
-
21
 # -----------------------------------------------------------------------------
3
-# Parse RCS files (,v) - ignore the deltas - we need only the commit messages
4
-# Recursive Descent Parser
2
+# Tool packages. Parsing RCS files.
3
+#
4
+# Some of the information in RCS files is skipped over, most
5
+# importantly the actual delta texts. The users of this parser need
6
+# only the meta-data about when revisions were added, the tree
7
+# (branching) structure, commit messages.
8
+#
9
+# The parser is based on Recursive Descent.
510
611
 # -----------------------------------------------------------------------------
712
 # Requirements
813
914
 package require Tcl 8.4
10
-package require fileutil ; # Tcllib (cat)
15
+package require fileutil ; # Tcllib (cat)
16
+package require tools::log ; # User feedback
1117
12
-namespace eval ::rcsparser {}
18
+namespace eval ::rcsparser {
19
+ tools::log::system rcs
20
+ namespace import ::tools::log::progress
21
+}
1322
1423
 # -----------------------------------------------------------------------------
1524
 # API
1625
17
-proc ::rcsparser::feedback {logcmd} {
18
- variable lc $logcmd
19
- return
20
-}
26
+# rcsparser::process file
27
+#
28
+# Parses the rcs file and returns a dictionary containing the meta
29
+# data. The following keys are used
30
+#
31
+# Key Meaning
32
+# --- -------
33
+# 'head' head revision
34
+# 'branch' ?
35
+# 'symbol' dict (symbol -> revision)
36
+# 'lock' dict (symbol -> revision)
37
+# 'comment' file comment
38
+# 'expand' ?
39
+# 'date' dict (revision -> date)
40
+# 'author' dict (revision -> author)
41
+# 'state' dict (revision -> state)
42
+# 'parent' dict (revision -> parent revision)
43
+# 'commit' dict (revision -> commit message)
44
+#
45
+# The state 'dead' has special meaning, the user should know that.
46
+
47
+# -----------------------------------------------------------------------------
48
+# API Implementation
2149
2250
 proc ::rcsparser::process {path} {
2351
 set data [fileutil::cat -encoding binary $path]
2452
 array set res {}
2553
 set res(size) [file size $path]
@@ -29,36 +57,22 @@
2957
 Admin
3058
 Deltas
3159
 Description
3260
 DeltaTexts
3361
34
- Feedback \r
35
-
3662
 # Remove parser state
3763
 catch {unset res(id)}
3864
 catch {unset res(lastval)}
3965
 unset res(size)
4066
 unset res(nsize)
4167
 unset res(done)
4268
43
- # res: 'head' -> head revision
44
- # 'branch' -> ?
45
- # 'symbol' -> (sym -> revision)
46
- # 'lock' -> (sym -> revision)
47
- # 'comment' -> file comment
48
- # 'expand' -> ?
49
- # 'date' -> (revision -> date)
50
- # 'author' -> (revision -> author)
51
- # 'state' -> (revision -> state)
52
- # 'parent' -> (revision -> parent revision)
53
- # 'commit' -> (revision -> commit message)
54
-
5569
 return [array get res]
5670
 }
5771
5872
 # -----------------------------------------------------------------------------
59
-# Internal helper commands
73
+# Internal - Recursive Descent functions implementing the syntax.
6074
6175
 proc ::rcsparser::Admin {} {
6276
 upvar 1 data data res res
6377
 Head ; Branch ; Access ; Symbols ; Locks ; Strict ; Comment ; Expand
6478
 return
@@ -190,10 +204,11 @@
190204
 Literal text ; String 1
191205
 return
192206
 }
193207
194208
 # -----------------------------------------------------------------------------
209
+# Internal - Lexicographical commands and data aquisition preparation
195210
196211
 proc ::rcsparser::Ident {} {
197212
 upvar 1 data data res res
198213
199214
 #puts I@?<[string range $data 0 10]...>
@@ -256,10 +271,13 @@
256271
 regexp -indices -- {^\s*([^;]*)\s*} $data match val
257272
 Get $val
258273
 Next
259274
 return
260275
 }
276
+
277
+# -----------------------------------------------------------------------------
278
+# Internal - Data aquisition
261279
262280
 proc ::rcsparser::Def {key} {
263281
 upvar 1 data data res res
264282
 set res($key) $res(lastval)
265283
 unset res(lastval)
@@ -294,28 +312,14 @@
294312
 upvar 1 match match data data res res
295313
 foreach {s e} $match break ; incr e
296314
 set data [string range $data $e end]
297315
 set res(done) [expr {$res(size) - [string length $data]}]
298316
299
- Feedback "\r [format "%$res(nsize)s" $res(done)]/$res(size) "
300
- return
301
-}
302
-
303
-# -----------------------------------------------------------------------------
304
-
305
-namespace eval ::rcsparser {
306
- variable lc ::rcs::Nop
307
-}
308
-
309
-proc ::rcsparser::Feedback {text} {
310
- variable lc
311
- uplevel #0 [linsert $lc end info $text]
312
- return
313
-}
314
-
315
-proc ::rcsparser::Nop {args} {}
317
+ progress 2 rcs $res(done) $res(size)
318
+ return
319
+}
316320
317321
 # -----------------------------------------------------------------------------
318322
 # Ready
319323
320324
 package provide rcsparser 1.0
321325
 return
322326
--- tools/lib/rcsparser.tcl
+++ tools/lib/rcsparser.tcl
@@ -1,25 +1,53 @@
1
2 # -----------------------------------------------------------------------------
3 # Parse RCS files (,v) - ignore the deltas - we need only the commit messages
4 # Recursive Descent Parser
 
 
 
 
 
 
5
6 # -----------------------------------------------------------------------------
7 # Requirements
8
9 package require Tcl 8.4
10 package require fileutil ; # Tcllib (cat)
 
11
12 namespace eval ::rcsparser {}
 
 
 
13
14 # -----------------------------------------------------------------------------
15 # API
16
17 proc ::rcsparser::feedback {logcmd} {
18 variable lc $logcmd
19 return
20 }
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
21
22 proc ::rcsparser::process {path} {
23 set data [fileutil::cat -encoding binary $path]
24 array set res {}
25 set res(size) [file size $path]
@@ -29,36 +57,22 @@
29 Admin
30 Deltas
31 Description
32 DeltaTexts
33
34 Feedback \r
35
36 # Remove parser state
37 catch {unset res(id)}
38 catch {unset res(lastval)}
39 unset res(size)
40 unset res(nsize)
41 unset res(done)
42
43 # res: 'head' -> head revision
44 # 'branch' -> ?
45 # 'symbol' -> (sym -> revision)
46 # 'lock' -> (sym -> revision)
47 # 'comment' -> file comment
48 # 'expand' -> ?
49 # 'date' -> (revision -> date)
50 # 'author' -> (revision -> author)
51 # 'state' -> (revision -> state)
52 # 'parent' -> (revision -> parent revision)
53 # 'commit' -> (revision -> commit message)
54
55 return [array get res]
56 }
57
58 # -----------------------------------------------------------------------------
59 # Internal helper commands
60
61 proc ::rcsparser::Admin {} {
62 upvar 1 data data res res
63 Head ; Branch ; Access ; Symbols ; Locks ; Strict ; Comment ; Expand
64 return
@@ -190,10 +204,11 @@
190 Literal text ; String 1
191 return
192 }
193
194 # -----------------------------------------------------------------------------
 
195
196 proc ::rcsparser::Ident {} {
197 upvar 1 data data res res
198
199 #puts I@?<[string range $data 0 10]...>
@@ -256,10 +271,13 @@
256 regexp -indices -- {^\s*([^;]*)\s*} $data match val
257 Get $val
258 Next
259 return
260 }
 
 
 
261
262 proc ::rcsparser::Def {key} {
263 upvar 1 data data res res
264 set res($key) $res(lastval)
265 unset res(lastval)
@@ -294,28 +312,14 @@
294 upvar 1 match match data data res res
295 foreach {s e} $match break ; incr e
296 set data [string range $data $e end]
297 set res(done) [expr {$res(size) - [string length $data]}]
298
299 Feedback "\r [format "%$res(nsize)s" $res(done)]/$res(size) "
300 return
301 }
302
303 # -----------------------------------------------------------------------------
304
305 namespace eval ::rcsparser {
306 variable lc ::rcs::Nop
307 }
308
309 proc ::rcsparser::Feedback {text} {
310 variable lc
311 uplevel #0 [linsert $lc end info $text]
312 return
313 }
314
315 proc ::rcsparser::Nop {args} {}
316
317 # -----------------------------------------------------------------------------
318 # Ready
319
320 package provide rcsparser 1.0
321 return
322
--- tools/lib/rcsparser.tcl
+++ tools/lib/rcsparser.tcl
@@ -1,25 +1,53 @@
 
1 # -----------------------------------------------------------------------------
2 # Tool packages. Parsing RCS files.
3 #
4 # Some of the information in RCS files is skipped over, most
5 # importantly the actual delta texts. The users of this parser need
6 # only the meta-data about when revisions were added, the tree
7 # (branching) structure, commit messages.
8 #
9 # The parser is based on Recursive Descent.
10
11 # -----------------------------------------------------------------------------
12 # Requirements
13
14 package require Tcl 8.4
15 package require fileutil ; # Tcllib (cat)
16 package require tools::log ; # User feedback
17
18 namespace eval ::rcsparser {
19 tools::log::system rcs
20 namespace import ::tools::log::progress
21 }
22
23 # -----------------------------------------------------------------------------
24 # API
25
26 # rcsparser::process file
27 #
28 # Parses the rcs file and returns a dictionary containing the meta
29 # data. The following keys are used
30 #
31 # Key Meaning
32 # --- -------
33 # 'head' head revision
34 # 'branch' ?
35 # 'symbol' dict (symbol -> revision)
36 # 'lock' dict (symbol -> revision)
37 # 'comment' file comment
38 # 'expand' ?
39 # 'date' dict (revision -> date)
40 # 'author' dict (revision -> author)
41 # 'state' dict (revision -> state)
42 # 'parent' dict (revision -> parent revision)
43 # 'commit' dict (revision -> commit message)
44 #
45 # The state 'dead' has special meaning, the user should know that.
46
47 # -----------------------------------------------------------------------------
48 # API Implementation
49
50 proc ::rcsparser::process {path} {
51 set data [fileutil::cat -encoding binary $path]
52 array set res {}
53 set res(size) [file size $path]
@@ -29,36 +57,22 @@
57 Admin
58 Deltas
59 Description
60 DeltaTexts
61
 
 
62 # Remove parser state
63 catch {unset res(id)}
64 catch {unset res(lastval)}
65 unset res(size)
66 unset res(nsize)
67 unset res(done)
68
 
 
 
 
 
 
 
 
 
 
 
 
69 return [array get res]
70 }
71
72 # -----------------------------------------------------------------------------
73 # Internal - Recursive Descent functions implementing the syntax.
74
75 proc ::rcsparser::Admin {} {
76 upvar 1 data data res res
77 Head ; Branch ; Access ; Symbols ; Locks ; Strict ; Comment ; Expand
78 return
@@ -190,10 +204,11 @@
204 Literal text ; String 1
205 return
206 }
207
208 # -----------------------------------------------------------------------------
209 # Internal - Lexicographical commands and data aquisition preparation
210
211 proc ::rcsparser::Ident {} {
212 upvar 1 data data res res
213
214 #puts I@?<[string range $data 0 10]...>
@@ -256,10 +271,13 @@
271 regexp -indices -- {^\s*([^;]*)\s*} $data match val
272 Get $val
273 Next
274 return
275 }
276
277 # -----------------------------------------------------------------------------
278 # Internal - Data aquisition
279
280 proc ::rcsparser::Def {key} {
281 upvar 1 data data res res
282 set res($key) $res(lastval)
283 unset res(lastval)
@@ -294,28 +312,14 @@
312 upvar 1 match match data data res res
313 foreach {s e} $match break ; incr e
314 set data [string range $data $e end]
315 set res(done) [expr {$res(size) - [string length $data]}]
316
317 progress 2 rcs $res(done) $res(size)
318 return
319 }
 
 
 
 
 
 
 
 
 
 
 
 
 
 
320
321 # -----------------------------------------------------------------------------
322 # Ready
323
324 package provide rcsparser 1.0
325 return
326

Keyboard Shortcuts

Open search /
Next entry (timeline) j
Previous entry (timeline) k
Open focused entry Enter
Show this help ?
Toggle theme Top nav button