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