|
e7bb3d0…
|
aku
|
1 |
## -*- tcl -*- |
|
e7bb3d0…
|
aku
|
2 |
# # ## ### ##### ######## ############# ##################### |
|
e7bb3d0…
|
aku
|
3 |
## Copyright (c) 2007 Andreas Kupries. |
|
e7bb3d0…
|
aku
|
4 |
# |
|
e7bb3d0…
|
aku
|
5 |
# This software is licensed as described in the file LICENSE, which |
|
e7bb3d0…
|
aku
|
6 |
# you should have received as part of this distribution. |
|
e7bb3d0…
|
aku
|
7 |
# |
|
e7bb3d0…
|
aku
|
8 |
# This software consists of voluntary contributions made by many |
|
e7bb3d0…
|
aku
|
9 |
# individuals. For exact contribution history, see the revision |
|
e7bb3d0…
|
aku
|
10 |
# history and logs, available at http://fossil-scm.hwaci.com/fossil |
|
e7bb3d0…
|
aku
|
11 |
# # ## ### ##### ######## ############# ##################### |
|
e7bb3d0…
|
aku
|
12 |
|
|
e7bb3d0…
|
aku
|
13 |
# A tool package, provides a parser for RCS archive files. This parser |
|
e7bb3d0…
|
aku
|
14 |
# is implemented via recursive descent. It is not only given a file to |
|
e7bb3d0…
|
aku
|
15 |
# process, but also a 'sink', an object it calls out to at important |
|
e7bb3d0…
|
aku
|
16 |
# places of the parsing process to either signal an event and/or |
|
e7bb3d0…
|
aku
|
17 |
# convey gathered information to it. The sink is responsible for the |
|
e7bb3d0…
|
aku
|
18 |
# actual processing of the data in whatever way it desires. |
|
e7bb3d0…
|
aku
|
19 |
|
|
e7bb3d0…
|
aku
|
20 |
# # ## ### ##### ######## ############# ##################### |
|
e7bb3d0…
|
aku
|
21 |
## Requirements |
|
e7bb3d0…
|
aku
|
22 |
|
|
e7bb3d0…
|
aku
|
23 |
package require Tcl 8.4 ; # Required runtime. |
|
e7bb3d0…
|
aku
|
24 |
package require snit ; # OO system. |
|
e7bb3d0…
|
aku
|
25 |
package require fileutil ; # File utilities. |
|
e7bb3d0…
|
aku
|
26 |
package require vc::tools::log ; # User feedback. |
|
e7bb3d0…
|
aku
|
27 |
package require struct::list ; # Advanced list ops. |
|
e7bb3d0…
|
aku
|
28 |
|
|
e7bb3d0…
|
aku
|
29 |
# # ## ### ##### ######## ############# ##################### |
|
b679ca3…
|
aku
|
30 |
## |
|
e7bb3d0…
|
aku
|
31 |
|
|
e7bb3d0…
|
aku
|
32 |
snit::type ::vc::rcs::parser { |
|
e7bb3d0…
|
aku
|
33 |
# # ## ### ##### ######## ############# |
|
e7bb3d0…
|
aku
|
34 |
## Public API |
|
e7bb3d0…
|
aku
|
35 |
|
|
e7bb3d0…
|
aku
|
36 |
typemethod process {path sink} { |
|
e7bb3d0…
|
aku
|
37 |
Initialize $path $sink |
|
e7bb3d0…
|
aku
|
38 |
Call begin |
|
e7bb3d0…
|
aku
|
39 |
Admin ; Deltas ; Description ; DeltaTexts |
|
e7bb3d0…
|
aku
|
40 |
Call done |
|
e7bb3d0…
|
aku
|
41 |
return |
|
e7bb3d0…
|
aku
|
42 |
} |
|
e7bb3d0…
|
aku
|
43 |
|
|
e7bb3d0…
|
aku
|
44 |
# # ## ### ##### ######## ############# |
|
e7bb3d0…
|
aku
|
45 |
## Internal methods, recursive descent, syntactical processing |
|
e7bb3d0…
|
aku
|
46 |
|
|
e7bb3d0…
|
aku
|
47 |
proc Admin {} { |
|
e7bb3d0…
|
aku
|
48 |
Head ; PrincipalBranch ; Access ; Symbols |
|
e7bb3d0…
|
aku
|
49 |
Locks ; Strictness ; FileComment ; Expand |
|
e7bb3d0…
|
aku
|
50 |
Call admindone |
|
e7bb3d0…
|
aku
|
51 |
return |
|
e7bb3d0…
|
aku
|
52 |
} |
|
e7bb3d0…
|
aku
|
53 |
|
|
e7bb3d0…
|
aku
|
54 |
# # ## ### ##### ######## ############# |
|
e7bb3d0…
|
aku
|
55 |
|
|
e7bb3d0…
|
aku
|
56 |
proc Head {} { |
|
e7bb3d0…
|
aku
|
57 |
RequiredLiteral head |
|
e7bb3d0…
|
aku
|
58 |
RequiredNumber -> head |
|
e7bb3d0…
|
aku
|
59 |
Semicolon |
|
e7bb3d0…
|
aku
|
60 |
Call sethead $head |
|
e7bb3d0…
|
aku
|
61 |
return |
|
e7bb3d0…
|
aku
|
62 |
} |
|
e7bb3d0…
|
aku
|
63 |
|
|
e7bb3d0…
|
aku
|
64 |
proc PrincipalBranch {} { |
|
e7bb3d0…
|
aku
|
65 |
if {![OptionalLiteral branch]} return |
|
e7bb3d0…
|
aku
|
66 |
RequiredNumber -> branch |
|
e7bb3d0…
|
aku
|
67 |
Semicolon |
|
e7bb3d0…
|
aku
|
68 |
Call setprincipalbranch $branch |
|
e7bb3d0…
|
aku
|
69 |
return |
|
e7bb3d0…
|
aku
|
70 |
} |
|
e7bb3d0…
|
aku
|
71 |
|
|
e7bb3d0…
|
aku
|
72 |
proc Access {} { |
|
e7bb3d0…
|
aku
|
73 |
RequiredLiteral access ; |
|
e7bb3d0…
|
aku
|
74 |
Semicolon |
|
e7bb3d0…
|
aku
|
75 |
return |
|
e7bb3d0…
|
aku
|
76 |
} |
|
e7bb3d0…
|
aku
|
77 |
|
|
e7bb3d0…
|
aku
|
78 |
proc Symbols {} { |
|
e7bb3d0…
|
aku
|
79 |
RequiredLiteral symbols |
|
e7bb3d0…
|
aku
|
80 |
while {[Ident -> symbol]} { |
|
fa643aa…
|
aku
|
81 |
if { |
|
fa643aa…
|
aku
|
82 |
*$} $symbol] || |
|
fa643aa…
|
aku
|
83 |
[string match */ $symbol] |
|
fa643aa…
|
aku
|
84 |
} { |
|
1527954…
|
aku
|
85 |
Rewind |
|
1527954…
|
aku
|
86 |
Bad {symbol name} |
|
1527954…
|
aku
|
87 |
} |
|
e7bb3d0…
|
aku
|
88 |
RequiredNumber -> rev |
|
338854a…
|
aku
|
89 |
Call deftag $symbol $rev |
|
e7bb3d0…
|
aku
|
90 |
} |
|
e7bb3d0…
|
aku
|
91 |
Semicolon |
|
e7bb3d0…
|
aku
|
92 |
return |
|
e7bb3d0…
|
aku
|
93 |
} |
|
e7bb3d0…
|
aku
|
94 |
|
|
e7bb3d0…
|
aku
|
95 |
proc Locks {} { |
|
e7bb3d0…
|
aku
|
96 |
# Not saving locks. |
|
e7bb3d0…
|
aku
|
97 |
RequiredLiteral locks |
|
e7bb3d0…
|
aku
|
98 |
while {[Ident -> symbol]} { |
|
e7bb3d0…
|
aku
|
99 |
RequiredNumber -> l |
|
e7bb3d0…
|
aku
|
100 |
} |
|
e7bb3d0…
|
aku
|
101 |
Semicolon |
|
e7bb3d0…
|
aku
|
102 |
return |
|
e7bb3d0…
|
aku
|
103 |
} |
|
e7bb3d0…
|
aku
|
104 |
|
|
e7bb3d0…
|
aku
|
105 |
proc Strictness {} { |
|
e7bb3d0…
|
aku
|
106 |
# Not saving strictness |
|
e7bb3d0…
|
aku
|
107 |
if {![OptionalLiteral strict]} return |
|
e7bb3d0…
|
aku
|
108 |
Semicolon |
|
e7bb3d0…
|
aku
|
109 |
return |
|
e7bb3d0…
|
aku
|
110 |
} |
|
e7bb3d0…
|
aku
|
111 |
|
|
e7bb3d0…
|
aku
|
112 |
proc FileComment {} { |
|
e7bb3d0…
|
aku
|
113 |
if {![OptionalLiteral comment]} return |
|
e7bb3d0…
|
aku
|
114 |
if {![OptionalString -> c]} return |
|
e7bb3d0…
|
aku
|
115 |
Semicolon |
|
e7bb3d0…
|
aku
|
116 |
Call setcomment $c |
|
e7bb3d0…
|
aku
|
117 |
return |
|
e7bb3d0…
|
aku
|
118 |
} |
|
e7bb3d0…
|
aku
|
119 |
|
|
e7bb3d0…
|
aku
|
120 |
proc Expand {} { |
|
e7bb3d0…
|
aku
|
121 |
# Not saving expanded keywords |
|
e7bb3d0…
|
aku
|
122 |
if {![OptionalLiteral expand]} return |
|
e7bb3d0…
|
aku
|
123 |
if {![OptionalString -> dummy]} return |
|
e7bb3d0…
|
aku
|
124 |
Semicolon |
|
e7bb3d0…
|
aku
|
125 |
return |
|
e7bb3d0…
|
aku
|
126 |
} |
|
e7bb3d0…
|
aku
|
127 |
|
|
e7bb3d0…
|
aku
|
128 |
# # ## ### ##### ######## ############# |
|
e7bb3d0…
|
aku
|
129 |
|
|
e7bb3d0…
|
aku
|
130 |
proc Deltas {} { |
|
294156a…
|
aku
|
131 |
set ok [OptionalNumber -> rev] |
|
294156a…
|
aku
|
132 |
while {$ok} { |
|
e7bb3d0…
|
aku
|
133 |
Date -> d |
|
e7bb3d0…
|
aku
|
134 |
Author -> a |
|
e7bb3d0…
|
aku
|
135 |
State -> s |
|
e7bb3d0…
|
aku
|
136 |
Branches -> b |
|
e7bb3d0…
|
aku
|
137 |
NextRev -> n |
|
e7bb3d0…
|
aku
|
138 |
Call def $rev $d $a $s $n $b |
|
294156a…
|
aku
|
139 |
|
|
294156a…
|
aku
|
140 |
# Check if this is followed by a revision number or the |
|
294156a…
|
aku
|
141 |
# literal 'desc'. If neither we consume whatever is there |
|
294156a…
|
aku
|
142 |
# until the next semicolon, as it has to be a 'new |
|
294156a…
|
aku
|
143 |
# phrase'. Otherwise, for a revision number we loop back |
|
294156a…
|
aku
|
144 |
# and consume that revision, and lastly for 'desc' we stop |
|
294156a…
|
aku
|
145 |
# completely as this signals the end of the revision tree |
|
294156a…
|
aku
|
146 |
# and the beginning of the deltas. |
|
294156a…
|
aku
|
147 |
|
|
294156a…
|
aku
|
148 |
while {1} { |
|
294156a…
|
aku
|
149 |
set ok [OptionalNumber -> rev] |
|
294156a…
|
aku
|
150 |
if {$ok} break |
|
294156a…
|
aku
|
151 |
|
|
294156a…
|
aku
|
152 |
if {[LiteralPeek desc]} { |
|
294156a…
|
aku
|
153 |
set ok 0 |
|
294156a…
|
aku
|
154 |
break |
|
294156a…
|
aku
|
155 |
} |
|
294156a…
|
aku
|
156 |
|
|
294156a…
|
aku
|
157 |
Anything -> dummy |
|
294156a…
|
aku
|
158 |
Semicolon |
|
294156a…
|
aku
|
159 |
} |
|
e7bb3d0…
|
aku
|
160 |
} |
|
40eaf58…
|
aku
|
161 |
Call defdone |
|
e7bb3d0…
|
aku
|
162 |
return |
|
e7bb3d0…
|
aku
|
163 |
} |
|
e7bb3d0…
|
aku
|
164 |
|
|
e7bb3d0…
|
aku
|
165 |
# # ## ### ##### ######## ############# |
|
e7bb3d0…
|
aku
|
166 |
|
|
e7bb3d0…
|
aku
|
167 |
proc Date {_ dv} { |
|
e7bb3d0…
|
aku
|
168 |
upvar 1 $dv d |
|
e7bb3d0…
|
aku
|
169 |
RequiredLiteral date |
|
e7bb3d0…
|
aku
|
170 |
RequiredNumber -> d |
|
e7bb3d0…
|
aku
|
171 |
Semicolon |
|
e7bb3d0…
|
aku
|
172 |
|
|
e7bb3d0…
|
aku
|
173 |
struct::list assign [split $d .] year month day hour min sec |
|
e7bb3d0…
|
aku
|
174 |
if {$year < 100} {incr year 1900} |
|
e7bb3d0…
|
aku
|
175 |
set d [clock scan "${year}-${month}-${day} ${hour}:${min}:${sec}"] |
|
e7bb3d0…
|
aku
|
176 |
return |
|
e7bb3d0…
|
aku
|
177 |
} |
|
e7bb3d0…
|
aku
|
178 |
|
|
e7bb3d0…
|
aku
|
179 |
proc Author {_ av} { |
|
e7bb3d0…
|
aku
|
180 |
upvar 1 $av a |
|
e7bb3d0…
|
aku
|
181 |
RequiredLiteral author |
|
e7bb3d0…
|
aku
|
182 |
Anything -> a |
|
e7bb3d0…
|
aku
|
183 |
Semicolon |
|
e7bb3d0…
|
aku
|
184 |
return |
|
e7bb3d0…
|
aku
|
185 |
} |
|
e7bb3d0…
|
aku
|
186 |
|
|
e7bb3d0…
|
aku
|
187 |
proc State {_ sv} { |
|
e7bb3d0…
|
aku
|
188 |
upvar 1 $sv s |
|
e7bb3d0…
|
aku
|
189 |
RequiredLiteral state |
|
e7bb3d0…
|
aku
|
190 |
Anything -> s |
|
e7bb3d0…
|
aku
|
191 |
Semicolon |
|
e7bb3d0…
|
aku
|
192 |
return |
|
e7bb3d0…
|
aku
|
193 |
} |
|
e7bb3d0…
|
aku
|
194 |
|
|
e7bb3d0…
|
aku
|
195 |
proc Branches {_ bv} { |
|
e7bb3d0…
|
aku
|
196 |
upvar 1 $bv b |
|
e7bb3d0…
|
aku
|
197 |
RequiredLiteral branches |
|
e7bb3d0…
|
aku
|
198 |
Anything -> b |
|
e7bb3d0…
|
aku
|
199 |
Semicolon |
|
e7bb3d0…
|
aku
|
200 |
return |
|
e7bb3d0…
|
aku
|
201 |
} |
|
e7bb3d0…
|
aku
|
202 |
|
|
e7bb3d0…
|
aku
|
203 |
proc NextRev {_ nv} { |
|
e7bb3d0…
|
aku
|
204 |
upvar 1 $nv n |
|
e7bb3d0…
|
aku
|
205 |
RequiredLiteral next |
|
e7bb3d0…
|
aku
|
206 |
Anything -> n |
|
e7bb3d0…
|
aku
|
207 |
Semicolon |
|
e7bb3d0…
|
aku
|
208 |
return |
|
e7bb3d0…
|
aku
|
209 |
} |
|
e7bb3d0…
|
aku
|
210 |
|
|
e7bb3d0…
|
aku
|
211 |
# # ## ### ##### ######## ############# |
|
e7bb3d0…
|
aku
|
212 |
|
|
e7bb3d0…
|
aku
|
213 |
proc Description {} { |
|
e7bb3d0…
|
aku
|
214 |
upvar 1 data data res res |
|
e7bb3d0…
|
aku
|
215 |
RequiredLiteral desc |
|
e7bb3d0…
|
aku
|
216 |
RequiredString -> d |
|
e7bb3d0…
|
aku
|
217 |
Call setdesc $d |
|
e7bb3d0…
|
aku
|
218 |
return |
|
e7bb3d0…
|
aku
|
219 |
} |
|
e7bb3d0…
|
aku
|
220 |
|
|
e7bb3d0…
|
aku
|
221 |
# # ## ### ##### ######## ############# |
|
e7bb3d0…
|
aku
|
222 |
|
|
e7bb3d0…
|
aku
|
223 |
proc DeltaTexts {} { |
|
e7bb3d0…
|
aku
|
224 |
while {[OptionalNumber -> rev]} { |
|
e7bb3d0…
|
aku
|
225 |
RequiredLiteral log |
|
e7bb3d0…
|
aku
|
226 |
RequiredString -> cmsg |
|
1527954…
|
aku
|
227 |
if {[regexp {[\000-\010\013\014\016-\037]} $cmsg]} { |
|
fa643aa…
|
aku
|
228 |
#Rewind |
|
fa643aa…
|
aku
|
229 |
#Bad "log message for $rev contains at least one control character" |
|
1527954…
|
aku
|
230 |
} |
|
1527954…
|
aku
|
231 |
|
|
e7bb3d0…
|
aku
|
232 |
RequiredLiteral text |
|
e7bb3d0…
|
aku
|
233 |
RequiredStringRange -> delta |
|
e7bb3d0…
|
aku
|
234 |
Call extend $rev $cmsg $delta |
|
e7bb3d0…
|
aku
|
235 |
} |
|
e7bb3d0…
|
aku
|
236 |
return |
|
e7bb3d0…
|
aku
|
237 |
} |
|
e7bb3d0…
|
aku
|
238 |
|
|
e7bb3d0…
|
aku
|
239 |
# # ## ### ##### ######## ############# |
|
e7bb3d0…
|
aku
|
240 |
## Internal methods, lexiographical processing |
|
e7bb3d0…
|
aku
|
241 |
|
|
e7bb3d0…
|
aku
|
242 |
proc Semicolon {} { |
|
e7bb3d0…
|
aku
|
243 |
::variable mydata |
|
e7bb3d0…
|
aku
|
244 |
::variable mypos |
|
e7bb3d0…
|
aku
|
245 |
|
|
e7bb3d0…
|
aku
|
246 |
set ok [regexp -start $mypos -indices -- {\A\s*;\s*} $mydata match] |
|
e7bb3d0…
|
aku
|
247 |
if {!$ok} { Expected ';' } |
|
e7bb3d0…
|
aku
|
248 |
|
|
e7bb3d0…
|
aku
|
249 |
SkipOver match |
|
e7bb3d0…
|
aku
|
250 |
return |
|
e7bb3d0…
|
aku
|
251 |
} |
|
e7bb3d0…
|
aku
|
252 |
|
|
e7bb3d0…
|
aku
|
253 |
proc RequiredLiteral {name} { |
|
e7bb3d0…
|
aku
|
254 |
::variable mydata |
|
e7bb3d0…
|
aku
|
255 |
::variable mypos |
|
e7bb3d0…
|
aku
|
256 |
|
|
e7bb3d0…
|
aku
|
257 |
set pattern "\\A\\s*$name\\s*" |
|
e7bb3d0…
|
aku
|
258 |
set ok [regexp -start $mypos -indices -- $pattern $mydata match] |
|
e7bb3d0…
|
aku
|
259 |
if {!$ok} { Expected '$name' } |
|
e7bb3d0…
|
aku
|
260 |
|
|
e7bb3d0…
|
aku
|
261 |
SkipOver match |
|
e7bb3d0…
|
aku
|
262 |
return |
|
e7bb3d0…
|
aku
|
263 |
} |
|
e7bb3d0…
|
aku
|
264 |
|
|
e7bb3d0…
|
aku
|
265 |
proc OptionalLiteral {name} { |
|
e7bb3d0…
|
aku
|
266 |
::variable mydata |
|
e7bb3d0…
|
aku
|
267 |
::variable mypos |
|
e7bb3d0…
|
aku
|
268 |
|
|
e7bb3d0…
|
aku
|
269 |
set pattern "\\A\\s*$name\\s*" |
|
e7bb3d0…
|
aku
|
270 |
set ok [regexp -start $mypos -indices -- $pattern $mydata match] |
|
e7bb3d0…
|
aku
|
271 |
if {!$ok} { return 0 } |
|
e7bb3d0…
|
aku
|
272 |
|
|
e7bb3d0…
|
aku
|
273 |
SkipOver match |
|
294156a…
|
aku
|
274 |
return 1 |
|
294156a…
|
aku
|
275 |
} |
|
294156a…
|
aku
|
276 |
|
|
294156a…
|
aku
|
277 |
proc LiteralPeek {name} { |
|
294156a…
|
aku
|
278 |
::variable mydata |
|
294156a…
|
aku
|
279 |
::variable mypos |
|
294156a…
|
aku
|
280 |
|
|
294156a…
|
aku
|
281 |
set pattern "\\A\\s*$name\\s*" |
|
294156a…
|
aku
|
282 |
set ok [regexp -start $mypos -indices -- $pattern $mydata match] |
|
294156a…
|
aku
|
283 |
if {!$ok} { return 0 } |
|
294156a…
|
aku
|
284 |
|
|
294156a…
|
aku
|
285 |
# NO - SkipOver match - Only looking ahead here. |
|
e7bb3d0…
|
aku
|
286 |
return 1 |
|
e7bb3d0…
|
aku
|
287 |
} |
|
e7bb3d0…
|
aku
|
288 |
|
|
e7bb3d0…
|
aku
|
289 |
proc RequiredNumber {_ v} { |
|
e7bb3d0…
|
aku
|
290 |
upvar 1 $v value |
|
e7bb3d0…
|
aku
|
291 |
::variable mydata |
|
e7bb3d0…
|
aku
|
292 |
::variable mypos |
|
e7bb3d0…
|
aku
|
293 |
|
|
e7bb3d0…
|
aku
|
294 |
set pattern {\A\s*((\d|\.)+)\s*} |
|
e7bb3d0…
|
aku
|
295 |
set ok [regexp -start $mypos -indices -- $pattern $mydata match v] |
|
e7bb3d0…
|
aku
|
296 |
if {!$ok} { Expected id } |
|
e7bb3d0…
|
aku
|
297 |
|
|
e7bb3d0…
|
aku
|
298 |
Extract $v -> value |
|
e7bb3d0…
|
aku
|
299 |
SkipOver match |
|
e7bb3d0…
|
aku
|
300 |
return |
|
e7bb3d0…
|
aku
|
301 |
} |
|
e7bb3d0…
|
aku
|
302 |
|
|
e7bb3d0…
|
aku
|
303 |
proc OptionalNumber {_ v} { |
|
e7bb3d0…
|
aku
|
304 |
upvar 1 $v value |
|
e7bb3d0…
|
aku
|
305 |
::variable mydata |
|
e7bb3d0…
|
aku
|
306 |
::variable mypos |
|
e7bb3d0…
|
aku
|
307 |
|
|
e7bb3d0…
|
aku
|
308 |
set pattern {\A\s*((\d|\.)+)\s*} |
|
e7bb3d0…
|
aku
|
309 |
set ok [regexp -start $mypos -indices -- $pattern $mydata match v] |
|
e7bb3d0…
|
aku
|
310 |
if {!$ok} { return 0 } |
|
e7bb3d0…
|
aku
|
311 |
|
|
e7bb3d0…
|
aku
|
312 |
Extract $v -> value |
|
e7bb3d0…
|
aku
|
313 |
SkipOver match |
|
e7bb3d0…
|
aku
|
314 |
return 1 |
|
e7bb3d0…
|
aku
|
315 |
} |
|
e7bb3d0…
|
aku
|
316 |
|
|
e7bb3d0…
|
aku
|
317 |
proc RequiredString {_ v} { |
|
e7bb3d0…
|
aku
|
318 |
upvar 1 $v value |
|
e7bb3d0…
|
aku
|
319 |
::variable mydata |
|
e7bb3d0…
|
aku
|
320 |
::variable mypos |
|
e7bb3d0…
|
aku
|
321 |
|
|
e7bb3d0…
|
aku
|
322 |
set ok [regexp -start $mypos -indices -- {\A\s*@(([^@]*(@@)*)*)@\s*} $mydata match v] |
|
e7bb3d0…
|
aku
|
323 |
if {!$ok} { Expected string } |
|
e7bb3d0…
|
aku
|
324 |
|
|
e7bb3d0…
|
aku
|
325 |
Extract $v -> value |
|
e7bb3d0…
|
aku
|
326 |
set value [string map {@@ @} $value] |
|
e7bb3d0…
|
aku
|
327 |
SkipOver match |
|
e7bb3d0…
|
aku
|
328 |
return |
|
e7bb3d0…
|
aku
|
329 |
} |
|
e7bb3d0…
|
aku
|
330 |
|
|
e7bb3d0…
|
aku
|
331 |
proc RequiredStringRange {_ v} { |
|
e7bb3d0…
|
aku
|
332 |
upvar 1 $v value |
|
e7bb3d0…
|
aku
|
333 |
::variable mydata |
|
e7bb3d0…
|
aku
|
334 |
::variable mypos |
|
e7bb3d0…
|
aku
|
335 |
|
|
e7bb3d0…
|
aku
|
336 |
set ok [regexp -start $mypos -indices -- {\A\s*@(([^@]*(@@)*)*)@\s*} $mydata match value] |
|
e7bb3d0…
|
aku
|
337 |
if {!$ok} { Expected string } |
|
e7bb3d0…
|
aku
|
338 |
|
|
e7bb3d0…
|
aku
|
339 |
SkipOver match |
|
e7bb3d0…
|
aku
|
340 |
return |
|
e7bb3d0…
|
aku
|
341 |
} |
|
e7bb3d0…
|
aku
|
342 |
|
|
e7bb3d0…
|
aku
|
343 |
proc OptionalString {_ v} { |
|
e7bb3d0…
|
aku
|
344 |
upvar 1 $v value |
|
e7bb3d0…
|
aku
|
345 |
::variable mydata |
|
e7bb3d0…
|
aku
|
346 |
::variable mypos |
|
e7bb3d0…
|
aku
|
347 |
|
|
e7bb3d0…
|
aku
|
348 |
set ok [regexp -start $mypos -indices -- {\A\s*@(([^@]*(@@)*)*)@\s*} $mydata match v] |
|
e7bb3d0…
|
aku
|
349 |
if {!$ok} { return 0 } |
|
e7bb3d0…
|
aku
|
350 |
|
|
e7bb3d0…
|
aku
|
351 |
Extract $v -> value |
|
e7bb3d0…
|
aku
|
352 |
set value [string map {@@ @} $value] |
|
e7bb3d0…
|
aku
|
353 |
SkipOver match |
|
e7bb3d0…
|
aku
|
354 |
return 1 |
|
e7bb3d0…
|
aku
|
355 |
} |
|
e7bb3d0…
|
aku
|
356 |
|
|
e7bb3d0…
|
aku
|
357 |
proc Ident {_ v} { |
|
e7bb3d0…
|
aku
|
358 |
upvar 1 $v value |
|
e7bb3d0…
|
aku
|
359 |
::variable mydata |
|
e7bb3d0…
|
aku
|
360 |
::variable mypos |
|
e7bb3d0…
|
aku
|
361 |
|
|
e7bb3d0…
|
aku
|
362 |
set ok [regexp -start $mypos -indices -- {\A\s*;\s*} $mydata] |
|
e7bb3d0…
|
aku
|
363 |
if {$ok} { return 0 } |
|
e7bb3d0…
|
aku
|
364 |
|
|
e7bb3d0…
|
aku
|
365 |
set ok [regexp -start $mypos -indices -- {\A\s*([^:]*)\s*:\s*} $mydata match v] |
|
e7bb3d0…
|
aku
|
366 |
if {!$ok} { return 0 } |
|
e7bb3d0…
|
aku
|
367 |
|
|
e7bb3d0…
|
aku
|
368 |
Extract $v -> value |
|
e7bb3d0…
|
aku
|
369 |
SkipOver match |
|
e7bb3d0…
|
aku
|
370 |
return 1 |
|
e7bb3d0…
|
aku
|
371 |
} |
|
e7bb3d0…
|
aku
|
372 |
|
|
e7bb3d0…
|
aku
|
373 |
proc Anything {_ v} { |
|
e7bb3d0…
|
aku
|
374 |
upvar 1 $v value |
|
e7bb3d0…
|
aku
|
375 |
::variable mydata |
|
e7bb3d0…
|
aku
|
376 |
::variable mypos |
|
e7bb3d0…
|
aku
|
377 |
|
|
e7bb3d0…
|
aku
|
378 |
regexp -start $mypos -indices -- {\A\s*([^;]*)\s*} $mydata match v |
|
e7bb3d0…
|
aku
|
379 |
|
|
e7bb3d0…
|
aku
|
380 |
Extract $v -> value |
|
e7bb3d0…
|
aku
|
381 |
SkipOver match |
|
e7bb3d0…
|
aku
|
382 |
return |
|
e7bb3d0…
|
aku
|
383 |
} |
|
e7bb3d0…
|
aku
|
384 |
|
|
e7bb3d0…
|
aku
|
385 |
# # ## ### ##### ######## ############# |
|
e7bb3d0…
|
aku
|
386 |
## Internal methods, input handling |
|
e7bb3d0…
|
aku
|
387 |
|
|
e7bb3d0…
|
aku
|
388 |
proc Extract {range _ v} { |
|
e7bb3d0…
|
aku
|
389 |
upvar 1 $v value |
|
e7bb3d0…
|
aku
|
390 |
::variable mydata |
|
e7bb3d0…
|
aku
|
391 |
struct::list assign $range s e |
|
e7bb3d0…
|
aku
|
392 |
set value [string range $mydata $s $e] |
|
e7bb3d0…
|
aku
|
393 |
return |
|
e7bb3d0…
|
aku
|
394 |
} |
|
e7bb3d0…
|
aku
|
395 |
|
|
e7bb3d0…
|
aku
|
396 |
proc SkipOver {mv} { |
|
e7bb3d0…
|
aku
|
397 |
# Note: The indices are absolute!, not relative to the start |
|
e7bb3d0…
|
aku
|
398 |
# location. |
|
e7bb3d0…
|
aku
|
399 |
upvar 1 $mv match |
|
e7bb3d0…
|
aku
|
400 |
::variable mypos |
|
e7bb3d0…
|
aku
|
401 |
::variable mysize |
|
1527954…
|
aku
|
402 |
::variable mylastpos |
|
e7bb3d0…
|
aku
|
403 |
|
|
e7bb3d0…
|
aku
|
404 |
struct::list assign $match s e |
|
e7bb3d0…
|
aku
|
405 |
#puts "<$s $e> [info level -1]" |
|
e7bb3d0…
|
aku
|
406 |
|
|
1527954…
|
aku
|
407 |
set mylastpos $mypos |
|
e7bb3d0…
|
aku
|
408 |
set mypos $e |
|
e7bb3d0…
|
aku
|
409 |
incr mypos |
|
e7bb3d0…
|
aku
|
410 |
|
|
e7bb3d0…
|
aku
|
411 |
log progress 2 rcs $mypos $mysize |
|
e7bb3d0…
|
aku
|
412 |
#puts $mypos/$mysize |
|
e7bb3d0…
|
aku
|
413 |
return |
|
e7bb3d0…
|
aku
|
414 |
} |
|
e7bb3d0…
|
aku
|
415 |
|
|
1527954…
|
aku
|
416 |
proc Rewind {} { |
|
1527954…
|
aku
|
417 |
::variable mypos |
|
1527954…
|
aku
|
418 |
::variable mylastpos |
|
1527954…
|
aku
|
419 |
|
|
1527954…
|
aku
|
420 |
set mypos $mylastpos |
|
1527954…
|
aku
|
421 |
return |
|
1527954…
|
aku
|
422 |
} |
|
1527954…
|
aku
|
423 |
|
|
e7bb3d0…
|
aku
|
424 |
proc Expected {x} { |
|
e7bb3d0…
|
aku
|
425 |
::variable mydata |
|
e7bb3d0…
|
aku
|
426 |
::variable mypos |
|
e7bb3d0…
|
aku
|
427 |
set e $mypos ; incr e 30 |
|
be89123…
|
aku
|
428 |
return -code error -errorcode vc::rcs::parser \ |
|
b679ca3…
|
aku
|
429 |
"Expected $x @ '[string range $mydata $mypos $e]...'" |
|
1527954…
|
aku
|
430 |
} |
|
1527954…
|
aku
|
431 |
|
|
1527954…
|
aku
|
432 |
proc Bad {x} { |
|
1527954…
|
aku
|
433 |
::variable mydata |
|
1527954…
|
aku
|
434 |
::variable mypos |
|
1527954…
|
aku
|
435 |
set e $mypos ; incr e 30 |
|
1527954…
|
aku
|
436 |
return -code error -errorcode vc::rcs::parser \ |
|
b679ca3…
|
aku
|
437 |
"Bad $x @ '[string range $mydata $mypos $e]...'" |
|
e7bb3d0…
|
aku
|
438 |
} |
|
e7bb3d0…
|
aku
|
439 |
|
|
e7bb3d0…
|
aku
|
440 |
# # ## ### ##### ######## ############# |
|
e7bb3d0…
|
aku
|
441 |
## Setup, callbacks. |
|
e7bb3d0…
|
aku
|
442 |
|
|
e7bb3d0…
|
aku
|
443 |
proc Initialize {path sink} { |
|
e7bb3d0…
|
aku
|
444 |
::variable mypos 0 |
|
6f1c442…
|
aku
|
445 |
::variable mydata [fileutil::cat -translation binary $path] |
|
e7bb3d0…
|
aku
|
446 |
::variable mysize [file size $path] |
|
e7bb3d0…
|
aku
|
447 |
::variable mysink $sink |
|
e7bb3d0…
|
aku
|
448 |
return |
|
e7bb3d0…
|
aku
|
449 |
} |
|
e7bb3d0…
|
aku
|
450 |
|
|
e7bb3d0…
|
aku
|
451 |
proc Call {args} { |
|
e7bb3d0…
|
aku
|
452 |
::variable mysink |
|
e7bb3d0…
|
aku
|
453 |
set cmd $mysink |
|
e7bb3d0…
|
aku
|
454 |
foreach a $args { lappend cmd $a } |
|
e7bb3d0…
|
aku
|
455 |
eval $cmd |
|
e7bb3d0…
|
aku
|
456 |
return |
|
e7bb3d0…
|
aku
|
457 |
} |
|
e7bb3d0…
|
aku
|
458 |
|
|
e7bb3d0…
|
aku
|
459 |
# # ## ### ##### ######## ############# |
|
e7bb3d0…
|
aku
|
460 |
## Configuration |
|
e7bb3d0…
|
aku
|
461 |
|
|
e7bb3d0…
|
aku
|
462 |
typevariable mydata {} ; # Rcs archive contents to process |
|
e7bb3d0…
|
aku
|
463 |
typevariable mysize 0 ; # Length of contents |
|
e7bb3d0…
|
aku
|
464 |
typevariable mysink {} ; # Sink to report to |
|
e7bb3d0…
|
aku
|
465 |
|
|
e7bb3d0…
|
aku
|
466 |
pragma -hasinstances no ; # singleton |
|
e7bb3d0…
|
aku
|
467 |
pragma -hastypeinfo no ; # no introspection |
|
e7bb3d0…
|
aku
|
468 |
pragma -hastypedestroy no ; # immortal |
|
e7bb3d0…
|
aku
|
469 |
|
|
e7bb3d0…
|
aku
|
470 |
# # ## ### ##### ######## ############# |
|
e7bb3d0…
|
aku
|
471 |
} |
|
e7bb3d0…
|
aku
|
472 |
|
|
e7bb3d0…
|
aku
|
473 |
namespace eval ::vc::rcs { |
|
e7bb3d0…
|
aku
|
474 |
namespace export parser |
|
e7bb3d0…
|
aku
|
475 |
namespace eval parser { |
|
e7bb3d0…
|
aku
|
476 |
namespace import ::vc::tools::log |
|
e7bb3d0…
|
aku
|
477 |
log register rcs |
|
e7bb3d0…
|
aku
|
478 |
} |
|
e7bb3d0…
|
aku
|
479 |
} |
|
e7bb3d0…
|
aku
|
480 |
|
|
e7bb3d0…
|
aku
|
481 |
# # ## ### ##### ######## ############# ##################### |
|
e7bb3d0…
|
aku
|
482 |
## Ready |
|
860f533…
|
aku
|
483 |
|
|
860f533…
|
aku
|
484 |
package provide vc::rcs::parser 1.0 |
|
860f533…
|
aku
|
485 |
return |