|
1
|
## -*- tcl -*- |
|
2
|
# # ## ### ##### ######## ############# ##################### |
|
3
|
## Copyright (c) 2007-2008 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
|
## Revisions per project, aka Changesets. These objects are first used |
|
14
|
## in pass 5, which creates the initial set covering the repository. |
|
15
|
|
|
16
|
# # ## ### ##### ######## ############# ##################### |
|
17
|
## Requirements |
|
18
|
|
|
19
|
package require Tcl 8.4 ; # Required runtime. |
|
20
|
package require snit ; # OO system. |
|
21
|
package require struct::set ; # Set operations. |
|
22
|
package require vc::tools::misc ; # Text formatting |
|
23
|
package require vc::tools::trouble ; # Error reporting. |
|
24
|
package require vc::tools::log ; # User feedback. |
|
25
|
package require vc::fossil::import::cvs::state ; # State storage. |
|
26
|
package require vc::fossil::import::cvs::integrity ; # State integrity checks. |
|
27
|
|
|
28
|
# # ## ### ##### ######## ############# ##################### |
|
29
|
## |
|
30
|
|
|
31
|
snit::type ::vc::fossil::import::cvs::project::rev { |
|
32
|
# # ## ### ##### ######## ############# |
|
33
|
## Public API |
|
34
|
|
|
35
|
constructor {project cstype srcid items {theid {}}} { |
|
36
|
if {$theid ne ""} { |
|
37
|
set myid $theid |
|
38
|
} else { |
|
39
|
set myid [incr mycounter] |
|
40
|
} |
|
41
|
|
|
42
|
integrity assert { |
|
43
|
[info exists mycstype($cstype)] |
|
44
|
} {Bad changeset type '$cstype'.} |
|
45
|
|
|
46
|
set myproject $project |
|
47
|
set mytype $cstype |
|
48
|
set mytypeobj ::vc::fossil::import::cvs::project::rev::${cstype} |
|
49
|
set mysrcid $srcid |
|
50
|
set myitems $items |
|
51
|
set mypos {} ; # Commit location is not known yet. |
|
52
|
|
|
53
|
foreach iid $items { lappend mytitems [list $cstype $iid] } |
|
54
|
|
|
55
|
# Keep track of the generated changesets and of the inverse |
|
56
|
# mapping from items to them. |
|
57
|
lappend mychangesets $self |
|
58
|
lappend mytchangesets($cstype) $self |
|
59
|
set myidmap($myid) $self |
|
60
|
|
|
61
|
MapItems $cstype $items |
|
62
|
return |
|
63
|
} |
|
64
|
|
|
65
|
destructor { |
|
66
|
# We may be able to get rid of this entirely, at least for |
|
67
|
# (de)construction and pass InitCSets. |
|
68
|
|
|
69
|
UnmapItems $mytype $myitems |
|
70
|
unset myidmap($myid) |
|
71
|
|
|
72
|
set pos [lsearch -exact $mychangesets $self] |
|
73
|
set mychangesets [lreplace $mychangesets $pos $pos] |
|
74
|
set pos [lsearch -exact $mytchangesets($mytype) $self] |
|
75
|
set mytchangesets($mytype) [lreplace $mytchangesets($mytype) $pos $pos] |
|
76
|
return |
|
77
|
} |
|
78
|
|
|
79
|
method str {} { |
|
80
|
set str "<" |
|
81
|
set detail "" |
|
82
|
if {[$mytypeobj bysymbol]} { |
|
83
|
set detail " '[state one { |
|
84
|
SELECT S.name |
|
85
|
FROM symbol S |
|
86
|
WHERE S.sid = $mysrcid |
|
87
|
}]'" |
|
88
|
} |
|
89
|
append str "$mytype ${myid}${detail}>" |
|
90
|
return $str |
|
91
|
} |
|
92
|
|
|
93
|
method lod {} { |
|
94
|
return [$mytypeobj cs_lod $mysrcid $myitems] |
|
95
|
} |
|
96
|
|
|
97
|
method id {} { return $myid } |
|
98
|
method items {} { return $mytitems } |
|
99
|
method data {} { return [list $myproject $mytype $mysrcid] } |
|
100
|
|
|
101
|
delegate method bysymbol to mytypeobj |
|
102
|
delegate method byrevision to mytypeobj |
|
103
|
delegate method isbranch to mytypeobj |
|
104
|
delegate method istag to mytypeobj |
|
105
|
|
|
106
|
method setpos {p} { set mypos $p ; return } |
|
107
|
method pos {} { return $mypos } |
|
108
|
|
|
109
|
method determinesuccessors {} { |
|
110
|
# Pass 6 operation. Compute project-level dependencies from |
|
111
|
# the file-level data and save it back to the state. This may |
|
112
|
# be called during the cycle breaker passes as well, to adjust |
|
113
|
# the successor information of changesets which are the |
|
114
|
# predecessors of dropped changesets. For them we have to |
|
115
|
# remove their existing information first before inserting the |
|
116
|
# new data. |
|
117
|
state run { |
|
118
|
DELETE FROM cssuccessor WHERE cid = $myid; |
|
119
|
} |
|
120
|
set loop 0 |
|
121
|
# TODO: Check other uses of cs_sucessors. |
|
122
|
# TODO: Consider merging cs_sucessor's SELECT with the INSERT here. |
|
123
|
foreach nid [$mytypeobj cs_successors $myitems] { |
|
124
|
state run { |
|
125
|
INSERT INTO cssuccessor (cid, nid) |
|
126
|
VALUES ($myid,$nid) |
|
127
|
} |
|
128
|
if {$nid == $myid} { set loop 1 } |
|
129
|
} |
|
130
|
# Report after the complete structure has been saved. |
|
131
|
if {$loop} { $self reportloop } |
|
132
|
return |
|
133
|
} |
|
134
|
|
|
135
|
# result = list (changeset) |
|
136
|
method successors {} { |
|
137
|
# Use the data saved by pass 6. |
|
138
|
return [struct::list map [state run { |
|
139
|
SELECT S.nid |
|
140
|
FROM cssuccessor S |
|
141
|
WHERE S.cid = $myid |
|
142
|
}] [mytypemethod of]] |
|
143
|
} |
|
144
|
|
|
145
|
# item -> list (item) |
|
146
|
method nextmap {} { |
|
147
|
$mytypeobj successors tmp $myitems |
|
148
|
return [array get tmp] |
|
149
|
} |
|
150
|
|
|
151
|
method breakinternaldependencies {cv} { |
|
152
|
upvar 1 $cv counter |
|
153
|
log write 14 csets {[$self str] BID} |
|
154
|
vc::tools::mem::mark |
|
155
|
|
|
156
|
# This method inspects the changeset, looking for internal |
|
157
|
# dependencies. Nothing is done if there are no such. |
|
158
|
|
|
159
|
# Otherwise the changeset is split into a set of fragments |
|
160
|
# which have no internal dependencies, transforming the |
|
161
|
# internal dependencies into external ones. The new changesets |
|
162
|
# generated from the fragment information are added to the |
|
163
|
# list of all changesets (by the caller). |
|
164
|
|
|
165
|
# The code checks only successor dependencies, as this auto- |
|
166
|
# matically covers the predecessor dependencies as well (Any |
|
167
|
# successor dependency a -> b is also a predecessor dependency |
|
168
|
# b -> a). |
|
169
|
|
|
170
|
array set breaks {} |
|
171
|
|
|
172
|
set fragments [BreakDirectDependencies $myitems breaks] |
|
173
|
|
|
174
|
if {![llength $fragments]} { return {} } |
|
175
|
|
|
176
|
return [$self CreateFromFragments $fragments counter breaks] |
|
177
|
} |
|
178
|
|
|
179
|
method persist {} { |
|
180
|
set tid $mycstype($mytype) |
|
181
|
set pid [$myproject id] |
|
182
|
set pos 0 |
|
183
|
|
|
184
|
state transaction { |
|
185
|
state run { |
|
186
|
INSERT INTO changeset (cid, pid, type, src) |
|
187
|
VALUES ($myid, $pid, $tid, $mysrcid); |
|
188
|
} |
|
189
|
|
|
190
|
foreach iid $myitems { |
|
191
|
state run { |
|
192
|
INSERT INTO csitem (cid, pos, iid) |
|
193
|
VALUES ($myid, $pos, $iid); |
|
194
|
} |
|
195
|
incr pos |
|
196
|
} |
|
197
|
} |
|
198
|
return |
|
199
|
} |
|
200
|
|
|
201
|
method timerange {} { return [$mytypeobj timerange $myitems] } |
|
202
|
|
|
203
|
method limits {} { |
|
204
|
struct::list assign [$mytypeobj limits $myitems] maxp mins |
|
205
|
return [list [TagItemDict $maxp $mytype] [TagItemDict $mins $mytype]] |
|
206
|
} |
|
207
|
|
|
208
|
method drop {} { |
|
209
|
log write 8 csets {Dropping $self = [$self str]} |
|
210
|
|
|
211
|
state transaction { |
|
212
|
state run { |
|
213
|
DELETE FROM changeset WHERE cid = $myid; |
|
214
|
DELETE FROM csitem WHERE cid = $myid; |
|
215
|
DELETE FROM cssuccessor WHERE cid = $myid; |
|
216
|
} |
|
217
|
} |
|
218
|
|
|
219
|
# Return the list of predecessors so that they can be adjusted. |
|
220
|
return [struct::list map [state run { |
|
221
|
SELECT cid |
|
222
|
FROM cssuccessor |
|
223
|
WHERE nid = $myid |
|
224
|
}] [mytypemethod of]] |
|
225
|
} |
|
226
|
|
|
227
|
method reportloop {{kill 1}} { |
|
228
|
# We print the items which are producing the loop, and how. |
|
229
|
|
|
230
|
set hdr "Self-referential changeset [$self str] __________________" |
|
231
|
set ftr [regsub -all {[^ ]} $hdr {_}] |
|
232
|
|
|
233
|
log write 0 csets $hdr |
|
234
|
foreach {item nextitem} [$mytypeobj loops $myitems] { |
|
235
|
# Create tagged items from the id and our type. |
|
236
|
set item [list $mytype $item] |
|
237
|
set nextitem [list $mytype $nextitem] |
|
238
|
# Printable labels. |
|
239
|
set i "<[$type itemstr $item]>" |
|
240
|
set n "<[$type itemstr $nextitem]>" |
|
241
|
set ncs $myitemmap($nextitem) |
|
242
|
# Print |
|
243
|
log write 0 csets {* $i --> $n --> cs [$ncs str]} |
|
244
|
} |
|
245
|
log write 0 csets $ftr |
|
246
|
|
|
247
|
if {!$kill} return |
|
248
|
trouble internal "[$self str] depends on itself" |
|
249
|
return |
|
250
|
} |
|
251
|
|
|
252
|
method pushto {repository date rstate} { |
|
253
|
# Generate and import the manifest for this changeset. |
|
254
|
# |
|
255
|
# Data needed: |
|
256
|
# - Commit message (-- mysrcid -> repository meta) |
|
257
|
# - User doing the commit (s.a.) |
|
258
|
# |
|
259
|
# - Timestamp of when committed (command argument) |
|
260
|
# |
|
261
|
# - The parent changeset, if any. If there is no parent fossil |
|
262
|
# will use the empty base revision as parent. |
|
263
|
# |
|
264
|
# - List of the file revisions in the changeset. |
|
265
|
|
|
266
|
# We derive the lod information directly from the revisions of |
|
267
|
# the changeset, as the branch part of the meta data (s.a.) is |
|
268
|
# outdated since pass FilterSymbols. See the method 'run' in |
|
269
|
# file "c2f_pfiltersym.tcl" for more commentary on this. |
|
270
|
|
|
271
|
set lodname [$self lod] |
|
272
|
|
|
273
|
log write 2 csets {Importing changeset [$self str] on $lodname} |
|
274
|
|
|
275
|
if {[$mytypeobj istag]} { |
|
276
|
# Handle tags. They appear immediately after the revision |
|
277
|
# they are attached to (*). We can assume that the |
|
278
|
# workspace for the relevant line of development |
|
279
|
# exists. We retrieve it, then the uuid of the last |
|
280
|
# revision entered into it, then tag this revision. |
|
281
|
|
|
282
|
# (*) Immediately in terms of the relevant line of |
|
283
|
# development. Revisions on other lines may come in |
|
284
|
# between, but they do not matter to that. |
|
285
|
|
|
286
|
set lws [Getworkspace $rstate $lodname $myproject 0] |
|
287
|
set uuid [lindex [$lws getid] 1] |
|
288
|
|
|
289
|
$repository tag $uuid [state one { |
|
290
|
SELECT S.name |
|
291
|
FROM symbol S |
|
292
|
WHERE S.sid = $mysrcid |
|
293
|
}] |
|
294
|
|
|
295
|
} elseif {[$mytypeobj isbranch]} { |
|
296
|
|
|
297
|
# Handle branches. They appear immediately after the |
|
298
|
# revision they are spawned from (*). We can assume that |
|
299
|
# the workspace for the relevant line of development |
|
300
|
# exists. |
|
301
|
|
|
302
|
# We retrieve it, then the uuid of the last revision |
|
303
|
# entered into it. That revision is tagged as the root of |
|
304
|
# the branch (**). A new workspace for the branch is |
|
305
|
# created as well, for the future revisions of the new |
|
306
|
# line of development. |
|
307
|
|
|
308
|
# An exception is made of the non-trunk default branch, |
|
309
|
# aka vendor branch. This lod has to have a workspace not |
|
310
|
# inherited from anything else. It has no root either, so |
|
311
|
# tagging is out as well. |
|
312
|
|
|
313
|
# (*) Immediately in terms of the relevant line of |
|
314
|
# development. Revisions on other lines may come in |
|
315
|
# between, but they do not matter to that. |
|
316
|
|
|
317
|
# (**) Tagging the parent revision of the branch as its |
|
318
|
# root is done to let us know about the existence of |
|
319
|
# the branch even if it has no revisions committed to |
|
320
|
# it, and thus no regular branch tag anywhere else. |
|
321
|
# The name of the tag is the name for the lod, with |
|
322
|
# the suffix '-root' appended to it. |
|
323
|
|
|
324
|
# LOD is self symbol of branch, not parent |
|
325
|
set lodname [state one { |
|
326
|
SELECT S.name |
|
327
|
FROM symbol S |
|
328
|
WHERE S.sid = $mysrcid |
|
329
|
}] |
|
330
|
|
|
331
|
if {![$rstate has :trunk:]} { |
|
332
|
# No trunk implies default branch. Just create the |
|
333
|
# proper workspace. |
|
334
|
Getworkspace $rstate $lodname $myproject 1 |
|
335
|
} else { |
|
336
|
# Non-default branch. Need workspace, and tag parent |
|
337
|
# revision. |
|
338
|
|
|
339
|
set lws [Getworkspace $rstate $lodname $myproject 0] |
|
340
|
set uuid [lindex [$lws getid] 1] |
|
341
|
|
|
342
|
$repository tag $uuid ${lodname}-root |
|
343
|
} |
|
344
|
} else { |
|
345
|
# Revision changeset. |
|
346
|
|
|
347
|
struct::list assign [$myproject getmeta $mysrcid] __ __ user message |
|
348
|
|
|
349
|
# Perform the import. As part of that we determine the |
|
350
|
# parent we need, and convert the list of items in the |
|
351
|
# changeset into uuids and printable data. |
|
352
|
|
|
353
|
struct::list assign [Getisdefault $myitems] \ |
|
354
|
isdefault lastdefaultontrunk |
|
355
|
|
|
356
|
log write 8 csets {LOD '$lodname'} |
|
357
|
log write 8 csets { def? $isdefault} |
|
358
|
log write 8 csets { last? $lastdefaultontrunk} |
|
359
|
|
|
360
|
set lws [Getworkspace $rstate $lodname $myproject $isdefault] |
|
361
|
$lws add [Getrevisioninfo $myitems] |
|
362
|
|
|
363
|
struct::list assign \ |
|
364
|
[$repository importrevision [$self str] \ |
|
365
|
$user $message $date \ |
|
366
|
[lindex [$lws getid] 0] [$lws get]] \ |
|
367
|
rid uuid |
|
368
|
|
|
369
|
if {[$lws ticks] == 1} { |
|
370
|
# First commit on this line of development. Set our |
|
371
|
# own name as a propagating tag. And if the LOD has a |
|
372
|
# parent we have to prevent the propagation of that |
|
373
|
# tag into this new line. |
|
374
|
|
|
375
|
set plws [$lws parent] |
|
376
|
if {$plws ne ""} { |
|
377
|
$repository branchcancel $uuid [$plws name] |
|
378
|
} |
|
379
|
$repository branchmark $uuid [$lws name] |
|
380
|
} |
|
381
|
|
|
382
|
# Remember the imported changeset in the state, under our |
|
383
|
# LOD. And if it is the last trunk changeset on the vendor |
|
384
|
# branch then the revision is also the actual root of the |
|
385
|
# :trunk:, so we remember it as such in the state. However |
|
386
|
# if the trunk already exists then the changeset cannot be |
|
387
|
# on it any more. This indicates weirdness in the setup of |
|
388
|
# the vendor branch, but one we can work around. |
|
389
|
|
|
390
|
$lws defid [list $rid $uuid] |
|
391
|
if {$lastdefaultontrunk} { |
|
392
|
log write 2 csets {This cset is the last on the NTDB, set the trunk workspace up} |
|
393
|
|
|
394
|
if {[$rstate has :trunk:]} { |
|
395
|
log write 2 csets {Multiple changesets declared to be the last trunk changeset on the vendor-branch} |
|
396
|
} else { |
|
397
|
$rstate new :trunk: [$lws name] |
|
398
|
} |
|
399
|
} |
|
400
|
} |
|
401
|
|
|
402
|
log write 2 csets { } |
|
403
|
log write 2 csets { } |
|
404
|
return |
|
405
|
} |
|
406
|
|
|
407
|
proc Getrevisioninfo {revisions} { |
|
408
|
set theset ('[join $revisions {','}]') |
|
409
|
set revisions {} |
|
410
|
state foreachrow [subst -nocommands -nobackslashes { |
|
411
|
SELECT U.uuid AS frid, |
|
412
|
F.visible AS path, |
|
413
|
F.name AS fname, |
|
414
|
R.rev AS revnr, |
|
415
|
R.op AS rop |
|
416
|
FROM revision R, revuuid U, file F |
|
417
|
WHERE R.rid IN $theset -- All specified revisions |
|
418
|
AND U.rid = R.rid -- get fossil uuid of revision |
|
419
|
AND F.fid = R.fid -- get file of revision |
|
420
|
}] { |
|
421
|
lappend revisions $frid $path $fname/$revnr $rop |
|
422
|
} |
|
423
|
return $revisions |
|
424
|
} |
|
425
|
|
|
426
|
proc Getworkspace {rstate lodname project isdefault} { |
|
427
|
|
|
428
|
# The state object holds the workspace state of each known |
|
429
|
# line-of-development (LOD), up to the last committed |
|
430
|
# changeset belonging to that LOD. |
|
431
|
|
|
432
|
# (*) Standard handling if in-LOD changesets. If the LOD of |
|
433
|
# the current changeset exists in the state (= has been |
|
434
|
# committed to) then this it has the workspace we are |
|
435
|
# looking for. |
|
436
|
|
|
437
|
if {[$rstate has $lodname]} { |
|
438
|
return [$rstate get $lodname] |
|
439
|
} |
|
440
|
|
|
441
|
# If the LOD is however not yet known, then the current |
|
442
|
# changeset can be either of |
|
443
|
# (a) root of a vendor branch, |
|
444
|
# (b) root of the trunk LOD, or |
|
445
|
# (c) the first changeset in a new LOD which was spawned from |
|
446
|
# an existing LOD. |
|
447
|
|
|
448
|
# For both (a) and (b) we have to create a new workspace for |
|
449
|
# the lod, and it doesn't inherit from anything. |
|
450
|
|
|
451
|
# One exception for (a). If we already have a :vendor: branch |
|
452
|
# then multiple symbols were used for the vendor branch by |
|
453
|
# different files. In that case the 'new' branch is made an |
|
454
|
# alias of the :vendor:, effectively merging the symbols |
|
455
|
# together. |
|
456
|
|
|
457
|
# Note that case (b) may never occur. See the variable |
|
458
|
# 'lastdefaultontrunk' in the caller (method pushto). This |
|
459
|
# flag can the generation of the workspace for the :trunk: LOD |
|
460
|
# as well, making it inherit the state of the last |
|
461
|
# trunk-changeset on the vendor-branch. |
|
462
|
|
|
463
|
if {$isdefault} { |
|
464
|
if {![$rstate has ":vendor:"]} { |
|
465
|
# Create the vendor branch if not present already. We |
|
466
|
# use the actual name for the lod, and additional make |
|
467
|
# it accessible under an internal name (:vendor:) so |
|
468
|
# that we can merge to it later, should it become |
|
469
|
# necessary. See the other branch below. |
|
470
|
$rstate new $lodname |
|
471
|
$rstate dup :vendor: <-- $lodname |
|
472
|
} else { |
|
473
|
# Merge the new symbol to the vendor branch |
|
474
|
$rstate dup $lodname <-- :vendor: |
|
475
|
} |
|
476
|
return [$rstate get $lodname] |
|
477
|
} |
|
478
|
|
|
479
|
if {$lodname eq ":trunk:"} { |
|
480
|
return [$rstate new $lodname] |
|
481
|
} |
|
482
|
|
|
483
|
# Case (c). We find the parent LOD of our LOD and let the new |
|
484
|
# workspace inherit from the parent's workspace. |
|
485
|
|
|
486
|
set plodname [[[$project getsymbol $lodname] parent] name] |
|
487
|
|
|
488
|
log write 8 csets {pLOD '$plodname'} |
|
489
|
|
|
490
|
if {[$rstate has $plodname]} { |
|
491
|
return [$rstate new $lodname $plodname] |
|
492
|
} |
|
493
|
|
|
494
|
foreach k [lsort [$rstate names]] { |
|
495
|
log write 8 csets { $k = [[$rstate get $k] getid]} |
|
496
|
} |
|
497
|
|
|
498
|
trouble internal {Unable to determine changeset parent} |
|
499
|
return |
|
500
|
} |
|
501
|
|
|
502
|
proc Getisdefault {revisions} { |
|
503
|
set theset ('[join $revisions {','}]') |
|
504
|
|
|
505
|
struct::list assign [state run [subst -nocommands -nobackslashes { |
|
506
|
SELECT R.isdefault, R.dbchild |
|
507
|
FROM revision R |
|
508
|
WHERE R.rid IN $theset -- All specified revisions |
|
509
|
LIMIT 1 |
|
510
|
}]] def last |
|
511
|
|
|
512
|
# TODO/CHECK: look for changesets where isdefault/dbchild is |
|
513
|
# ambigous. |
|
514
|
|
|
515
|
return [list $def [expr {$last ne ""}]] |
|
516
|
} |
|
517
|
|
|
518
|
typemethod split {cset args} { |
|
519
|
# As part of the creation of the new changesets specified in |
|
520
|
# ARGS as sets of items, all subsets of CSET's item set, CSET |
|
521
|
# will be dropped from all databases, in and out of memory, |
|
522
|
# and then destroyed. |
|
523
|
# |
|
524
|
# Note: The item lists found in args are tagged items. They |
|
525
|
# have to have the same type as the changeset, being subsets |
|
526
|
# of its items. This is checked in Untag1. |
|
527
|
|
|
528
|
log write 8 csets {OLD: [lsort [$cset items]]} |
|
529
|
ValidateFragments $cset $args |
|
530
|
|
|
531
|
# All checks pass, actually perform the split. |
|
532
|
|
|
533
|
struct::list assign [$cset data] project cstype cssrc |
|
534
|
|
|
535
|
set predecessors [$cset drop] |
|
536
|
$cset destroy |
|
537
|
|
|
538
|
set newcsets {} |
|
539
|
foreach fragmentitems $args { |
|
540
|
log write 8 csets {MAKE: [lsort $fragmentitems]} |
|
541
|
|
|
542
|
set fragment [$type %AUTO% $project $cstype $cssrc \ |
|
543
|
[Untag $fragmentitems $cstype]] |
|
544
|
lappend newcsets $fragment |
|
545
|
|
|
546
|
$fragment persist |
|
547
|
$fragment determinesuccessors |
|
548
|
} |
|
549
|
|
|
550
|
# The predecessors have to recompute their successors, i.e. |
|
551
|
# remove the dropped changeset and put one of the fragments |
|
552
|
# into its place. |
|
553
|
foreach p $predecessors { |
|
554
|
$p determinesuccessors |
|
555
|
} |
|
556
|
|
|
557
|
return $newcsets |
|
558
|
} |
|
559
|
|
|
560
|
typemethod itemstr {item} { |
|
561
|
struct::list assign $item itype iid |
|
562
|
return [$itype str $iid] |
|
563
|
} |
|
564
|
|
|
565
|
typemethod strlist {changesets} { |
|
566
|
return [join [struct::list map $changesets [myproc ID]]] |
|
567
|
} |
|
568
|
|
|
569
|
proc ID {cset} { $cset str } |
|
570
|
|
|
571
|
proc Untag {taggeditems cstype} { |
|
572
|
return [struct::list map $taggeditems [myproc Untag1 $cstype]] |
|
573
|
} |
|
574
|
|
|
575
|
proc Untag1 {cstype theitem} { |
|
576
|
struct::list assign $theitem t i |
|
577
|
integrity assert {$cstype eq $t} {Item $i's type is '$t', expected '$cstype'} |
|
578
|
return $i |
|
579
|
} |
|
580
|
|
|
581
|
proc TagItemDict {itemdict cstype} { |
|
582
|
set res {} |
|
583
|
foreach {i v} $itemdict { lappend res [list $cstype $i] $v } |
|
584
|
return $res |
|
585
|
} |
|
586
|
|
|
587
|
proc ValidateFragments {cset fragments} { |
|
588
|
# Check the various integrity constraints for the fragments |
|
589
|
# specifying how to split the changeset: |
|
590
|
# |
|
591
|
# * We must have two or more fragments, as splitting a |
|
592
|
# changeset into one makes no sense. |
|
593
|
# * No fragment may be empty. |
|
594
|
# * All fragments have to be true subsets of the items in the |
|
595
|
# changeset to split. The 'true' is implied because none are |
|
596
|
# allowed to be empty, so each has to be smaller than the |
|
597
|
# total. |
|
598
|
# * The union of the fragments has to be the item set of the |
|
599
|
# changeset. |
|
600
|
# * The fragment must not overlap, i.e. their pairwise |
|
601
|
# intersections have to be empty. |
|
602
|
|
|
603
|
set cover {} |
|
604
|
foreach fragmentitems $fragments { |
|
605
|
log write 8 csets {NEW: [lsort $fragmentitems]} |
|
606
|
|
|
607
|
integrity assert { |
|
608
|
![struct::set empty $fragmentitems] |
|
609
|
} {changeset fragment is empty} |
|
610
|
|
|
611
|
integrity assert { |
|
612
|
[struct::set subsetof $fragmentitems [$cset items]] |
|
613
|
} {changeset fragment is not a subset} |
|
614
|
struct::set add cover $fragmentitems |
|
615
|
} |
|
616
|
|
|
617
|
integrity assert { |
|
618
|
[struct::set equal $cover [$cset items]] |
|
619
|
} {The fragments do not cover the original changeset} |
|
620
|
|
|
621
|
set i 1 |
|
622
|
foreach fia $fragments { |
|
623
|
foreach fib [lrange $fragments $i end] { |
|
624
|
integrity assert { |
|
625
|
[struct::set empty [struct::set intersect $fia $fib]] |
|
626
|
} {The fragments <$fia> and <$fib> overlap} |
|
627
|
} |
|
628
|
incr i |
|
629
|
} |
|
630
|
|
|
631
|
return |
|
632
|
} |
|
633
|
|
|
634
|
# # ## ### ##### ######## ############# |
|
635
|
## State |
|
636
|
|
|
637
|
variable myid {} ; # Id of the cset for the persistent |
|
638
|
# state. |
|
639
|
variable myproject {} ; # Reference of the project object the |
|
640
|
# changeset belongs to. |
|
641
|
variable mytype {} ; # What the changeset is based on |
|
642
|
# (revisions, tags, or branches). |
|
643
|
# Values: See mycstype. Note that we |
|
644
|
# have to keep the names of the helper |
|
645
|
# singletons in sync with the contents |
|
646
|
# of state table 'cstype', and various |
|
647
|
# other places using them hardwired. |
|
648
|
variable mytypeobj {} ; # Reference to the container for the |
|
649
|
# type dependent code. Derived from |
|
650
|
# mytype. |
|
651
|
variable mysrcid {} ; # Id of the metadata or symbol the cset |
|
652
|
# is based on. |
|
653
|
variable myitems {} ; # List of the file level revisions, |
|
654
|
# tags, or branches in the cset, as |
|
655
|
# ids. Not tagged. |
|
656
|
variable mytitems {} ; # As myitems, the tagged form. |
|
657
|
variable mypos {} ; # Commit position of the changeset, if |
|
658
|
# known. |
|
659
|
|
|
660
|
# # ## ### ##### ######## ############# |
|
661
|
## Internal methods |
|
662
|
|
|
663
|
typevariable mycounter 0 ; # Id counter for csets. Last id |
|
664
|
# used. |
|
665
|
typevariable mycstype -array {} ; # Map cstypes (names) to persistent |
|
666
|
# ids. Note that we have to keep |
|
667
|
# the names in the table 'cstype' |
|
668
|
# in sync with the names of the |
|
669
|
# helper singletons. |
|
670
|
|
|
671
|
typemethod inorder {projectid} { |
|
672
|
# Return all changesets (object references) for the specified |
|
673
|
# project, in the order given to them by the sort passes. Both |
|
674
|
# the filtering by project and the sorting by time make the |
|
675
|
# use of 'project::rev rev' impossible. |
|
676
|
|
|
677
|
set res {} |
|
678
|
state foreachrow { |
|
679
|
SELECT C.cid AS xcid, |
|
680
|
T.date AS cdate |
|
681
|
FROM changeset C, cstimestamp T |
|
682
|
WHERE C.pid = $projectid -- limit to changesets in project |
|
683
|
AND T.cid = C.cid -- get ordering information |
|
684
|
ORDER BY T.date -- sort into commit order |
|
685
|
} { |
|
686
|
lappend res $myidmap($xcid) $cdate |
|
687
|
} |
|
688
|
return $res |
|
689
|
} |
|
690
|
|
|
691
|
typemethod getcstypes {} { |
|
692
|
state foreachrow { |
|
693
|
SELECT tid, name FROM cstype; |
|
694
|
} { set mycstype($name) $tid } |
|
695
|
return |
|
696
|
} |
|
697
|
|
|
698
|
typemethod load {repository} { |
|
699
|
set n 0 |
|
700
|
log write 2 csets {Loading the changesets} |
|
701
|
state foreachrow { |
|
702
|
SELECT C.cid AS id, |
|
703
|
C.pid AS xpid, |
|
704
|
CS.name AS cstype, |
|
705
|
C.src AS srcid |
|
706
|
FROM changeset C, cstype CS |
|
707
|
WHERE C.type = CS.tid |
|
708
|
ORDER BY C.cid |
|
709
|
} { |
|
710
|
log progress 2 csets $n {} |
|
711
|
set r [$type %AUTO% [$repository projectof $xpid] $cstype $srcid [state run { |
|
712
|
SELECT C.iid |
|
713
|
FROM csitem C |
|
714
|
WHERE C.cid = $id |
|
715
|
ORDER BY C.pos |
|
716
|
}] $id] |
|
717
|
incr n |
|
718
|
} |
|
719
|
return |
|
720
|
} |
|
721
|
|
|
722
|
typemethod loadcounter {} { |
|
723
|
# Initialize the counter from the state |
|
724
|
log write 2 csets {Loading changeset counter} |
|
725
|
set mycounter [state one { SELECT MAX(cid) FROM changeset }] |
|
726
|
return |
|
727
|
} |
|
728
|
|
|
729
|
typemethod num {} { return $mycounter } |
|
730
|
|
|
731
|
# # ## ### ##### ######## ############# |
|
732
|
|
|
733
|
method CreateFromFragments {fragments cv bv} { |
|
734
|
upvar 1 $cv counter $bv breaks |
|
735
|
UnmapItems $mytype $myitems |
|
736
|
|
|
737
|
# Create changesets for the fragments, reusing the current one |
|
738
|
# for the first fragment. We sort them in order to allow |
|
739
|
# checking for gaps and nice messages. |
|
740
|
|
|
741
|
set newcsets {} |
|
742
|
set fragments [lsort -index 0 -integer $fragments] |
|
743
|
|
|
744
|
#puts \t.[join [PRs $fragments] .\n\t.]. |
|
745
|
|
|
746
|
Border [lindex $fragments 0] firsts firste |
|
747
|
|
|
748
|
integrity assert { |
|
749
|
$firsts == 0 |
|
750
|
} {Bad fragment start @ $firsts, gap, or before beginning of the range} |
|
751
|
|
|
752
|
set laste $firste |
|
753
|
foreach fragment [lrange $fragments 1 end] { |
|
754
|
Border $fragment s e |
|
755
|
integrity assert { |
|
756
|
$laste == ($s - 1) |
|
757
|
} {Bad fragment border <$laste | $s>, gap or overlap} |
|
758
|
|
|
759
|
set new [$type %AUTO% $myproject $mytype $mysrcid [lrange $myitems $s $e]] |
|
760
|
lappend newcsets $new |
|
761
|
incr counter |
|
762
|
|
|
763
|
log write 4 csets {Breaking [$self str ] @ $laste, new [$new str], cutting $breaks($laste)} |
|
764
|
|
|
765
|
set laste $e |
|
766
|
} |
|
767
|
|
|
768
|
integrity assert { |
|
769
|
$laste == ([llength $myitems]-1) |
|
770
|
} {Bad fragment end @ $laste, gap, or beyond end of the range} |
|
771
|
|
|
772
|
# Put the first fragment into the current changeset, and |
|
773
|
# update the in-memory index. We can simply (re)add the items |
|
774
|
# because we cleared the previously existing information, see |
|
775
|
# 'UnmapItems' above. Persistence does not matter here, none |
|
776
|
# of the changesets has been saved to the persistent state |
|
777
|
# yet. |
|
778
|
|
|
779
|
set myitems [lrange $myitems 0 $firste] |
|
780
|
set mytitems [lrange $mytitems 0 $firste] |
|
781
|
MapItems $mytype $myitems |
|
782
|
return $newcsets |
|
783
|
} |
|
784
|
|
|
785
|
# # ## ### ##### ######## ############# |
|
786
|
|
|
787
|
proc BreakDirectDependencies {theitems bv} { |
|
788
|
upvar 1 mytypeobj mytypeobj self self $bv breaks |
|
789
|
|
|
790
|
# Array of dependencies (parent -> child). This is pulled from |
|
791
|
# the state, and limited to successors within the changeset. |
|
792
|
|
|
793
|
array set dependencies {} |
|
794
|
|
|
795
|
$mytypeobj internalsuccessors dependencies $theitems |
|
796
|
if {![array size dependencies]} { |
|
797
|
return {} |
|
798
|
} ; # Nothing to break. |
|
799
|
|
|
800
|
log write 5 csets ...[$self str]....................................................... |
|
801
|
vc::tools::mem::mark |
|
802
|
|
|
803
|
return [BreakerCore $theitems dependencies breaks] |
|
804
|
} |
|
805
|
|
|
806
|
proc BreakerCore {theitems dv bv} { |
|
807
|
# Break a set of revisions into fragments which have no |
|
808
|
# internal dependencies. |
|
809
|
|
|
810
|
# We perform all necessary splits in one go, instead of only |
|
811
|
# one. The previous algorithm, adapted from cvs2svn, computed |
|
812
|
# a lot of state which was thrown away and then computed again |
|
813
|
# for each of the fragments. It should be easier to update and |
|
814
|
# reuse that state. |
|
815
|
|
|
816
|
upvar 1 $dv dependencies $bv breaks |
|
817
|
|
|
818
|
# We have internal dependencies to break. We now iterate over |
|
819
|
# all positions in the list (which is chronological, at least |
|
820
|
# as far as the timestamps are correct and unique) and |
|
821
|
# determine the best position for the break, by trying to |
|
822
|
# break as many dependencies as possible in one go. When a |
|
823
|
# break was found this is redone for the fragments coming and |
|
824
|
# after, after upding the crossing information. |
|
825
|
|
|
826
|
# Data structures: |
|
827
|
# Map: POS revision id -> position in list. |
|
828
|
# CROSS position in list -> number of dependencies crossing it |
|
829
|
# DEPC dependency -> positions it crosses |
|
830
|
# List: RANGE Of the positions itself. |
|
831
|
# Map: DELTA position in list -> time delta between its revision |
|
832
|
# and the next, if any. |
|
833
|
# A dependency is a single-element map parent -> child |
|
834
|
|
|
835
|
# InitializeBreakState initializes their contents after |
|
836
|
# upvar'ing them from this scope. It uses the information in |
|
837
|
# DEPENDENCIES to do so. |
|
838
|
|
|
839
|
InitializeBreakState $theitems |
|
840
|
|
|
841
|
set fragments {} |
|
842
|
set new [list $range] |
|
843
|
|
|
844
|
# Instead of one list holding both processed and pending |
|
845
|
# fragments we use two, one for the framents to process, one |
|
846
|
# to hold the new fragments, and the latter is copied to the |
|
847
|
# former when they run out. This keeps the list of pending |
|
848
|
# fragments short without sacrificing speed by shifting stuff |
|
849
|
# down. We especially drop the memory of fragments broken |
|
850
|
# during processing after a short time, instead of letting it |
|
851
|
# consume memory. |
|
852
|
|
|
853
|
while {[llength $new]} { |
|
854
|
|
|
855
|
set pending $new |
|
856
|
set new {} |
|
857
|
set at 0 |
|
858
|
|
|
859
|
while {$at < [llength $pending]} { |
|
860
|
set current [lindex $pending $at] |
|
861
|
|
|
862
|
log write 6 csets {. . .. ... ..... ........ .............} |
|
863
|
log write 6 csets {Scheduled [join [PRs [lrange $pending $at end]] { }]} |
|
864
|
log write 6 csets {Considering [PR $current] \[$at/[llength $pending]\]} |
|
865
|
|
|
866
|
set best [FindBestBreak $current] |
|
867
|
|
|
868
|
if {$best < 0} { |
|
869
|
# The inspected range has no internal |
|
870
|
# dependencies. This is a complete fragment. |
|
871
|
lappend fragments $current |
|
872
|
|
|
873
|
log write 6 csets "No breaks, final" |
|
874
|
} else { |
|
875
|
# Split the range and schedule the resulting |
|
876
|
# fragments for further inspection. Remember the |
|
877
|
# number of dependencies cut before we remove them |
|
878
|
# from consideration, for documentation later. |
|
879
|
|
|
880
|
set breaks($best) $cross($best) |
|
881
|
|
|
882
|
log write 6 csets "Best break @ $best, cutting [nsp $cross($best) dependency dependencies]" |
|
883
|
|
|
884
|
# Note: The value of best is an abolute location |
|
885
|
# in myitems. Use the start of current to make it |
|
886
|
# an index absolute to current. |
|
887
|
|
|
888
|
set brel [expr {$best - [lindex $current 0]}] |
|
889
|
set bnext $brel ; incr bnext |
|
890
|
set fragbefore [lrange $current 0 $brel] |
|
891
|
set fragafter [lrange $current $bnext end] |
|
892
|
|
|
893
|
log write 6 csets "New pieces [PR $fragbefore] [PR $fragafter]" |
|
894
|
|
|
895
|
integrity assert {[llength $fragbefore]} {Found zero-length fragment at the beginning} |
|
896
|
integrity assert {[llength $fragafter]} {Found zero-length fragment at the end} |
|
897
|
|
|
898
|
lappend new $fragbefore $fragafter |
|
899
|
CutAt $best |
|
900
|
} |
|
901
|
|
|
902
|
incr at |
|
903
|
} |
|
904
|
} |
|
905
|
|
|
906
|
log write 6 csets ". . .. ... ..... ........ ............." |
|
907
|
|
|
908
|
return $fragments |
|
909
|
} |
|
910
|
|
|
911
|
proc InitializeBreakState {revisions} { |
|
912
|
upvar 1 pos pos cross cross range range depc depc delta delta \ |
|
913
|
dependencies dependencies |
|
914
|
|
|
915
|
# First we create a map of positions to make it easier to |
|
916
|
# determine whether a dependency crosses a particular index. |
|
917
|
|
|
918
|
log write 14 csets {IBS: #rev [llength $revisions]} |
|
919
|
log write 14 csets {IBS: pos map, cross counter} |
|
920
|
|
|
921
|
array set pos {} |
|
922
|
array set cross {} |
|
923
|
array set depc {} |
|
924
|
set range {} |
|
925
|
set n 0 |
|
926
|
foreach rev $revisions { |
|
927
|
lappend range $n |
|
928
|
set pos($rev) $n |
|
929
|
set cross($n) 0 |
|
930
|
incr n |
|
931
|
} |
|
932
|
|
|
933
|
log write 14 csets {IBS: pos/[array size pos], cross/[array size cross]} |
|
934
|
|
|
935
|
# Secondly we count the crossings per position, by iterating |
|
936
|
# over the recorded internal dependencies. |
|
937
|
|
|
938
|
# Note: If the timestamps are badly out of order it is |
|
939
|
# possible to have a backward successor dependency, |
|
940
|
# i.e. with start > end. We may have to swap the indices |
|
941
|
# to ensure that the following loop runs correctly. |
|
942
|
# |
|
943
|
# Note 2: start == end is not possible. It indicates a |
|
944
|
# self-dependency due to the uniqueness of positions, |
|
945
|
# and that is something we have ruled out already, see |
|
946
|
# 'rev internalsuccessors'. |
|
947
|
|
|
948
|
log write 14 csets {IBS: cross counter filling, pos/cross map} |
|
949
|
|
|
950
|
foreach {rid children} [array get dependencies] { |
|
951
|
foreach child $children { |
|
952
|
set dkey [list $rid $child] |
|
953
|
set start $pos($rid) |
|
954
|
set end $pos($child) |
|
955
|
|
|
956
|
if {$start > $end} { |
|
957
|
set crosses [list $end [expr {$start-1}]] |
|
958
|
while {$end < $start} { |
|
959
|
incr cross($end) |
|
960
|
incr end |
|
961
|
} |
|
962
|
} else { |
|
963
|
set crosses [list $start [expr {$end-1}]] |
|
964
|
while {$start < $end} { |
|
965
|
incr cross($start) |
|
966
|
incr start |
|
967
|
} |
|
968
|
} |
|
969
|
set depc($dkey) $crosses |
|
970
|
} |
|
971
|
} |
|
972
|
|
|
973
|
log write 14 csets {IBS: pos/[array size pos], cross/[array size cross], depc/[array size depc] (for [llength $revisions])} |
|
974
|
log write 14 csets {IBS: timestamps, deltas} |
|
975
|
|
|
976
|
InitializeDeltas $revisions |
|
977
|
|
|
978
|
log write 14 csets {IBS: delta [array size delta]} |
|
979
|
return |
|
980
|
} |
|
981
|
|
|
982
|
proc InitializeDeltas {revisions} { |
|
983
|
upvar 1 delta delta |
|
984
|
|
|
985
|
# Pull the timestamps for all revisions in the changesets and |
|
986
|
# compute their deltas for use by the break finder. |
|
987
|
|
|
988
|
array set delta {} |
|
989
|
array set stamp {} |
|
990
|
|
|
991
|
set theset ('[join $revisions {','}]') |
|
992
|
state foreachrow [subst -nocommands -nobackslashes { |
|
993
|
SELECT R.rid AS xrid, R.date AS time |
|
994
|
FROM revision R |
|
995
|
WHERE R.rid IN $theset |
|
996
|
}] { |
|
997
|
set stamp($xrid) $time |
|
998
|
} |
|
999
|
|
|
1000
|
log write 14 csets {IBS: stamp [array size stamp]} |
|
1001
|
|
|
1002
|
set n 0 |
|
1003
|
foreach rid [lrange $revisions 0 end-1] rnext [lrange $revisions 1 end] { |
|
1004
|
set delta($n) [expr {$stamp($rnext) - $stamp($rid)}] |
|
1005
|
incr n |
|
1006
|
} |
|
1007
|
return |
|
1008
|
} |
|
1009
|
|
|
1010
|
proc FindBestBreak {range} { |
|
1011
|
upvar 1 cross cross delta delta |
|
1012
|
|
|
1013
|
# Determine the best break location in the given range of |
|
1014
|
# positions. First we look for the locations with the maximal |
|
1015
|
# number of crossings. If there are several we look for the |
|
1016
|
# shortest time interval among them. If we still have multiple |
|
1017
|
# possibilities after that we select the earliest location |
|
1018
|
# among these. |
|
1019
|
|
|
1020
|
# Note: If the maximal number of crossings is 0 then the range |
|
1021
|
# has no internal dependencies, and no break location at |
|
1022
|
# all. This possibility is signaled via result -1. |
|
1023
|
|
|
1024
|
# Note: A range of length 1 or less cannot have internal |
|
1025
|
# dependencies, as that needs at least two revisions in |
|
1026
|
# the range. |
|
1027
|
|
|
1028
|
if {[llength $range] < 2} { return -1 } |
|
1029
|
|
|
1030
|
set max -1 |
|
1031
|
set best {} |
|
1032
|
|
|
1033
|
foreach location $range { |
|
1034
|
set crossings $cross($location) |
|
1035
|
if {$crossings > $max} { |
|
1036
|
set max $crossings |
|
1037
|
set best [list $location] |
|
1038
|
continue |
|
1039
|
} elseif {$crossings == $max} { |
|
1040
|
lappend best $location |
|
1041
|
} |
|
1042
|
} |
|
1043
|
|
|
1044
|
if {$max == 0} { return -1 } |
|
1045
|
if {[llength $best] == 1} { return [lindex $best 0] } |
|
1046
|
|
|
1047
|
set locations $best |
|
1048
|
set best {} |
|
1049
|
set min -1 |
|
1050
|
|
|
1051
|
foreach location $locations { |
|
1052
|
set interval $delta($location) |
|
1053
|
if {($min < 0) || ($interval < $min)} { |
|
1054
|
set min $interval |
|
1055
|
set best [list $location] |
|
1056
|
} elseif {$interval == $min} { |
|
1057
|
lappend best $location |
|
1058
|
} |
|
1059
|
} |
|
1060
|
|
|
1061
|
if {[llength $best] == 1} { return [lindex $best 0] } |
|
1062
|
|
|
1063
|
return [lindex [lsort -integer -increasing $best] 0] |
|
1064
|
} |
|
1065
|
|
|
1066
|
proc CutAt {location} { |
|
1067
|
upvar 1 cross cross depc depc |
|
1068
|
|
|
1069
|
# It was decided to split the changeset at the given |
|
1070
|
# location. This cuts a number of dependencies. Here we update |
|
1071
|
# the cross information so that the break finder has accurate |
|
1072
|
# data when we look at the generated fragments. |
|
1073
|
|
|
1074
|
set six [log visible? 6] |
|
1075
|
|
|
1076
|
# Note: The loop below could be made faster by keeping a map |
|
1077
|
# from positions to the dependencies crossing. An extension of |
|
1078
|
# CROSS, i.e. list of dependencies, counter is implied. Takes |
|
1079
|
# a lot more memory however, and takes time to update here |
|
1080
|
# (The inner loop is not incr -1, but ldelete). |
|
1081
|
|
|
1082
|
foreach dep [array names depc] { |
|
1083
|
set range $depc($dep) |
|
1084
|
# Check all dependencies still known, take their range and |
|
1085
|
# see if the break location falls within. |
|
1086
|
|
|
1087
|
Border $range s e |
|
1088
|
if {$location < $s} continue ; # break before range, ignore |
|
1089
|
if {$location > $e} continue ; # break after range, ignore. |
|
1090
|
|
|
1091
|
# This dependency crosses the break location. We remove it |
|
1092
|
# from the crossings counters, and then also from the set |
|
1093
|
# of known dependencies, as we are done with it. |
|
1094
|
|
|
1095
|
Border $depc($dep) ds de |
|
1096
|
for {set loc $ds} {$loc <= $de} {incr loc} { |
|
1097
|
incr cross($loc) -1 |
|
1098
|
} |
|
1099
|
unset depc($dep) |
|
1100
|
|
|
1101
|
if {!$six} continue |
|
1102
|
|
|
1103
|
struct::list assign $dep parent child |
|
1104
|
log write 5 csets "Broke dependency [PD $parent] --> [PD $child]" |
|
1105
|
} |
|
1106
|
|
|
1107
|
return |
|
1108
|
} |
|
1109
|
|
|
1110
|
# Print identifying data for a revision (project, file, dotted rev |
|
1111
|
# number), for high verbosity log output. |
|
1112
|
# TODO: Replace with call to itemstr (list rev $id) |
|
1113
|
|
|
1114
|
proc PD {id} { |
|
1115
|
foreach {p f r} [state run { |
|
1116
|
SELECT P.name , F.name, R.rev |
|
1117
|
FROM revision R, file F, project P |
|
1118
|
WHERE R.rid = $id -- Find specified file revision |
|
1119
|
AND F.fid = R.fid -- Get file of the revision |
|
1120
|
AND P.pid = F.pid -- Get project of the file. |
|
1121
|
}] break |
|
1122
|
return "'$p : $f/$r'" |
|
1123
|
} |
|
1124
|
|
|
1125
|
# Printing one or more ranges, formatted, and only their border to |
|
1126
|
# keep the strings short. |
|
1127
|
|
|
1128
|
proc PRs {ranges} { |
|
1129
|
return [struct::list map $ranges [myproc PR]] |
|
1130
|
} |
|
1131
|
|
|
1132
|
proc PR {range} { |
|
1133
|
Border $range s e |
|
1134
|
return <${s}...${e}> |
|
1135
|
} |
|
1136
|
|
|
1137
|
proc Border {range sv ev} { |
|
1138
|
upvar 1 $sv s $ev e |
|
1139
|
set s [lindex $range 0] |
|
1140
|
set e [lindex $range end] |
|
1141
|
return |
|
1142
|
} |
|
1143
|
|
|
1144
|
# # ## ### ##### ######## ############# |
|
1145
|
|
|
1146
|
proc UnmapItems {thetype theitems} { |
|
1147
|
# (*) We clear out the associated part of the myitemmap |
|
1148
|
# in-memory index in preparation for new data, or as part of |
|
1149
|
# object destruction. A simple unset is enough, we have no |
|
1150
|
# symbol changesets at this time, and thus never more than one |
|
1151
|
# reference in the list. |
|
1152
|
|
|
1153
|
upvar 1 myitemmap myitemmap self self |
|
1154
|
foreach iid $theitems { |
|
1155
|
set key [list $thetype $iid] |
|
1156
|
unset myitemmap($key) |
|
1157
|
log write 8 csets {MAP- item <$key> $self = [$self str]} |
|
1158
|
} |
|
1159
|
return |
|
1160
|
} |
|
1161
|
|
|
1162
|
proc MapItems {thetype theitems} { |
|
1163
|
upvar 1 myitemmap myitemmap self self |
|
1164
|
|
|
1165
|
foreach iid $theitems { |
|
1166
|
set key [list $thetype $iid] |
|
1167
|
set myitemmap($key) $self |
|
1168
|
log write 8 csets {MAP+ item <$key> $self = [$self str]} |
|
1169
|
} |
|
1170
|
return |
|
1171
|
} |
|
1172
|
|
|
1173
|
# # ## ### ##### ######## ############# |
|
1174
|
|
|
1175
|
typevariable mychangesets {} ; # List of all known |
|
1176
|
# changesets. |
|
1177
|
|
|
1178
|
# List of all known changesets of a type. |
|
1179
|
typevariable mytchangesets -array { |
|
1180
|
sym::branch {} |
|
1181
|
sym::tag {} |
|
1182
|
rev {} |
|
1183
|
} |
|
1184
|
|
|
1185
|
typevariable myitemmap -array {} ; # Map from items (tagged) |
|
1186
|
# to the list of changesets |
|
1187
|
# containing it. Each item |
|
1188
|
# can be used by only one |
|
1189
|
# changeset. |
|
1190
|
typevariable myidmap -array {} ; # Map from changeset id to |
|
1191
|
# changeset. |
|
1192
|
|
|
1193
|
typemethod all {} { return $mychangesets } |
|
1194
|
typemethod of {cid} { return $myidmap($cid) } |
|
1195
|
typemethod ofitem {iid} { return $myitemmap($iid) } |
|
1196
|
|
|
1197
|
typemethod rev {} { return $mytchangesets(rev) } |
|
1198
|
typemethod sym {} { return [concat \ |
|
1199
|
${mytchangesets(sym::branch)} \ |
|
1200
|
${mytchangesets(sym::tag)}] } |
|
1201
|
|
|
1202
|
# # ## ### ##### ######## ############# |
|
1203
|
## Configuration |
|
1204
|
|
|
1205
|
pragma -hastypeinfo no ; # no type introspection |
|
1206
|
pragma -hasinfo no ; # no object introspection |
|
1207
|
|
|
1208
|
# # ## ### ##### ######## ############# |
|
1209
|
} |
|
1210
|
|
|
1211
|
## |
|
1212
|
## NOTE: The successor and predecessor methods defined by the classes |
|
1213
|
## below are -- bottle necks --. Look for ways to make the SQL |
|
1214
|
## faster. |
|
1215
|
## |
|
1216
|
|
|
1217
|
# # ## ### ##### ######## ############# ##################### |
|
1218
|
## Helper singleton. Commands for revision changesets. |
|
1219
|
|
|
1220
|
snit::type ::vc::fossil::import::cvs::project::rev::rev { |
|
1221
|
typemethod byrevision {} { return 1 } |
|
1222
|
typemethod bysymbol {} { return 0 } |
|
1223
|
typemethod istag {} { return 0 } |
|
1224
|
typemethod isbranch {} { return 0 } |
|
1225
|
|
|
1226
|
typemethod str {revision} { |
|
1227
|
struct::list assign [state run { |
|
1228
|
SELECT R.rev, F.name, P.name |
|
1229
|
FROM revision R, file F, project P |
|
1230
|
WHERE R.rid = $revision -- Find specified file revision |
|
1231
|
AND F.fid = R.fid -- Get file of the revision |
|
1232
|
AND P.pid = F.pid -- Get project of the file. |
|
1233
|
}] revnr fname pname |
|
1234
|
return "$pname/${revnr}::$fname" |
|
1235
|
} |
|
1236
|
|
|
1237
|
# result = list (mintime, maxtime) |
|
1238
|
typemethod timerange {items} { |
|
1239
|
set theset ('[join $items {','}]') |
|
1240
|
return [state run [subst -nocommands -nobackslashes { |
|
1241
|
SELECT MIN(R.date), MAX(R.date) |
|
1242
|
FROM revision R |
|
1243
|
WHERE R.rid IN $theset -- Restrict to revisions of interest |
|
1244
|
}]] |
|
1245
|
} |
|
1246
|
|
|
1247
|
# var(dv) = dict (revision -> list (revision)) |
|
1248
|
typemethod internalsuccessors {dv revisions} { |
|
1249
|
upvar 1 $dv dependencies |
|
1250
|
set theset ('[join $revisions {','}]') |
|
1251
|
|
|
1252
|
log write 14 csets internalsuccessors |
|
1253
|
|
|
1254
|
# See 'successors' below for the main explanation of |
|
1255
|
# the various cases. This piece is special in that it |
|
1256
|
# restricts the successors we look for to the same set of |
|
1257
|
# revisions we start from. Sensible as we are looking for |
|
1258
|
# changeset internal dependencies. |
|
1259
|
|
|
1260
|
array set dep {} |
|
1261
|
|
|
1262
|
state foreachrow [subst -nocommands -nobackslashes { |
|
1263
|
-- (1) Primary child |
|
1264
|
SELECT R.rid AS xrid, R.child AS xchild |
|
1265
|
FROM revision R |
|
1266
|
WHERE R.rid IN $theset -- Restrict to revisions of interest |
|
1267
|
AND R.child IS NOT NULL -- Has primary child |
|
1268
|
AND R.child IN $theset -- Which is also of interest |
|
1269
|
UNION |
|
1270
|
-- (2) Secondary (branch) children |
|
1271
|
SELECT R.rid AS xrid, B.brid AS xchild |
|
1272
|
FROM revision R, revisionbranchchildren B |
|
1273
|
WHERE R.rid IN $theset -- Restrict to revisions of interest |
|
1274
|
AND R.rid = B.rid -- Select subset of branch children |
|
1275
|
AND B.brid IN $theset -- Which is also of interest |
|
1276
|
UNION |
|
1277
|
-- (4) Child of trunk root successor of last NTDB on trunk. |
|
1278
|
SELECT R.rid AS xrid, RA.child AS xchild |
|
1279
|
FROM revision R, revision RA |
|
1280
|
WHERE R.rid IN $theset -- Restrict to revisions of interest |
|
1281
|
AND R.isdefault -- Restrict to NTDB |
|
1282
|
AND R.dbchild IS NOT NULL -- and last NTDB belonging to trunk |
|
1283
|
AND RA.rid = R.dbchild -- Go directly to trunk root |
|
1284
|
AND RA.child IS NOT NULL -- Has primary child. |
|
1285
|
AND RA.child IN $theset -- Which is also of interest |
|
1286
|
}] { |
|
1287
|
# Consider moving this to the integrity module. |
|
1288
|
integrity assert {$xrid != $xchild} {Revision $xrid depends on itself.} |
|
1289
|
lappend dependencies($xrid) $xchild |
|
1290
|
set dep($xrid,$xchild) . |
|
1291
|
} |
|
1292
|
|
|
1293
|
# The sql statements above looks only for direct dependencies |
|
1294
|
# between revision in the changeset. However due to the |
|
1295
|
# vagaries of meta data it is possible for two revisions of |
|
1296
|
# the same file to end up in the same changeset, without a |
|
1297
|
# direct dependency between them. However we know that there |
|
1298
|
# has to be a an indirect dependency, be it through primary |
|
1299
|
# children, branch children, or a combination thereof. |
|
1300
|
|
|
1301
|
# We now fill in these pseudo-dependencies, if no such |
|
1302
|
# dependency exists already. The direction of the dependency |
|
1303
|
# is actually irrelevant for this. |
|
1304
|
|
|
1305
|
# NOTE: This is different from cvs2svn. Our spiritual ancestor |
|
1306
|
# does not use such pseudo-dependencies, however it uses a |
|
1307
|
# COMMIT_THRESHOLD, a time interval commits should fall. This |
|
1308
|
# will greatly reduces the risk of getting far separated |
|
1309
|
# revisions of the same file into one changeset. |
|
1310
|
|
|
1311
|
# We allow revisions to be far apart in time in the same |
|
1312
|
# changeset, but in turn need the pseudo-dependencies to |
|
1313
|
# handle this. |
|
1314
|
|
|
1315
|
log write 14 csets {internal [array size dep]} |
|
1316
|
log write 14 csets {collected [array size dependencies]} |
|
1317
|
log write 14 csets pseudo-internalsuccessors |
|
1318
|
|
|
1319
|
array set fids {} |
|
1320
|
state foreachrow [subst -nocommands -nobackslashes { |
|
1321
|
SELECT R.rid AS xrid, R.fid AS xfid |
|
1322
|
FROM revision R |
|
1323
|
WHERE R.rid IN $theset |
|
1324
|
}] { lappend fids($xfid) $xrid } |
|
1325
|
|
|
1326
|
set groups {} |
|
1327
|
foreach {fid rids} [array get fids] { |
|
1328
|
if {[llength $rids] < 2} continue |
|
1329
|
foreach a $rids { |
|
1330
|
foreach b $rids { |
|
1331
|
if {$a == $b} continue |
|
1332
|
if {[info exists dep($a,$b)]} continue |
|
1333
|
if {[info exists dep($b,$a)]} continue |
|
1334
|
lappend dependencies($a) $b |
|
1335
|
set dep($a,$b) . |
|
1336
|
set dep($b,$a) . |
|
1337
|
} |
|
1338
|
} |
|
1339
|
set n [llength $rids] |
|
1340
|
lappend groups [list $n [expr {($n*$n-$n)/2}]] |
|
1341
|
} |
|
1342
|
|
|
1343
|
log write 14 csets {pseudo [array size fids] ([lsort -index 0 -decreasing -integer $groups])} |
|
1344
|
log write 14 csets {internal [array size dep]} |
|
1345
|
log write 14 csets {collected [array size dependencies]} |
|
1346
|
log write 14 csets complete |
|
1347
|
return |
|
1348
|
} |
|
1349
|
|
|
1350
|
# result = 4-list (itemtype itemid nextitemtype nextitemid ...) |
|
1351
|
typemethod loops {revisions} { |
|
1352
|
# Note: Tags and branches cannot cause the loop. Their id's, |
|
1353
|
# being of a fundamentally different type than the revisions |
|
1354
|
# coming in cannot be in the set. |
|
1355
|
|
|
1356
|
set theset ('[join $revisions {','}]') |
|
1357
|
return [state run [subst -nocommands -nobackslashes { |
|
1358
|
-- (1) Primary child |
|
1359
|
SELECT R.rid, R.child |
|
1360
|
FROM revision R |
|
1361
|
WHERE R.rid IN $theset -- Restrict to revisions of interest |
|
1362
|
AND R.child IS NOT NULL -- Has primary child |
|
1363
|
AND R.child IN $theset -- Loop |
|
1364
|
-- |
|
1365
|
UNION |
|
1366
|
-- (2) Secondary (branch) children |
|
1367
|
SELECT R.rid, B.brid |
|
1368
|
FROM revision R, revisionbranchchildren B |
|
1369
|
WHERE R.rid IN $theset -- Restrict to revisions of interest |
|
1370
|
AND R.rid = B.rid -- Select subset of branch children |
|
1371
|
AND B.rid IN $theset -- Loop |
|
1372
|
-- |
|
1373
|
UNION |
|
1374
|
-- (4) Child of trunk root successor of last NTDB on trunk. |
|
1375
|
SELECT R.rid, RA.child |
|
1376
|
FROM revision R, revision RA |
|
1377
|
WHERE R.rid IN $theset -- Restrict to revisions of interest |
|
1378
|
AND R.isdefault -- Restrict to NTDB |
|
1379
|
AND R.dbchild IS NOT NULL -- and last NTDB belonging to trunk |
|
1380
|
AND RA.rid = R.dbchild -- Go directly to trunk root |
|
1381
|
AND RA.child IS NOT NULL -- Has primary child. |
|
1382
|
AND RA.child IN $theset -- Loop |
|
1383
|
}]] |
|
1384
|
} |
|
1385
|
|
|
1386
|
# var(dv) = dict (item -> list (item)), item = list (type id) |
|
1387
|
typemethod successors {dv revisions} { |
|
1388
|
upvar 1 $dv dependencies |
|
1389
|
set theset ('[join $revisions {','}]') |
|
1390
|
|
|
1391
|
# The following cases specify when a revision S is a successor |
|
1392
|
# of a revision R. Each of the cases translates into one of |
|
1393
|
# the branches of the SQL UNION coming below. |
|
1394
|
# |
|
1395
|
# (1) S can be a primary child of R, i.e. in the same LOD. R |
|
1396
|
# references S directly. R.child = S(.rid), if it exists. |
|
1397
|
# |
|
1398
|
# (2) S can be a secondary, i.e. branch, child of R. Here the |
|
1399
|
# link is made through the helper table |
|
1400
|
# REVISIONBRANCHCHILDREN. R.rid -> RBC.rid, RBC.brid = |
|
1401
|
# S(.rid) |
|
1402
|
# |
|
1403
|
# (3) Originally this use case defined the root of a detached |
|
1404
|
# NTDB as the successor of the trunk root. This leads to a |
|
1405
|
# bad tangle later on. With a detached NTDB the original |
|
1406
|
# trunk root revision was removed as irrelevant, allowing |
|
1407
|
# the nominal root to be later in time than the NTDB |
|
1408
|
# root. Now setting this dependency will be backward in |
|
1409
|
# time. REMOVED. |
|
1410
|
# |
|
1411
|
# (4) If R is the last of the NTDB revisions which belong to |
|
1412
|
# the trunk, then the primary child of the trunk root (the |
|
1413
|
# '1.2' revision) is a successor, if it exists. |
|
1414
|
|
|
1415
|
# Note that the branches spawned from the revisions, and the |
|
1416
|
# tags associated with them are successors as well. |
|
1417
|
|
|
1418
|
state foreachrow [subst -nocommands -nobackslashes { |
|
1419
|
-- (1) Primary child |
|
1420
|
SELECT R.rid AS xrid, R.child AS xchild |
|
1421
|
FROM revision R |
|
1422
|
WHERE R.rid IN $theset -- Restrict to revisions of interest |
|
1423
|
AND R.child IS NOT NULL -- Has primary child |
|
1424
|
UNION |
|
1425
|
-- (2) Secondary (branch) children |
|
1426
|
SELECT R.rid AS xrid, B.brid AS xchild |
|
1427
|
FROM revision R, revisionbranchchildren B |
|
1428
|
WHERE R.rid IN $theset -- Restrict to revisions of interest |
|
1429
|
AND R.rid = B.rid -- Select subset of branch children |
|
1430
|
UNION |
|
1431
|
-- (4) Child of trunk root successor of last NTDB on trunk. |
|
1432
|
SELECT R.rid AS xrid, RA.child AS xchild |
|
1433
|
FROM revision R, revision RA |
|
1434
|
WHERE R.rid IN $theset -- Restrict to revisions of interest |
|
1435
|
AND R.isdefault -- Restrict to NTDB |
|
1436
|
AND R.dbchild IS NOT NULL -- and last NTDB belonging to trunk |
|
1437
|
AND RA.rid = R.dbchild -- Go directly to trunk root |
|
1438
|
AND RA.child IS NOT NULL -- Has primary child. |
|
1439
|
}] { |
|
1440
|
# Consider moving this to the integrity module. |
|
1441
|
integrity assert {$xrid != $xchild} {Revision $xrid depends on itself.} |
|
1442
|
lappend dependencies([list rev $xrid]) [list rev $xchild] |
|
1443
|
} |
|
1444
|
state foreachrow [subst -nocommands -nobackslashes { |
|
1445
|
SELECT R.rid AS xrid, T.tid AS xchild |
|
1446
|
FROM revision R, tag T |
|
1447
|
WHERE R.rid IN $theset -- Restrict to revisions of interest |
|
1448
|
AND T.rev = R.rid -- Select tags attached to them |
|
1449
|
}] { |
|
1450
|
lappend dependencies([list rev $xrid]) [list sym::tag $xchild] |
|
1451
|
} |
|
1452
|
state foreachrow [subst -nocommands -nobackslashes { |
|
1453
|
SELECT R.rid AS xrid, B.bid AS xchild |
|
1454
|
FROM revision R, branch B |
|
1455
|
WHERE R.rid IN $theset -- Restrict to revisions of interest |
|
1456
|
AND B.root = R.rid -- Select branches attached to them |
|
1457
|
}] { |
|
1458
|
lappend dependencies([list rev $xrid]) [list sym::branch $xchild] |
|
1459
|
} |
|
1460
|
return |
|
1461
|
} |
|
1462
|
|
|
1463
|
# result = list (changeset-id) |
|
1464
|
typemethod cs_successors {revisions} { |
|
1465
|
# This is a variant of 'successors' which maps the low-level |
|
1466
|
# data directly to the associated changesets. I.e. instead |
|
1467
|
# millions of dependency pairs (in extreme cases (Example: Tcl |
|
1468
|
# CVS)) we return a very short and much more manageable list |
|
1469
|
# of changesets. |
|
1470
|
|
|
1471
|
set theset ('[join $revisions {','}]') |
|
1472
|
return [state run [subst -nocommands -nobackslashes { |
|
1473
|
-- (1) Primary child |
|
1474
|
SELECT C.cid |
|
1475
|
FROM revision R, csitem CI, changeset C |
|
1476
|
WHERE R.rid IN $theset -- Restrict to revisions of interest |
|
1477
|
AND R.child IS NOT NULL -- Has primary child |
|
1478
|
AND CI.iid = R.child -- Select all changesets |
|
1479
|
AND C.cid = CI.cid -- containing the primary child |
|
1480
|
AND C.type = 0 -- which are revision changesets |
|
1481
|
UNION |
|
1482
|
-- (2) Secondary (branch) children |
|
1483
|
SELECT C.cid |
|
1484
|
FROM revision R, revisionbranchchildren B, csitem CI, changeset C |
|
1485
|
WHERE R.rid IN $theset -- Restrict to revisions of interest |
|
1486
|
AND R.rid = B.rid -- Select subset of branch children |
|
1487
|
AND CI.iid = B.brid -- Select all changesets |
|
1488
|
AND C.cid = CI.cid -- containing the branch |
|
1489
|
AND C.type = 0 -- which are revision changesets |
|
1490
|
UNION |
|
1491
|
-- (4) Child of trunk root successor of last NTDB on trunk. |
|
1492
|
SELECT C.cid |
|
1493
|
FROM revision R, revision RA, csitem CI, changeset C |
|
1494
|
WHERE R.rid IN $theset -- Restrict to revisions of interest |
|
1495
|
AND R.isdefault -- Restrict to NTDB |
|
1496
|
AND R.dbchild IS NOT NULL -- and last NTDB belonging to trunk |
|
1497
|
AND RA.rid = R.dbchild -- Go directly to trunk root |
|
1498
|
AND RA.child IS NOT NULL -- Has primary child. |
|
1499
|
AND CI.iid = RA.child -- Select all changesets |
|
1500
|
AND C.cid = CI.cid -- containing the primary child |
|
1501
|
AND C.type = 0 -- which are revision changesets |
|
1502
|
UNION |
|
1503
|
SELECT C.cid |
|
1504
|
FROM revision R, tag T, csitem CI, changeset C |
|
1505
|
WHERE R.rid in $theset -- Restrict to revisions of interest |
|
1506
|
AND T.rev = R.rid -- Select tags attached to them |
|
1507
|
AND CI.iid = T.tid -- Select all changesets |
|
1508
|
AND C.cid = CI.cid -- containing the tags |
|
1509
|
AND C.type = 1 -- which are tag changesets |
|
1510
|
UNION |
|
1511
|
SELECT C.cid |
|
1512
|
FROM revision R, branch B, csitem CI, changeset C |
|
1513
|
WHERE R.rid in $theset -- Restrict to revisions of interest |
|
1514
|
AND B.root = R.rid -- Select branches attached to them |
|
1515
|
AND CI.iid = B.bid -- Select all changesets |
|
1516
|
AND C.cid = CI.cid -- containing the branches |
|
1517
|
AND C.type = 2 -- which are branch changesets |
|
1518
|
}]] |
|
1519
|
|
|
1520
|
# Regarding rev -> branch|tag, we could consider looking at |
|
1521
|
# the symbol of the branch|tag, its lod-symbol, and the |
|
1522
|
# revisions on that lod, but don't. Because it is not exact |
|
1523
|
# enough, the branch|tag would depend on revisions coming |
|
1524
|
# after its creation on the parental lod. |
|
1525
|
} |
|
1526
|
|
|
1527
|
# result = symbol name |
|
1528
|
typemethod cs_lod {metaid revisions} { |
|
1529
|
# Determines the name of the symbol which is the line of |
|
1530
|
# development for the revisions in a changeset. The |
|
1531
|
# information in the meta data referenced by the source metaid |
|
1532
|
# is out of date by the time we come here (since pass |
|
1533
|
# FilterSymbols), so it cannot be used. See the method 'run' |
|
1534
|
# in file "c2f_pfiltersym.tcl" for more commentary on this. |
|
1535
|
|
|
1536
|
set theset ('[join $revisions {','}]') |
|
1537
|
return [state run [subst -nocommands -nobackslashes { |
|
1538
|
SELECT |
|
1539
|
DISTINCT L.name |
|
1540
|
FROM revision R, symbol L |
|
1541
|
WHERE R.rid in $theset -- Restrict to revisions of interest |
|
1542
|
AND L.sid = R.lod -- Get lod symbol of revision |
|
1543
|
}]] |
|
1544
|
} |
|
1545
|
} |
|
1546
|
|
|
1547
|
# # ## ### ##### ######## ############# ##################### |
|
1548
|
## Helper singleton. Commands for tag symbol changesets. |
|
1549
|
|
|
1550
|
snit::type ::vc::fossil::import::cvs::project::rev::sym::tag { |
|
1551
|
typemethod byrevision {} { return 0 } |
|
1552
|
typemethod bysymbol {} { return 1 } |
|
1553
|
typemethod istag {} { return 1 } |
|
1554
|
typemethod isbranch {} { return 0 } |
|
1555
|
|
|
1556
|
typemethod str {tag} { |
|
1557
|
struct::list assign [state run { |
|
1558
|
SELECT S.name, F.name, P.name |
|
1559
|
FROM tag T, symbol S, file F, project P |
|
1560
|
WHERE T.tid = $tag -- Find specified tag |
|
1561
|
AND F.fid = T.fid -- Get file of tag |
|
1562
|
AND P.pid = F.pid -- Get project of file |
|
1563
|
AND S.sid = T.sid -- Get symbol of tag |
|
1564
|
}] sname fname pname |
|
1565
|
return "$pname/T'${sname}'::$fname" |
|
1566
|
} |
|
1567
|
|
|
1568
|
# result = list (mintime, maxtime) |
|
1569
|
typemethod timerange {tags} { |
|
1570
|
# The range is defined as the range of the revisions the tags |
|
1571
|
# are attached to. |
|
1572
|
|
|
1573
|
set theset ('[join $tags {','}]') |
|
1574
|
return [state run [subst -nocommands -nobackslashes { |
|
1575
|
SELECT MIN(R.date), MAX(R.date) |
|
1576
|
FROM tag T, revision R |
|
1577
|
WHERE T.tid IN $theset -- Restrict to tags of interest |
|
1578
|
AND R.rid = T.rev -- Select tag parent revisions |
|
1579
|
}]] |
|
1580
|
} |
|
1581
|
|
|
1582
|
# var(dv) = dict (item -> list (item)), item = list (type id) |
|
1583
|
typemethod successors {dv tags} { |
|
1584
|
# Tags have no successors. |
|
1585
|
return |
|
1586
|
} |
|
1587
|
|
|
1588
|
# result = 4-list (itemtype itemid nextitemtype nextitemid ...) |
|
1589
|
typemethod loops {tags} { |
|
1590
|
# Tags have no successors, therefore cannot cause loops |
|
1591
|
return {} |
|
1592
|
} |
|
1593
|
|
|
1594
|
# result = list (changeset-id) |
|
1595
|
typemethod cs_successors {tags} { |
|
1596
|
# Tags have no successors. |
|
1597
|
return |
|
1598
|
} |
|
1599
|
|
|
1600
|
# result = symbol name |
|
1601
|
typemethod cs_lod {sid tags} { |
|
1602
|
# Determines the name of the symbol which is the line of |
|
1603
|
# development for the tags in a changeset. Comes directly from |
|
1604
|
# the symbol which is the changeset's source and its prefered |
|
1605
|
# parent. |
|
1606
|
|
|
1607
|
return [state run { |
|
1608
|
SELECT P.name |
|
1609
|
FROM preferedparent SP, symbol P |
|
1610
|
WHERE SP.sid = $sid |
|
1611
|
AND P.sid = SP.pid |
|
1612
|
}] |
|
1613
|
} |
|
1614
|
} |
|
1615
|
|
|
1616
|
# # ## ### ##### ######## ############# ##################### |
|
1617
|
## Helper singleton. Commands for branch symbol changesets. |
|
1618
|
|
|
1619
|
snit::type ::vc::fossil::import::cvs::project::rev::sym::branch { |
|
1620
|
typemethod byrevision {} { return 0 } |
|
1621
|
typemethod bysymbol {} { return 1 } |
|
1622
|
typemethod istag {} { return 0 } |
|
1623
|
typemethod isbranch {} { return 1 } |
|
1624
|
|
|
1625
|
typemethod str {branch} { |
|
1626
|
struct::list assign [state run { |
|
1627
|
SELECT S.name, F.name, P.name |
|
1628
|
FROM branch B, symbol S, file F, project P |
|
1629
|
WHERE B.bid = $branch -- Find specified branch |
|
1630
|
AND F.fid = B.fid -- Get file of branch |
|
1631
|
AND P.pid = F.pid -- Get project of file |
|
1632
|
AND S.sid = B.sid -- Get symbol of branch |
|
1633
|
}] sname fname pname |
|
1634
|
return "$pname/B'${sname}'::$fname" |
|
1635
|
} |
|
1636
|
|
|
1637
|
# result = list (mintime, maxtime) |
|
1638
|
typemethod timerange {branches} { |
|
1639
|
# The range of a branch is defined as the range of the |
|
1640
|
# revisions the branches are spawned by. NOTE however that the |
|
1641
|
# branches associated with a detached NTDB will have no root |
|
1642
|
# spawning them, hence they have no real timerange any |
|
1643
|
# longer. By using 0 we put them in front of everything else, |
|
1644
|
# as they logically are. |
|
1645
|
|
|
1646
|
set theset ('[join $branches {','}]') |
|
1647
|
return [state run [subst -nocommands -nobackslashes { |
|
1648
|
SELECT IFNULL(MIN(R.date),0), IFNULL(MAX(R.date),0) |
|
1649
|
FROM branch B, revision R |
|
1650
|
WHERE B.bid IN $theset -- Restrict to branches of interest |
|
1651
|
AND R.rid = B.root -- Select branch parent revisions |
|
1652
|
}]] |
|
1653
|
} |
|
1654
|
|
|
1655
|
# result = 4-list (itemtype itemid nextitemtype nextitemid ...) |
|
1656
|
typemethod loops {branches} { |
|
1657
|
# Note: Revisions and tags cannot cause the loop. Being of a |
|
1658
|
# fundamentally different type they cannot be in the incoming |
|
1659
|
# set of ids. |
|
1660
|
|
|
1661
|
set theset ('[join $branches {','}]') |
|
1662
|
return [state run [subst -nocommands -nobackslashes { |
|
1663
|
SELECT B.bid, BX.bid |
|
1664
|
FROM branch B, preferedparent P, branch BX |
|
1665
|
WHERE B.bid IN $theset -- Restrict to branches of interest |
|
1666
|
AND B.sid = P.pid -- Get the prefered branches via |
|
1667
|
AND BX.sid = P.sid -- the branch symbols |
|
1668
|
AND BX.bid IN $theset -- Loop |
|
1669
|
}]] |
|
1670
|
} |
|
1671
|
|
|
1672
|
# var(dv) = dict (item -> list (item)), item = list (type id) |
|
1673
|
typemethod successors {dv branches} { |
|
1674
|
upvar 1 $dv dependencies |
|
1675
|
# The first revision committed on a branch, and all branches |
|
1676
|
# and tags which have it as their prefered parent are the |
|
1677
|
# successors of a branch. |
|
1678
|
|
|
1679
|
set theset ('[join $branches {','}]') |
|
1680
|
state foreachrow [subst -nocommands -nobackslashes { |
|
1681
|
SELECT B.bid AS xbid, R.rid AS xchild |
|
1682
|
FROM branch B, revision R |
|
1683
|
WHERE B.bid IN $theset -- Restrict to branches of interest |
|
1684
|
AND B.first = R.rid -- Get first revision on the branch |
|
1685
|
}] { |
|
1686
|
lappend dependencies([list sym::branch $xbid]) [list rev $xchild] |
|
1687
|
} |
|
1688
|
state foreachrow [subst -nocommands -nobackslashes { |
|
1689
|
SELECT B.bid AS xbid, BX.bid AS xchild |
|
1690
|
FROM branch B, preferedparent P, branch BX |
|
1691
|
WHERE B.bid IN $theset -- Restrict to branches of interest |
|
1692
|
AND B.sid = P.pid -- Get subordinate branches via the |
|
1693
|
AND BX.sid = P.sid -- prefered parents of their symbols |
|
1694
|
}] { |
|
1695
|
lappend dependencies([list sym::branch $xbid]) [list sym::branch $xchild] |
|
1696
|
} |
|
1697
|
state foreachrow [subst -nocommands -nobackslashes { |
|
1698
|
SELECT B.bid AS xbid, T.tid AS xchild |
|
1699
|
FROM branch B, preferedparent P, tag T |
|
1700
|
WHERE B.bid IN $theset -- Restrict to branches of interest |
|
1701
|
AND B.sid = P.pid -- Get subordinate tags via the |
|
1702
|
AND T.sid = P.sid -- prefered parents of their symbols |
|
1703
|
}] { |
|
1704
|
lappend dependencies([list sym::branch $xbid]) [list sym::tag $xchild] |
|
1705
|
} |
|
1706
|
return |
|
1707
|
} |
|
1708
|
|
|
1709
|
# result = list (changeset-id) |
|
1710
|
typemethod cs_successors {branches} { |
|
1711
|
# This is a variant of 'successors' which maps the low-level |
|
1712
|
# data directly to the associated changesets. I.e. instead |
|
1713
|
# millions of dependency pairs (in extreme cases (Example: Tcl |
|
1714
|
# CVS)) we return a very short and much more manageable list |
|
1715
|
# of changesets. |
|
1716
|
|
|
1717
|
set theset ('[join $branches {','}]') |
|
1718
|
return [state run [subst -nocommands -nobackslashes { |
|
1719
|
SELECT C.cid |
|
1720
|
FROM branch B, revision R, csitem CI, changeset C |
|
1721
|
WHERE B.bid IN $theset -- Restrict to branches of interest |
|
1722
|
AND B.first = R.rid -- Get first revision on the branch |
|
1723
|
AND CI.iid = R.rid -- Select all changesets |
|
1724
|
AND C.cid = CI.cid -- containing this revision |
|
1725
|
AND C.type = 0 -- which are revision changesets |
|
1726
|
UNION |
|
1727
|
SELECT C.cid |
|
1728
|
FROM branch B, preferedparent P, branch BX, csitem CI, changeset C |
|
1729
|
WHERE B.bid IN $theset -- Restrict to branches of interest |
|
1730
|
AND B.sid = P.pid -- Get subordinate branches via the |
|
1731
|
AND BX.sid = P.sid -- prefered parents of their symbols |
|
1732
|
AND CI.iid = BX.bid -- Select all changesets |
|
1733
|
AND C.cid = CI.cid -- containing the subordinate branches |
|
1734
|
AND C.type = 2 -- which are branch changesets |
|
1735
|
UNION |
|
1736
|
SELECT C.cid |
|
1737
|
FROM branch B, preferedparent P, tag T, csitem CI, changeset C |
|
1738
|
WHERE B.bid IN $theset -- Restrict to branches of interest |
|
1739
|
AND B.sid = P.pid -- Get subordinate tags via the |
|
1740
|
AND T.sid = P.sid -- prefered parents of their symbols |
|
1741
|
AND CI.iid = T.tid -- Select all changesets |
|
1742
|
AND C.cid = CI.cid -- containing the subordinate tags |
|
1743
|
AND C.type = 1 -- which are tag changesets |
|
1744
|
}]] |
|
1745
|
return |
|
1746
|
} |
|
1747
|
|
|
1748
|
# result = symbol name |
|
1749
|
typemethod cs_lod {sid branches} { |
|
1750
|
# Determines the name of the symbol which is the line of |
|
1751
|
# development for the branches in a changeset. Comes directly |
|
1752
|
# from the symbol which is the changeset's source and its |
|
1753
|
# prefered parent. |
|
1754
|
|
|
1755
|
return [state run { |
|
1756
|
SELECT P.name |
|
1757
|
FROM preferedparent SP, symbol P |
|
1758
|
WHERE SP.sid = $sid |
|
1759
|
AND P.sid = SP.pid |
|
1760
|
}] |
|
1761
|
} |
|
1762
|
|
|
1763
|
typemethod limits {branches} { |
|
1764
|
# Notes. This method exists only for branches. It is needed to |
|
1765
|
# get detailed information about a backward branch. It does |
|
1766
|
# not apply to tags, nor revisions. The queries can also |
|
1767
|
# restrict themselves to the revision sucessors/predecessors |
|
1768
|
# of branches, as only they have ordering data and thus can |
|
1769
|
# cause the backwardness. |
|
1770
|
|
|
1771
|
set theset ('[join $branches {','}]') |
|
1772
|
|
|
1773
|
set maxp [state run [subst -nocommands -nobackslashes { |
|
1774
|
-- maximal predecessor position per branch |
|
1775
|
SELECT B.bid, MAX (CO.pos) |
|
1776
|
FROM branch B, revision R, csitem CI, changeset C, csorder CO |
|
1777
|
WHERE B.bid IN $theset -- Restrict to branches of interest |
|
1778
|
AND B.root = R.rid -- Get branch root revisions |
|
1779
|
AND CI.iid = R.rid -- Get changesets containing the |
|
1780
|
AND C.cid = CI.cid -- root revisions, which are |
|
1781
|
AND C.type = 0 -- revision changesets |
|
1782
|
AND CO.cid = C.cid -- Get their topological ordering |
|
1783
|
GROUP BY B.bid |
|
1784
|
}]] |
|
1785
|
|
|
1786
|
set mins [state run [subst -nocommands -nobackslashes { |
|
1787
|
-- minimal successor position per branch |
|
1788
|
SELECT B.bid, MIN (CO.pos) |
|
1789
|
FROM branch B, revision R, csitem CI, changeset C, csorder CO |
|
1790
|
WHERE B.bid IN $theset -- Restrict to branches of interest |
|
1791
|
AND B.first = R.rid -- Get the first revisions on the branches |
|
1792
|
AND CI.iid = R.rid -- Get changesets containing the |
|
1793
|
AND C.cid = CI.cid -- first revisions, which are |
|
1794
|
AND C.type = 0 -- revision changesets |
|
1795
|
AND CO.cid = C.cid -- Get their topological ordering |
|
1796
|
GROUP BY B.bid |
|
1797
|
}]] |
|
1798
|
|
|
1799
|
return [list $maxp $mins] |
|
1800
|
} |
|
1801
|
|
|
1802
|
# # ## ### ##### ######## ############# |
|
1803
|
## Configuration |
|
1804
|
|
|
1805
|
pragma -hasinstances no ; # singleton |
|
1806
|
pragma -hastypeinfo no ; # no introspection |
|
1807
|
pragma -hastypedestroy no ; # immortal |
|
1808
|
} |
|
1809
|
|
|
1810
|
# # ## ### ##### ######## ############# ##################### |
|
1811
|
## |
|
1812
|
|
|
1813
|
namespace eval ::vc::fossil::import::cvs::project { |
|
1814
|
namespace export rev |
|
1815
|
namespace eval rev { |
|
1816
|
namespace import ::vc::fossil::import::cvs::state |
|
1817
|
namespace import ::vc::fossil::import::cvs::integrity |
|
1818
|
namespace import ::vc::tools::misc::* |
|
1819
|
namespace import ::vc::tools::trouble |
|
1820
|
namespace import ::vc::tools::log |
|
1821
|
log register csets |
|
1822
|
|
|
1823
|
# Set up the helper singletons |
|
1824
|
namespace eval rev { |
|
1825
|
namespace import ::vc::fossil::import::cvs::state |
|
1826
|
namespace import ::vc::fossil::import::cvs::integrity |
|
1827
|
namespace import ::vc::tools::log |
|
1828
|
} |
|
1829
|
namespace eval sym::tag { |
|
1830
|
namespace import ::vc::fossil::import::cvs::state |
|
1831
|
namespace import ::vc::fossil::import::cvs::integrity |
|
1832
|
namespace import ::vc::tools::log |
|
1833
|
} |
|
1834
|
namespace eval sym::branch { |
|
1835
|
namespace import ::vc::fossil::import::cvs::state |
|
1836
|
namespace import ::vc::fossil::import::cvs::integrity |
|
1837
|
namespace import ::vc::tools::log |
|
1838
|
} |
|
1839
|
} |
|
1840
|
} |
|
1841
|
|
|
1842
|
# # ## ### ##### ######## ############# ##################### |
|
1843
|
## Ready |
|
1844
|
|
|
1845
|
package provide vc::fossil::import::cvs::project::rev 1.0 |
|
1846
|
return |
|
1847
|
|