Fossil SCM

fossil-scm / tools / cvs2fossil / lib / c2f_cyclebreaker.tcl
Blame History Raw 580 lines
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
## This file provides a helper package for the passes 6 and 7 which
14
## contains the common code of the cycle breaking algorithm.
15
16
# # ## ### ##### ######## ############# #####################
17
## Requirements
18
19
package require Tcl 8.4 ; # Required runtime.
20
package require snit ; # OO system.
21
package require struct::graph ; # Graph handling.
22
package require struct::list ; # Higher order list operations.
23
package require vc::tools::dot ; # User feedback. DOT export.
24
package require vc::tools::log ; # User feedback.
25
package require vc::tools::trouble ; # Error reporting.
26
package require vc::tools::misc ; # Text formatting.
27
package require vc::fossil::import::cvs::project::rev ; # Project level changesets
28
package require vc::fossil::import::cvs::project::revlink ; # Cycle links.
29
package require vc::fossil::import::cvs::integrity ; # State integrity checks.
30
31
# # ## ### ##### ######## ############# #####################
32
##
33
34
snit::type ::vc::fossil::import::cvs::cyclebreaker {
35
# # ## ### ##### ######## #############
36
## Public API
37
38
typemethod precmd {cmd} {
39
::variable myprecmd $cmd
40
return
41
}
42
43
typemethod savecmd {cmd} {
44
::variable mysavecmd $cmd
45
return
46
}
47
48
typemethod breakcmd {cmd} {
49
::variable mybreakcmd $cmd
50
return
51
}
52
53
# # ## ### ##### ######## #############
54
55
typemethod dotsto {path} {
56
::variable mydotdestination $path
57
return
58
}
59
60
typemethod watch {id} {
61
::variable mywatchids
62
lappend mywatchids $id
63
}
64
65
typemethod dot {label changesets} {
66
::variable mydotprefix $label
67
::variable mydotid 0
68
69
set dg [Setup $changesets 0]
70
Mark $dg
71
$dg destroy
72
return
73
}
74
75
typemethod mark {graph suffix {subgraph {}}} {
76
Mark $graph $suffix $subgraph
77
return
78
}
79
80
# # ## ### ##### ######## #############
81
82
typemethod run {label changesetcmd} {
83
::variable myat 0
84
::variable mydotprefix $label
85
::variable mydotid 0
86
87
# We create a graph of the revision changesets, using the file
88
# level dependencies to construct a first approximation of the
89
# dependencies at the project level. Then we look for cycles
90
# in that graph and break them.
91
92
# 1. Create nodes for all relevant changesets and a mapping
93
# from the revisions to their changesets/nodes.
94
95
set changesets [uplevel #0 $changesetcmd]
96
set dg [Setup $changesets]
97
98
# 3. Lastly we iterate the graph topologically. We mark off
99
# the nodes which have no predecessors, in order from
100
# oldest to youngest, saving and removing dependencies. If
101
# we find no nodes without predecessors we have a cycle,
102
# and work on breaking it.
103
104
log write 3 cyclebreaker {Traverse changesets}
105
106
InitializeCandidates $dg
107
108
set k 0
109
set max [llength [$dg nodes]]
110
while {1} {
111
while {[WithoutPredecessor $dg n]} {
112
log progress 2 cyclebreaker $k $max ; incr k
113
MarkWatch $dg
114
ProcessedHook $dg $n $myat
115
$dg node delete $n
116
incr myat
117
ShowPendingNodes
118
}
119
120
if {![llength [$dg nodes]]} break
121
122
BreakCycleHook $dg
123
InitializeCandidates $dg
124
MarkWatch $dg
125
}
126
127
$dg destroy
128
129
log write 3 cyclebreaker Done.
130
ClearHooks
131
132
# Reread the graph and dump its final form, if graph export
133
# was activated.
134
135
::variable mydotdestination
136
if {$mydotdestination eq ""} return
137
138
set dg [Setup [uplevel #0 $changesetcmd] 0]
139
Mark $dg -done
140
$dg destroy
141
return
142
}
143
144
# # ## ### ##### ######## #############
145
146
typemethod break-segment {graph} {
147
BreakSegment $graph $path "segment ([project::rev strlist $path])"
148
return
149
}
150
151
typemethod break {graph} {
152
set cycle [FindCycle $graph]
153
set label "cycle ([project::rev strlist $cycle])"
154
155
# NOTE: cvs2svn uses the sequence "end-1, cycle, 0" to create
156
# the path from the cycle. The only effect I can see is
157
# that this causes the link-triples to be generated in a
158
# sightly different order, i.e. one link rotated to the
159
# right. This should have no effect on the search for
160
# the best of all.
161
162
lappend cycle [lindex $cycle 0] [lindex $cycle 1]
163
BreakSegment $graph $cycle $label
164
return
165
}
166
167
typemethod replace {graph n replacements} {
168
Replace $graph $n $replacements
169
return
170
}
171
172
# # ## ### ##### ######## #############
173
## Internal methods
174
175
proc Setup {changesets {log 1}} {
176
if {$log} {
177
log write 3 cyclebreaker "Creating graph of changesets"
178
}
179
180
set dg [struct::graph dg]
181
182
set n 0
183
set max [llength $changesets]
184
185
foreach cset $changesets {
186
log progress 2 cyclebreaker $n $max
187
set tr [$cset timerange]
188
$dg node insert $cset
189
$dg node set $cset timerange $tr
190
$dg node set $cset label "[$cset str]\\n[join [struct::list map $tr {::clock format}] "\\n"]"
191
$dg node set $cset __id__ [$cset id]
192
$dg node set $cset shape [expr {[$cset bysymbol]
193
? "ellipse"
194
: "box"}]
195
incr n
196
}
197
198
if {$log} {
199
log write 3 cyclebreaker "Has [nsp [llength $changesets] changeset]"
200
}
201
202
# 2. Find for all relevant changeset their revisions and their
203
# dependencies. Map the latter back to changesets and
204
# construct the corresponding arcs.
205
206
set n 0
207
foreach cset $changesets {
208
log progress 2 cyclebreaker $n $max
209
foreach succ [$cset successors] {
210
# Changesets may have dependencies outside of the
211
# chosen set. These are ignored
212
if {![$dg node exists $succ]} continue
213
$dg arc insert $cset $succ
214
integrity assert {
215
$succ ne $cset
216
} {[$cset reportloop 0]Changeset loop was not detected during creation}
217
}
218
incr n
219
}
220
221
if {$log} {
222
log write 3 cyclebreaker "Has [nsp [llength [$dg arcs]] dependency dependencies]"
223
}
224
225
# Run the user hook to manipulate the graph before
226
# consummation.
227
228
if {$log} { Mark $dg -start }
229
MarkWatch $dg
230
PreHook $dg
231
MarkWatch $dg
232
return $dg
233
}
234
235
# Instead of searching the whole graph for the degree-0 nodes in
236
# each iteration we compute the list once to start, and then only
237
# update it incrementally based on the outgoing neighbours of the
238
# node chosen for commit.
239
240
proc InitializeCandidates {dg} {
241
# bottom = list (list (node, range min, range max))
242
::variable mybottom
243
foreach n [$dg nodes] {
244
if {[$dg node degree -in $n]} continue
245
lappend mybottom [linsert [$dg node get $n timerange] 0 $n]
246
}
247
ScheduleCandidates
248
ShowPendingNodes
249
return
250
}
251
252
proc WithoutPredecessor {dg nv} {
253
::variable mybottom
254
255
upvar 1 $nv n
256
if {![llength $mybottom]} { return 0 }
257
258
set n [lindex [lindex $mybottom 0] 0]
259
set mybottom [lrange $mybottom 1 end]
260
set changed 0
261
262
# Update list of nodes without predecessor, based on the
263
# outgoing neighbours of the chosen node. This should be
264
# faster than iterating of the whole set of nodes, finding all
265
# without predecessors, sorting them by time, etc. pp.
266
foreach out [$dg nodes -out $n] {
267
if {[$dg node degree -in $out] > 1} continue
268
# Degree-1 neighbour, will have no predecessors after the
269
# removal of n. Put on the list.
270
lappend mybottom [linsert [$dg node get $out timerange] 0 $out]
271
set changed 1
272
}
273
if {$changed} {
274
ScheduleCandidates
275
}
276
277
# We do not delete the node immediately, to allow the Save
278
# procedure to save the dependencies as well (encoded in the
279
# arcs).
280
return 1
281
}
282
283
proc ScheduleCandidates {} {
284
::variable mybottom
285
# Sort by cset object name, lower border of timerange, at last
286
# by the upper border.
287
set mybottom [lsort -index 2 -integer [lsort -index 1 -integer [lsort -index 0 -dict $mybottom]]]
288
return
289
}
290
291
proc ShowPendingNodes {} {
292
if {[log verbosity?] < 10} return
293
::variable mybottom
294
log write 10 cyclebreaker "Pending..............................."
295
foreach item [struct::list map $mybottom [myproc FormatPendingItem]] {
296
log write 10 cyclebreaker "Pending: $item"
297
}
298
return
299
}
300
301
proc FormatPendingItem {item} {
302
join [list [[lindex $item 0] str] [clock format [lindex $item 1]] [clock format [lindex $item 2]]]
303
}
304
305
proc FindCycle {dg} {
306
# This procedure is run if and only the graph is not empty and
307
# all nodes have predecessors. This means that each node is
308
# either part of a cycle or (indirectly) depending on a node
309
# in a cycle. We can start at an arbitrary node, follow its
310
# incoming edges to its predecessors until we see a node a
311
# second time. That node closes the cycle and the beginning is
312
# its first occurence. Note that we can choose an arbitrary
313
# predecessor of each node as well, we do not have to search.
314
315
# We record for each node the index of the first appearance in
316
# the path, making it easy at the end to cut the cycle from
317
# it.
318
319
# Choose arbitrary node to start our search at.
320
set start [lindex [$dg nodes] 0]
321
322
# Initialize state, path of seen nodes, and when seen.
323
set path {}
324
array set seen {}
325
326
while {1} {
327
# Stop searching when we have seen the current node
328
# already, the circle has been closed.
329
if {[info exists seen($start)]} break
330
lappend path $start
331
set seen($start) [expr {[llength $path]-1}]
332
# Choose arbitrary predecessor
333
set start [lindex [$dg nodes -in $start] 0]
334
}
335
336
return [struct::list reverse [lrange $path $seen($start) end]]
337
}
338
339
proc BreakSegment {dg path label} {
340
# The path, usually a cycle, we have gotten is broken by
341
# breaking apart one or more of the changesets in the
342
# cycle. This causes us to create one or more changesets which
343
# are to be committed, added to the graph, etc. pp.
344
345
set bestlink {}
346
set bestnode {}
347
348
foreach \
349
prev [lrange $path 0 end-2] \
350
cset [lrange $path 1 end-1] \
351
next [lrange $path 2 end] {
352
353
# Each triple PREV -> CSET -> NEXT of changesets, a
354
# 'link' in the cycle, is analysed and the best
355
# location where to at least weaken the cycle is
356
# chosen for further processing.
357
358
set link [project::revlink %AUTO% $prev $cset $next]
359
if {$bestlink eq ""} {
360
set bestlink $link
361
set bestnode $cset
362
} elseif {[$link betterthan $bestlink]} {
363
$bestlink destroy
364
set bestlink $link
365
set bestnode $cset
366
} else {
367
$link destroy
368
}
369
}
370
371
log write 5 cyclebreaker "Breaking $label by splitting changeset [$bestnode str]"
372
set ID [$bestnode id]
373
Mark $dg -${ID}-before
374
375
set newcsets [$bestlink break]
376
$bestlink destroy
377
378
# At this point the old changeset (BESTNODE) is gone
379
# already. We remove it from the graph as well and then enter
380
# the fragments generated for it.
381
382
Replace $dg $bestnode $newcsets
383
384
Mark $dg -${ID}-after
385
return
386
}
387
388
# TODO: This should be a graph method.
389
proc HasArc {dg a b} {
390
#8.5: return [expr {$b in [$dg nodes -out $a]}]
391
if {[lsearch -exact [$dg nodes -out $a] $b] < 0} { return 0 }
392
return 1
393
}
394
395
proc Mark {dg {suffix {}} {subgraph {}}} {
396
::variable mydotdestination
397
if {$mydotdestination eq ""} return
398
::variable mydotprefix
399
::variable mydotid
400
set fname $mydotdestination/${mydotprefix}${mydotid}${suffix}.dot
401
file mkdir [file dirname $fname]
402
dot write $dg $mydotprefix$suffix $fname $subgraph
403
incr mydotid
404
405
log write 5 cyclebreaker ".dot export $fname"
406
return
407
}
408
409
proc Replace {dg n replacements} {
410
# NOTE. We have to get the list of incoming neighbours and
411
# recompute their successors after the new nodes have been
412
# inserted. Their outgoing arcs will now go to one or both of
413
# the new nodes, and not redoing them may cause us to forget
414
# circles, leaving them in, unbroken.
415
416
set pre [$dg nodes -in $n]
417
418
$dg node delete $n
419
420
foreach cset $replacements {
421
set tr [$cset timerange]
422
$dg node insert $cset
423
$dg node set $cset timerange $tr
424
$dg node set $cset label "[$cset str]\\n[join [struct::list map $tr {::clock format}] "\\n"]"
425
$dg node set $cset __id__ [$cset id]
426
$dg node set $cset shape [expr {[$cset bysymbol]
427
? "ellipse"
428
: "box"}]
429
}
430
431
foreach cset $replacements {
432
foreach succ [$cset successors] {
433
# The new changesets may have dependencies outside of
434
# the chosen set. These are ignored
435
if {![$dg node exists $succ]} continue
436
$dg arc insert $cset $succ
437
integrity assert {
438
$succ ne $cset
439
} {[$cset reportloop 0]Changeset loop was not detected during creation}
440
}
441
}
442
foreach cset $pre {
443
foreach succ [$cset successors] {
444
# Note that the arc may already exist in the graph. If
445
# so ignore it. The new changesets may have
446
# dependencies outside of the chosen set. These are
447
# ignored
448
if {![$dg node exists $succ]} continue
449
if {[HasArc $dg $cset $succ]} continue;# TODO should be graph method.
450
$dg arc insert $cset $succ
451
}
452
}
453
454
return
455
}
456
457
# # ## ### ##### ######## #############
458
## Callback invokation ...
459
460
proc PreHook {graph} {
461
# Give the user of the cycle breaker the opportunity to work
462
# with the graph between setup and consummation.
463
464
::variable myprecmd
465
if {![llength $myprecmd]} return
466
467
uplevel #0 [linsert $myprecmd end $graph]
468
Mark $graph -pre-done
469
return
470
}
471
472
proc ProcessedHook {dg cset pos} {
473
# Give the user of the cycle breaker the opportunity to work
474
# with the changeset before it is removed from the graph.
475
476
::variable mysavecmd
477
if {![llength $mysavecmd]} return
478
479
uplevel #0 [linsert $mysavecmd end $dg $pos $cset]
480
return
481
}
482
483
proc BreakCycleHook {graph} {
484
# Call out to the chosen algorithm for cycle breaking. Finding
485
# a cycle if no breaker was chosen is an error.
486
487
::variable mybreakcmd
488
if {![llength $mybreakcmd]} {
489
trouble fatal "Found a cycle, expecting none."
490
exit 1
491
}
492
493
uplevel #0 [linsert $mybreakcmd end $graph]
494
return
495
}
496
497
proc ClearHooks {} {
498
::variable myprecmd {}
499
::variable mysavecmd {}
500
::variable mybreakcmd {}
501
return
502
}
503
504
# # ## ### ##### ######## #############
505
506
proc MarkWatch {graph} {
507
::variable mywatchids
508
set watched [Watched $graph $mywatchids]
509
if {![llength $watched]} return
510
set neighbours [eval [linsert $watched 0 $graph nodes -adj]]
511
#foreach n $neighbours { log write 6 cyclebreaker "Neighbor [$n id] => $n" }
512
Mark $graph watched [concat $watched $neighbours]
513
return
514
}
515
516
proc Watched {graph watchids} {
517
set res {}
518
foreach id $watchids {
519
set nl [$graph nodes -key __id__ -value $id]
520
if {![llength $nl]} continue
521
lappend res $nl
522
#log write 6 breakrcycle "Watching $id => $nl"
523
$graph node set $nl fontcolor red
524
}
525
return $res
526
}
527
528
# # ## ### ##### ######## #############
529
530
531
typevariable myat 0 ; # Counter for commit ids for the
532
# changesets.
533
typevariable mybottom {} ; # List of the candidate nodes for
534
# committing.
535
536
typevariable myprecmd {} ; # Callback, change graph before walk.
537
typevariable mysavecmd {} ; # Callback, for each processed node.
538
typevariable mybreakcmd {} ; # Callback, for each found cycle.
539
540
typevariable mydotdestination {} ; # Destination directory for the
541
# generated .dot files.
542
typevariable mydotprefix {} ; # Prefix for dot files when
543
# exporting the graphs.
544
typevariable mydotid 0 ; # Counter for dot file name
545
# generation.
546
typevariable mywatchids {} ; # Changesets to watch the
547
# neighbourhood of.
548
549
# # ## ### ##### ######## #############
550
## Configuration
551
552
pragma -hasinstances no ; # singleton
553
pragma -hastypeinfo no ; # no introspection
554
pragma -hastypedestroy no ; # immortal
555
556
# # ## ### ##### ######## #############
557
}
558
559
namespace eval ::vc::fossil::import::cvs {
560
namespace export cyclebreaker
561
namespace eval cyclebreaker {
562
namespace import ::vc::fossil::import::cvs::integrity
563
namespace eval project {
564
namespace import ::vc::fossil::import::cvs::project::rev
565
namespace import ::vc::fossil::import::cvs::project::revlink
566
}
567
namespace import ::vc::tools::misc::*
568
namespace import ::vc::tools::log
569
namespace import ::vc::tools::trouble
570
namespace import ::vc::tools::dot
571
log register cyclebreaker
572
}
573
}
574
575
# # ## ### ##### ######## ############# #####################
576
## Ready
577
578
package provide vc::fossil::import::cvs::cyclebreaker 1.0
579
return
580

Keyboard Shortcuts

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