770a9b576a 2007-11-16 aku: ## -*- tcl -*- 770a9b576a 2007-11-16 aku: # # ## ### ##### ######## ############# ##################### 770a9b576a 2007-11-16 aku: ## Copyright (c) 2007 Andreas Kupries. 770a9b576a 2007-11-16 aku: # 770a9b576a 2007-11-16 aku: # This software is licensed as described in the file LICENSE, which 770a9b576a 2007-11-16 aku: # you should have received as part of this distribution. 770a9b576a 2007-11-16 aku: # 770a9b576a 2007-11-16 aku: # This software consists of voluntary contributions made by many 770a9b576a 2007-11-16 aku: # individuals. For exact contribution history, see the revision 770a9b576a 2007-11-16 aku: # history and logs, available at http://fossil-scm.hwaci.com/fossil 770a9b576a 2007-11-16 aku: # # ## ### ##### ######## ############# ##################### 770a9b576a 2007-11-16 aku: 770a9b576a 2007-11-16 aku: ## This file provides a helper package for the passes 6 and 7 which 770a9b576a 2007-11-16 aku: ## contains the common code of the cycle breaking algorithm. 770a9b576a 2007-11-16 aku: 770a9b576a 2007-11-16 aku: # # ## ### ##### ######## ############# ##################### 770a9b576a 2007-11-16 aku: ## Requirements 770a9b576a 2007-11-16 aku: 770a9b576a 2007-11-16 aku: package require Tcl 8.4 ; # Required runtime. 770a9b576a 2007-11-16 aku: package require snit ; # OO system. 770a9b576a 2007-11-16 aku: package require struct::graph ; # Graph handling. 770a9b576a 2007-11-16 aku: package require struct::list ; # Higher order list operations. 7f15be9078 2007-11-20 aku: package require vc::tools::dot ; # User feedback. DOT export. 770a9b576a 2007-11-16 aku: package require vc::tools::log ; # User feedback. 2cf0462b82 2007-11-21 aku: package require vc::tools::trouble ; # Error reporting. 770a9b576a 2007-11-16 aku: package require vc::tools::misc ; # Text formatting. 770a9b576a 2007-11-16 aku: package require vc::fossil::import::cvs::project::rev ; # Project level changesets 770a9b576a 2007-11-16 aku: package require vc::fossil::import::cvs::project::revlink ; # Cycle links. 770a9b576a 2007-11-16 aku: 770a9b576a 2007-11-16 aku: # # ## ### ##### ######## ############# ##################### 770a9b576a 2007-11-16 aku: ## 770a9b576a 2007-11-16 aku: 770a9b576a 2007-11-16 aku: snit::type ::vc::fossil::import::cvs::cyclebreaker { 770a9b576a 2007-11-16 aku: # # ## ### ##### ######## ############# 770a9b576a 2007-11-16 aku: ## Public API 770a9b576a 2007-11-16 aku: 1e177a4c91 2007-11-21 aku: typemethod precmd {cmd} { 1e177a4c91 2007-11-21 aku: ::variable myprecmd $cmd 1e177a4c91 2007-11-21 aku: return 1e177a4c91 2007-11-21 aku: } 1e177a4c91 2007-11-21 aku: d58423cdc4 2007-11-21 aku: typemethod savecmd {cmd} { d58423cdc4 2007-11-21 aku: ::variable mysavecmd $cmd d58423cdc4 2007-11-21 aku: return d58423cdc4 2007-11-21 aku: } d58423cdc4 2007-11-21 aku: 2cf0462b82 2007-11-21 aku: typemethod breakcmd {cmd} { 2cf0462b82 2007-11-21 aku: ::variable mybreakcmd $cmd 2cf0462b82 2007-11-21 aku: return 2cf0462b82 2007-11-21 aku: } 2cf0462b82 2007-11-21 aku: 2cf0462b82 2007-11-21 aku: # # ## ### ##### ######## ############# 2cf0462b82 2007-11-21 aku: 7f15be9078 2007-11-20 aku: typemethod dotsto {path} { 7f15be9078 2007-11-20 aku: ::variable mydotdestination $path 7f15be9078 2007-11-20 aku: return 2cf0462b82 2007-11-21 aku: } 2cf0462b82 2007-11-21 aku: 97b4405ecf 2007-11-25 aku: typemethod watch {id} { 97b4405ecf 2007-11-25 aku: ::variable mywatchids 97b4405ecf 2007-11-25 aku: lappend mywatchids $id 7f15be9078 2007-11-20 aku: } 7f15be9078 2007-11-20 aku: 7f15be9078 2007-11-20 aku: typemethod dot {label changesets} { 7f15be9078 2007-11-20 aku: ::variable mydotprefix $label 7f15be9078 2007-11-20 aku: ::variable mydotid 0 7f15be9078 2007-11-20 aku: 7f15be9078 2007-11-20 aku: set dg [Setup $changesets 0] 7f15be9078 2007-11-20 aku: Mark $dg 7f15be9078 2007-11-20 aku: $dg destroy 7f15be9078 2007-11-20 aku: return 7f15be9078 2007-11-20 aku: } 7f15be9078 2007-11-20 aku: 5f5620fbd2 2007-11-23 aku: typemethod mark {graph suffix {subgraph {}}} { 5f5620fbd2 2007-11-23 aku: Mark $graph $suffix $subgraph 2a0ec504c5 2007-11-21 aku: return 2a0ec504c5 2007-11-21 aku: } 2a0ec504c5 2007-11-21 aku: 2cf0462b82 2007-11-21 aku: # # ## ### ##### ######## ############# 2cf0462b82 2007-11-21 aku: 2a0ec504c5 2007-11-21 aku: typemethod run {label changesetcmd} { 7f15be9078 2007-11-20 aku: ::variable myat 0 7f15be9078 2007-11-20 aku: ::variable mydotprefix $label 7f15be9078 2007-11-20 aku: ::variable mydotid 0 770a9b576a 2007-11-16 aku: 770a9b576a 2007-11-16 aku: # We create a graph of the revision changesets, using the file 770a9b576a 2007-11-16 aku: # level dependencies to construct a first approximation of the 770a9b576a 2007-11-16 aku: # dependencies at the project level. Then we look for cycles 770a9b576a 2007-11-16 aku: # in that graph and break them. 770a9b576a 2007-11-16 aku: 770a9b576a 2007-11-16 aku: # 1. Create nodes for all relevant changesets and a mapping 770a9b576a 2007-11-16 aku: # from the revisions to their changesets/nodes. 770a9b576a 2007-11-16 aku: 2a0ec504c5 2007-11-21 aku: set changesets [uplevel #0 $changesetcmd] 7f15be9078 2007-11-20 aku: set dg [Setup $changesets] 770a9b576a 2007-11-16 aku: 770a9b576a 2007-11-16 aku: # 3. Lastly we iterate the graph topologically. We mark off 770a9b576a 2007-11-16 aku: # the nodes which have no predecessors, in order from 770a9b576a 2007-11-16 aku: # oldest to youngest, saving and removing dependencies. If 770a9b576a 2007-11-16 aku: # we find no nodes without predecessors we have a cycle, 770a9b576a 2007-11-16 aku: # and work on breaking it. 770a9b576a 2007-11-16 aku: 54e9b0a143 2007-11-25 aku: log write 3 cyclebreaker {Traverse changesets} 770a9b576a 2007-11-16 aku: 770a9b576a 2007-11-16 aku: InitializeCandidates $dg 770a9b576a 2007-11-16 aku: while {1} { 770a9b576a 2007-11-16 aku: while {[WithoutPredecessor $dg n]} { 97b4405ecf 2007-11-25 aku: MarkWatch $dg 5f5620fbd2 2007-11-23 aku: ProcessedHook $dg $n $myat 2cf0462b82 2007-11-21 aku: $dg node delete $n 2cf0462b82 2007-11-21 aku: incr myat ad7d5c2d10 2007-11-22 aku: ShowPendingNodes 770a9b576a 2007-11-16 aku: } 2cf0462b82 2007-11-21 aku: 770a9b576a 2007-11-16 aku: if {![llength [dg nodes]]} break 2cf0462b82 2007-11-21 aku: 2cf0462b82 2007-11-21 aku: BreakCycleHook $dg 770a9b576a 2007-11-16 aku: InitializeCandidates $dg 97b4405ecf 2007-11-25 aku: MarkWatch $dg 2a0ec504c5 2007-11-21 aku: } 2a0ec504c5 2007-11-21 aku: 2a0ec504c5 2007-11-21 aku: $dg destroy 770a9b576a 2007-11-16 aku: 770a9b576a 2007-11-16 aku: log write 3 cyclebreaker Done. d58423cdc4 2007-11-21 aku: ClearHooks 2a0ec504c5 2007-11-21 aku: 2a0ec504c5 2007-11-21 aku: # Reread the graph and dump its final form, if graph export 2a0ec504c5 2007-11-21 aku: # was activated. 2a0ec504c5 2007-11-21 aku: 2a0ec504c5 2007-11-21 aku: ::variable mydotdestination 2a0ec504c5 2007-11-21 aku: if {$mydotdestination eq ""} return 2a0ec504c5 2007-11-21 aku: 2a0ec504c5 2007-11-21 aku: set dg [Setup [uplevel #0 $changesetcmd] 0] 2a0ec504c5 2007-11-21 aku: Mark $dg -done 2a0ec504c5 2007-11-21 aku: $dg destroy 2cf0462b82 2007-11-21 aku: return 2cf0462b82 2007-11-21 aku: } 2cf0462b82 2007-11-21 aku: 2cf0462b82 2007-11-21 aku: # # ## ### ##### ######## ############# 2cf0462b82 2007-11-21 aku: 54e9b0a143 2007-11-25 aku: typemethod break-segment {graph} { 54e9b0a143 2007-11-25 aku: BreakSegment $graph $path "segment ([project::rev strlist $path])" 54e9b0a143 2007-11-25 aku: return 54e9b0a143 2007-11-25 aku: } 54e9b0a143 2007-11-25 aku: 2cf0462b82 2007-11-21 aku: typemethod break {graph} { 54e9b0a143 2007-11-25 aku: set cycle [FindCycle $graph] 54e9b0a143 2007-11-25 aku: set label "cycle ([project::rev strlist $cycle])" 54e9b0a143 2007-11-25 aku: 54e9b0a143 2007-11-25 aku: # NOTE: cvs2svn uses the sequence "end-1, cycle, 0" to create 54e9b0a143 2007-11-25 aku: # the path from the cycle. The only effect I can see is 54e9b0a143 2007-11-25 aku: # that this causes the link-triples to be generated in a 54e9b0a143 2007-11-25 aku: # sightly different order, i.e. one link rotated to the 54e9b0a143 2007-11-25 aku: # right. This should have no effect on the search for 54e9b0a143 2007-11-25 aku: # the best of all. 54e9b0a143 2007-11-25 aku: 54e9b0a143 2007-11-25 aku: lappend cycle [lindex $cycle 0] [lindex $cycle 1] 54e9b0a143 2007-11-25 aku: BreakSegment $graph $cycle $label ad7d5c2d10 2007-11-22 aku: return ad7d5c2d10 2007-11-22 aku: } ad7d5c2d10 2007-11-22 aku: ad7d5c2d10 2007-11-22 aku: typemethod replace {graph n replacements} { ad7d5c2d10 2007-11-22 aku: Replace $graph $n $replacements 770a9b576a 2007-11-16 aku: return 770a9b576a 2007-11-16 aku: } 770a9b576a 2007-11-16 aku: 770a9b576a 2007-11-16 aku: # # ## ### ##### ######## ############# 770a9b576a 2007-11-16 aku: ## Internal methods 770a9b576a 2007-11-16 aku: 7f15be9078 2007-11-20 aku: proc Setup {changesets {log 1}} { 7f15be9078 2007-11-20 aku: if {$log} { 97b4405ecf 2007-11-25 aku: log write 3 cyclebreaker "Creating graph of changesets" 7f15be9078 2007-11-20 aku: } 7f15be9078 2007-11-20 aku: 7f15be9078 2007-11-20 aku: set dg [struct::graph dg] 7f15be9078 2007-11-20 aku: 7f15be9078 2007-11-20 aku: foreach cset $changesets { 97b4405ecf 2007-11-25 aku: set tr [$cset timerange] 7f15be9078 2007-11-20 aku: $dg node insert $cset 97b4405ecf 2007-11-25 aku: $dg node set $cset timerange $tr 97b4405ecf 2007-11-25 aku: $dg node set $cset label "[$cset str]\\n[join [struct::list map $tr {::clock format}] "\\n"]" a99d5798f6 2007-11-24 aku: $dg node set $cset __id__ [$cset id] 97b4405ecf 2007-11-25 aku: $dg node set $cset shape [expr {[$cset bysymbol] 97b4405ecf 2007-11-25 aku: ? "ellipse" 97b4405ecf 2007-11-25 aku: : "box"}] 97b4405ecf 2007-11-25 aku: } 97b4405ecf 2007-11-25 aku: 97b4405ecf 2007-11-25 aku: if {$log} { 97b4405ecf 2007-11-25 aku: log write 3 cyclebreaker "Has [nsp [llength $changesets] changeset]" 7f15be9078 2007-11-20 aku: } 7f15be9078 2007-11-20 aku: 7f15be9078 2007-11-20 aku: # 2. Find for all relevant changeset their revisions and their 7f15be9078 2007-11-20 aku: # dependencies. Map the latter back to changesets and 7f15be9078 2007-11-20 aku: # construct the corresponding arcs. 7f15be9078 2007-11-20 aku: 7f15be9078 2007-11-20 aku: foreach cset $changesets { 7f15be9078 2007-11-20 aku: foreach succ [$cset successors] { 7f15be9078 2007-11-20 aku: # Changesets may have dependencies outside of the 7f15be9078 2007-11-20 aku: # chosen set. These are ignored 7f15be9078 2007-11-20 aku: if {![$dg node exists $succ]} continue 7f15be9078 2007-11-20 aku: $dg arc insert $cset $succ eabaea870a 2007-11-24 aku: eabaea870a 2007-11-24 aku: # Check for changesets referencing themselves. Such a eabaea870a 2007-11-24 aku: # loop shows that the changeset in question has eabaea870a 2007-11-24 aku: # internal dependencies. Something which is supposed eabaea870a 2007-11-24 aku: # to be not possible, as pass 5 (InitCsets) takes care eabaea870a 2007-11-24 aku: # to transform internal into external dependencies by eabaea870a 2007-11-24 aku: # breaking the relevant changesets apart. So having eabaea870a 2007-11-24 aku: # one indicates big trouble in pass 5. We report them eabaea870a 2007-11-24 aku: # and dump internal structures to make it easier to eabaea870a 2007-11-24 aku: # trace the links causing the problem. eabaea870a 2007-11-24 aku: if {$succ eq $cset} { 87cf609021 2007-11-24 aku: trouble fatal "Self-referencing changeset [$cset str]" 87cf609021 2007-11-24 aku: log write 2 cyclebreaker "LOOP changeset [$cset str] __________________" eabaea870a 2007-11-24 aku: array set nmap [$cset nextmap] eabaea870a 2007-11-24 aku: foreach r [lsort -dict [array names nmap]] { eabaea870a 2007-11-24 aku: foreach succrev $nmap($r) { eabaea870a 2007-11-24 aku: log write 2 cyclebreaker \ 87cf609021 2007-11-24 aku: "LOOP * rev <$r> --> rev <$succrev> --> cs [project::rev strlist [project::rev ofrev $succrev]]" eabaea870a 2007-11-24 aku: } eabaea870a 2007-11-24 aku: } eabaea870a 2007-11-24 aku: } 7f15be9078 2007-11-20 aku: } 7f15be9078 2007-11-20 aku: } 7f15be9078 2007-11-20 aku: 97b4405ecf 2007-11-25 aku: if {$log} { 97b4405ecf 2007-11-25 aku: log write 3 cyclebreaker "Has [nsp [llength [$dg arcs]] dependency dependencies]" 1e177a4c91 2007-11-21 aku: } 1e177a4c91 2007-11-21 aku: 1e177a4c91 2007-11-21 aku: # Run the user hook to manipulate the graph before 1e177a4c91 2007-11-21 aku: # consummation. 1e177a4c91 2007-11-21 aku: 2a0ec504c5 2007-11-21 aku: if {$log} { Mark $dg -start } 97b4405ecf 2007-11-25 aku: MarkWatch $dg 97b4405ecf 2007-11-25 aku: PreHook $dg 97b4405ecf 2007-11-25 aku: MarkWatch $dg eabaea870a 2007-11-24 aku: eabaea870a 2007-11-24 aku: # This kills the application if loops (see above) were found. eabaea870a 2007-11-24 aku: trouble abort? 2a0ec504c5 2007-11-21 aku: return $dg 7f15be9078 2007-11-20 aku: } 7f15be9078 2007-11-20 aku: 770a9b576a 2007-11-16 aku: # Instead of searching the whole graph for the degree-0 nodes in 770a9b576a 2007-11-16 aku: # each iteration we compute the list once to start, and then only 770a9b576a 2007-11-16 aku: # update it incrementally based on the outgoing neighbours of the 770a9b576a 2007-11-16 aku: # node chosen for commit. 770a9b576a 2007-11-16 aku: 770a9b576a 2007-11-16 aku: proc InitializeCandidates {dg} { 770a9b576a 2007-11-16 aku: # bottom = list (list (node, range min, range max)) 7f15be9078 2007-11-20 aku: ::variable mybottom 770a9b576a 2007-11-16 aku: foreach n [$dg nodes] { 770a9b576a 2007-11-16 aku: if {[$dg node degree -in $n]} continue 7f15be9078 2007-11-20 aku: lappend mybottom [linsert [$dg node get $n timerange] 0 $n] 770a9b576a 2007-11-16 aku: } 7f15be9078 2007-11-20 aku: set mybottom [lsort -index 1 -integer [lsort -index 2 -integer $mybottom]] ad7d5c2d10 2007-11-22 aku: ShowPendingNodes 770a9b576a 2007-11-16 aku: return 770a9b576a 2007-11-16 aku: } 770a9b576a 2007-11-16 aku: 770a9b576a 2007-11-16 aku: proc WithoutPredecessor {dg nv} { 7f15be9078 2007-11-20 aku: ::variable mybottom 770a9b576a 2007-11-16 aku: 770a9b576a 2007-11-16 aku: upvar 1 $nv n 7f15be9078 2007-11-20 aku: if {![llength $mybottom]} { return 0 } 7f15be9078 2007-11-20 aku: 7f15be9078 2007-11-20 aku: set n [lindex [lindex $mybottom 0] 0] 7f15be9078 2007-11-20 aku: set mybottom [lrange $mybottom 1 end] 770a9b576a 2007-11-16 aku: set changed 0 770a9b576a 2007-11-16 aku: 770a9b576a 2007-11-16 aku: # Update list of nodes without predecessor, based on the 770a9b576a 2007-11-16 aku: # outgoing neighbours of the chosen node. This should be 770a9b576a 2007-11-16 aku: # faster than iterating of the whole set of nodes, finding all 770a9b576a 2007-11-16 aku: # without predecessors, sorting them by time, etc. pp. 770a9b576a 2007-11-16 aku: foreach out [$dg nodes -out $n] { 770a9b576a 2007-11-16 aku: if {[$dg node degree -in $out] > 1} continue 770a9b576a 2007-11-16 aku: # Degree-1 neighbour, will have no predecessors after the 770a9b576a 2007-11-16 aku: # removal of n. Put on the list. 7f15be9078 2007-11-20 aku: lappend mybottom [linsert [$dg node get $out timerange] 0 $out] 770a9b576a 2007-11-16 aku: set changed 1 770a9b576a 2007-11-16 aku: } 770a9b576a 2007-11-16 aku: if {$changed} { 7f15be9078 2007-11-20 aku: set mybottom [lsort -index 1 -integer [lsort -index 2 -integer $mybottom]] 770a9b576a 2007-11-16 aku: } 770a9b576a 2007-11-16 aku: 770a9b576a 2007-11-16 aku: # We do not delete the node immediately, to allow the Save 770a9b576a 2007-11-16 aku: # procedure to save the dependencies as well (encoded in the 770a9b576a 2007-11-16 aku: # arcs). 770a9b576a 2007-11-16 aku: return 1 770a9b576a 2007-11-16 aku: } 770a9b576a 2007-11-16 aku: ad7d5c2d10 2007-11-22 aku: proc ShowPendingNodes {} { ad7d5c2d10 2007-11-22 aku: if {[log verbosity?] < 10} return ad7d5c2d10 2007-11-22 aku: ::variable mybottom ad7d5c2d10 2007-11-22 aku: log write 10 cyclebreaker \ ad7d5c2d10 2007-11-22 aku: "Pending: [struct::list map $mybottom [myproc FormatPendingItem]]" 770a9b576a 2007-11-16 aku: return 770a9b576a 2007-11-16 aku: } ad7d5c2d10 2007-11-22 aku: 87cf609021 2007-11-24 aku: proc FormatPendingItem {item} { lreplace $item 0 0 [[lindex $item 0] str] } 770a9b576a 2007-11-16 aku: 770a9b576a 2007-11-16 aku: proc FindCycle {dg} { 770a9b576a 2007-11-16 aku: # This procedure is run if and only the graph is not empty and 770a9b576a 2007-11-16 aku: # all nodes have predecessors. This means that each node is 770a9b576a 2007-11-16 aku: # either part of a cycle or (indirectly) depending on a node 770a9b576a 2007-11-16 aku: # in a cycle. We can start at an arbitrary node, follow its 770a9b576a 2007-11-16 aku: # incoming edges to its predecessors until we see a node a 770a9b576a 2007-11-16 aku: # second time. That node closes the cycle and the beginning is 770a9b576a 2007-11-16 aku: # its first occurence. Note that we can choose an arbitrary 770a9b576a 2007-11-16 aku: # predecessor of each node as well, we do not have to search. 770a9b576a 2007-11-16 aku: 770a9b576a 2007-11-16 aku: # We record for each node the index of the first appearance in 770a9b576a 2007-11-16 aku: # the path, making it easy at the end to cut the cycle from 770a9b576a 2007-11-16 aku: # it. 770a9b576a 2007-11-16 aku: 770a9b576a 2007-11-16 aku: # Choose arbitrary node to start our search at. 770a9b576a 2007-11-16 aku: set start [lindex [$dg nodes] 0] 770a9b576a 2007-11-16 aku: 770a9b576a 2007-11-16 aku: # Initialize state, path of seen nodes, and when seen. 770a9b576a 2007-11-16 aku: set path {} 770a9b576a 2007-11-16 aku: array set seen {} 770a9b576a 2007-11-16 aku: 770a9b576a 2007-11-16 aku: while {1} { 770a9b576a 2007-11-16 aku: # Stop searching when we have seen the current node 770a9b576a 2007-11-16 aku: # already, the circle has been closed. 770a9b576a 2007-11-16 aku: if {[info exists seen($start)]} break 770a9b576a 2007-11-16 aku: lappend path $start 770a9b576a 2007-11-16 aku: set seen($start) [expr {[llength $path]-1}] 770a9b576a 2007-11-16 aku: # Choose arbitrary predecessor 770a9b576a 2007-11-16 aku: set start [lindex [$dg nodes -in $start] 0] 770a9b576a 2007-11-16 aku: } 770a9b576a 2007-11-16 aku: 770a9b576a 2007-11-16 aku: return [struct::list reverse [lrange $path $seen($start) end]] 770a9b576a 2007-11-16 aku: } 770a9b576a 2007-11-16 aku: 54e9b0a143 2007-11-25 aku: proc BreakSegment {dg path label} { 54e9b0a143 2007-11-25 aku: # The path, usually a cycle, we have gotten is broken by 54e9b0a143 2007-11-25 aku: # breaking apart one or more of the changesets in the 54e9b0a143 2007-11-25 aku: # cycle. This causes us to create one or more changesets which 54e9b0a143 2007-11-25 aku: # are to be committed, added to the graph, etc. pp. 54e9b0a143 2007-11-25 aku: 770a9b576a 2007-11-16 aku: set bestlink {} 770a9b576a 2007-11-16 aku: set bestnode {} 770a9b576a 2007-11-16 aku: 770a9b576a 2007-11-16 aku: foreach \ 54e9b0a143 2007-11-25 aku: prev [lrange $path 0 end-2] \ 54e9b0a143 2007-11-25 aku: cset [lrange $path 1 end-1] \ 54e9b0a143 2007-11-25 aku: next [lrange $path 2 end] { 770a9b576a 2007-11-16 aku: 770a9b576a 2007-11-16 aku: # Each triple PREV -> CSET -> NEXT of changesets, a 770a9b576a 2007-11-16 aku: # 'link' in the cycle, is analysed and the best 770a9b576a 2007-11-16 aku: # location where to at least weaken the cycle is 770a9b576a 2007-11-16 aku: # chosen for further processing. 770a9b576a 2007-11-16 aku: 770a9b576a 2007-11-16 aku: set link [project::revlink %AUTO% $prev $cset $next] 770a9b576a 2007-11-16 aku: if {$bestlink eq ""} { 770a9b576a 2007-11-16 aku: set bestlink $link 770a9b576a 2007-11-16 aku: set bestnode $cset 770a9b576a 2007-11-16 aku: } elseif {[$link betterthan $bestlink]} { 770a9b576a 2007-11-16 aku: $bestlink destroy 770a9b576a 2007-11-16 aku: set bestlink $link 770a9b576a 2007-11-16 aku: set bestnode $cset 770a9b576a 2007-11-16 aku: } else { 770a9b576a 2007-11-16 aku: $link destroy 770a9b576a 2007-11-16 aku: } 770a9b576a 2007-11-16 aku: } 770a9b576a 2007-11-16 aku: 54e9b0a143 2007-11-25 aku: log write 5 cyclebreaker "Breaking $label by splitting changeset [$bestnode str]" 7f15be9078 2007-11-20 aku: set ID [$bestnode id] 7f15be9078 2007-11-20 aku: Mark $dg -${ID}-before 770a9b576a 2007-11-16 aku: 770a9b576a 2007-11-16 aku: set newcsets [$bestlink break] 770a9b576a 2007-11-16 aku: $bestlink destroy 770a9b576a 2007-11-16 aku: 770a9b576a 2007-11-16 aku: # At this point the old changeset (BESTNODE) is gone 770a9b576a 2007-11-16 aku: # already. We remove it from the graph as well and then enter 770a9b576a 2007-11-16 aku: # the fragments generated for it. 770a9b576a 2007-11-16 aku: ad7d5c2d10 2007-11-22 aku: Replace $dg $bestnode $newcsets ad7d5c2d10 2007-11-22 aku: ad7d5c2d10 2007-11-22 aku: Mark $dg -${ID}-after ad7d5c2d10 2007-11-22 aku: return ad7d5c2d10 2007-11-22 aku: } ad7d5c2d10 2007-11-22 aku: ad7d5c2d10 2007-11-22 aku: # TODO: This should be a graph method. ad7d5c2d10 2007-11-22 aku: proc HasArc {dg a b} { ad7d5c2d10 2007-11-22 aku: #8.5: return [expr {$b in [$dg nodes -out $a]}] ad7d5c2d10 2007-11-22 aku: if {[lsearch -exact [$dg nodes -out $a] $b] < 0} { return 0 } ad7d5c2d10 2007-11-22 aku: return 1 ad7d5c2d10 2007-11-22 aku: } ad7d5c2d10 2007-11-22 aku: 5f5620fbd2 2007-11-23 aku: proc Mark {dg {suffix {}} {subgraph {}}} { ad7d5c2d10 2007-11-22 aku: ::variable mydotdestination ad7d5c2d10 2007-11-22 aku: if {$mydotdestination eq ""} return ad7d5c2d10 2007-11-22 aku: ::variable mydotprefix ad7d5c2d10 2007-11-22 aku: ::variable mydotid ad7d5c2d10 2007-11-22 aku: set fname $mydotdestination/${mydotprefix}${mydotid}${suffix}.dot ad7d5c2d10 2007-11-22 aku: file mkdir [file dirname $fname] 5f5620fbd2 2007-11-23 aku: dot write $dg $mydotprefix$suffix $fname $subgraph ad7d5c2d10 2007-11-22 aku: incr mydotid ad7d5c2d10 2007-11-22 aku: ad7d5c2d10 2007-11-22 aku: log write 5 cyclebreaker ".dot export $fname" ad7d5c2d10 2007-11-22 aku: return ad7d5c2d10 2007-11-22 aku: } ad7d5c2d10 2007-11-22 aku: ad7d5c2d10 2007-11-22 aku: proc Replace {dg n replacements} { 7f15be9078 2007-11-20 aku: # NOTE. We have to get the list of incoming neighbours and 7f15be9078 2007-11-20 aku: # recompute their successors after the new nodes have been 7f15be9078 2007-11-20 aku: # inserted. Their outgoing arcs will now go to one or both of 7f15be9078 2007-11-20 aku: # the new nodes, and not redoing them may cause us to forget 7f15be9078 2007-11-20 aku: # circles, leaving them in, unbroken. 7f15be9078 2007-11-20 aku: ad7d5c2d10 2007-11-22 aku: set pre [$dg nodes -in $n] ad7d5c2d10 2007-11-22 aku: ad7d5c2d10 2007-11-22 aku: $dg node delete $n ad7d5c2d10 2007-11-22 aku: ad7d5c2d10 2007-11-22 aku: foreach cset $replacements { 97b4405ecf 2007-11-25 aku: set tr [$cset timerange] 770a9b576a 2007-11-16 aku: $dg node insert $cset 97b4405ecf 2007-11-25 aku: $dg node set $cset timerange $tr 97b4405ecf 2007-11-25 aku: $dg node set $cset label "[$cset str]\\n[join [struct::list map $tr {::clock format}] "\\n"]" a99d5798f6 2007-11-24 aku: $dg node set $cset __id__ [$cset id] 97b4405ecf 2007-11-25 aku: $dg node set $cset shape [expr {[$cset bysymbol] 97b4405ecf 2007-11-25 aku: ? "ellipse" 97b4405ecf 2007-11-25 aku: : "box"}] 770a9b576a 2007-11-16 aku: } 770a9b576a 2007-11-16 aku: ad7d5c2d10 2007-11-22 aku: foreach cset $replacements { 770a9b576a 2007-11-16 aku: foreach succ [$cset successors] { 770a9b576a 2007-11-16 aku: # The new changesets may have dependencies outside of 770a9b576a 2007-11-16 aku: # the chosen set. These are ignored 770a9b576a 2007-11-16 aku: if {![$dg node exists $succ]} continue 770a9b576a 2007-11-16 aku: $dg arc insert $cset $succ eabaea870a 2007-11-24 aku: if {$succ eq $cset} { 87cf609021 2007-11-24 aku: trouble internal "Self-referencing changeset [$cset str]" eabaea870a 2007-11-24 aku: } 7f15be9078 2007-11-20 aku: } 7f15be9078 2007-11-20 aku: } 7f15be9078 2007-11-20 aku: foreach cset $pre { 7f15be9078 2007-11-20 aku: foreach succ [$cset successors] { 7f15be9078 2007-11-20 aku: # Note that the arc may already exist in the graph. If 7f15be9078 2007-11-20 aku: # so ignore it. The new changesets may have 7f15be9078 2007-11-20 aku: # dependencies outside of the chosen set. These are 7f15be9078 2007-11-20 aku: # ignored 7f15be9078 2007-11-20 aku: if {![$dg node exists $succ]} continue 7f15be9078 2007-11-20 aku: if {[HasArc $dg $cset $succ]} continue;# TODO should be graph method. 7f15be9078 2007-11-20 aku: $dg arc insert $cset $succ 770a9b576a 2007-11-16 aku: } 770a9b576a 2007-11-16 aku: } 7f15be9078 2007-11-20 aku: d58423cdc4 2007-11-21 aku: return d58423cdc4 2007-11-21 aku: } d58423cdc4 2007-11-21 aku: d58423cdc4 2007-11-21 aku: # # ## ### ##### ######## ############# d58423cdc4 2007-11-21 aku: ## Callback invokation ... d58423cdc4 2007-11-21 aku: 1e177a4c91 2007-11-21 aku: proc PreHook {graph} { 1e177a4c91 2007-11-21 aku: # Give the user of the cycle breaker the opportunity to work 1e177a4c91 2007-11-21 aku: # with the graph between setup and consummation. 1e177a4c91 2007-11-21 aku: 1e177a4c91 2007-11-21 aku: ::variable myprecmd 1e177a4c91 2007-11-21 aku: if {![llength $myprecmd]} return 1e177a4c91 2007-11-21 aku: 1e177a4c91 2007-11-21 aku: uplevel #0 [linsert $myprecmd end $graph] 2a0ec504c5 2007-11-21 aku: Mark $graph -pre-done 1e177a4c91 2007-11-21 aku: return 1e177a4c91 2007-11-21 aku: } 1e177a4c91 2007-11-21 aku: 5f5620fbd2 2007-11-23 aku: proc ProcessedHook {dg cset pos} { d58423cdc4 2007-11-21 aku: # Give the user of the cycle breaker the opportunity to work d58423cdc4 2007-11-21 aku: # with the changeset before it is removed from the graph. d58423cdc4 2007-11-21 aku: d58423cdc4 2007-11-21 aku: ::variable mysavecmd d58423cdc4 2007-11-21 aku: if {![llength $mysavecmd]} return d58423cdc4 2007-11-21 aku: 5f5620fbd2 2007-11-23 aku: uplevel #0 [linsert $mysavecmd end $dg $pos $cset] 2cf0462b82 2007-11-21 aku: return 2cf0462b82 2007-11-21 aku: } 2cf0462b82 2007-11-21 aku: 2cf0462b82 2007-11-21 aku: proc BreakCycleHook {graph} { 2cf0462b82 2007-11-21 aku: # Call out to the chosen algorithm for cycle breaking. Finding 2cf0462b82 2007-11-21 aku: # a cycle if no breaker was chosen is an error. 2cf0462b82 2007-11-21 aku: 2cf0462b82 2007-11-21 aku: ::variable mybreakcmd 2cf0462b82 2007-11-21 aku: if {![llength $mybreakcmd]} { 2cf0462b82 2007-11-21 aku: trouble fatal "Found a cycle, expecting none." 2cf0462b82 2007-11-21 aku: exit 1 2cf0462b82 2007-11-21 aku: } 2cf0462b82 2007-11-21 aku: 2cf0462b82 2007-11-21 aku: uplevel #0 [linsert $mybreakcmd end $graph] d58423cdc4 2007-11-21 aku: return d58423cdc4 2007-11-21 aku: } d58423cdc4 2007-11-21 aku: d58423cdc4 2007-11-21 aku: proc ClearHooks {} { 1e177a4c91 2007-11-21 aku: ::variable myprecmd {} 2cf0462b82 2007-11-21 aku: ::variable mysavecmd {} 2cf0462b82 2007-11-21 aku: ::variable mybreakcmd {} 7f15be9078 2007-11-20 aku: return 7f15be9078 2007-11-20 aku: } 7f15be9078 2007-11-20 aku: 2cf0462b82 2007-11-21 aku: # # ## ### ##### ######## ############# 2cf0462b82 2007-11-21 aku: 97b4405ecf 2007-11-25 aku: proc MarkWatch {graph} { 97b4405ecf 2007-11-25 aku: ::variable mywatchids 97b4405ecf 2007-11-25 aku: set watched [Watched $graph $mywatchids] 97b4405ecf 2007-11-25 aku: if {![llength $watched]} return 97b4405ecf 2007-11-25 aku: set neighbours [eval [linsert $watched 0 $graph nodes -adj]] 97b4405ecf 2007-11-25 aku: #foreach n $neighbours { log write 6 cyclebreaker "Neighbor [$n id] => $n" } 97b4405ecf 2007-11-25 aku: Mark $graph watched [concat $watched $neighbours] 770a9b576a 2007-11-16 aku: return 770a9b576a 2007-11-16 aku: } 770a9b576a 2007-11-16 aku: 97b4405ecf 2007-11-25 aku: proc Watched {graph watchids} { 97b4405ecf 2007-11-25 aku: set res {} 97b4405ecf 2007-11-25 aku: foreach id $watchids { 97b4405ecf 2007-11-25 aku: set nl [$graph nodes -key __id__ -value $id] 97b4405ecf 2007-11-25 aku: if {![llength $nl]} continue 97b4405ecf 2007-11-25 aku: lappend res $nl 97b4405ecf 2007-11-25 aku: #log write 6 breakrcycle "Watching $id => $nl" 97b4405ecf 2007-11-25 aku: $graph node set $nl fontcolor red 97b4405ecf 2007-11-25 aku: } 97b4405ecf 2007-11-25 aku: return $res 97b4405ecf 2007-11-25 aku: } 97b4405ecf 2007-11-25 aku: d58423cdc4 2007-11-21 aku: # # ## ### ##### ######## ############# 97b4405ecf 2007-11-25 aku: d58423cdc4 2007-11-21 aku: d58423cdc4 2007-11-21 aku: typevariable myat 0 ; # Counter for commit ids for the d58423cdc4 2007-11-21 aku: # changesets. d58423cdc4 2007-11-21 aku: typevariable mybottom {} ; # List of the candidate nodes for d58423cdc4 2007-11-21 aku: # committing. d58423cdc4 2007-11-21 aku: 1e177a4c91 2007-11-21 aku: typevariable myprecmd {} ; # Callback, change graph before walk. d58423cdc4 2007-11-21 aku: typevariable mysavecmd {} ; # Callback, for each processed node. 2cf0462b82 2007-11-21 aku: typevariable mybreakcmd {} ; # Callback, for each found cycle. 7f15be9078 2007-11-20 aku: d58423cdc4 2007-11-21 aku: typevariable mydotdestination {} ; # Destination directory for the d58423cdc4 2007-11-21 aku: # generated .dot files. d58423cdc4 2007-11-21 aku: typevariable mydotprefix {} ; # Prefix for dot files when d58423cdc4 2007-11-21 aku: # exporting the graphs. d58423cdc4 2007-11-21 aku: typevariable mydotid 0 ; # Counter for dot file name d58423cdc4 2007-11-21 aku: # generation. 97b4405ecf 2007-11-25 aku: typevariable mywatchids {} ; # Changesets to watch the 97b4405ecf 2007-11-25 aku: # neighbourhood of. 770a9b576a 2007-11-16 aku: 770a9b576a 2007-11-16 aku: # # ## ### ##### ######## ############# 770a9b576a 2007-11-16 aku: ## Configuration 770a9b576a 2007-11-16 aku: 770a9b576a 2007-11-16 aku: pragma -hasinstances no ; # singleton 770a9b576a 2007-11-16 aku: pragma -hastypeinfo no ; # no introspection 770a9b576a 2007-11-16 aku: pragma -hastypedestroy no ; # immortal 770a9b576a 2007-11-16 aku: 770a9b576a 2007-11-16 aku: # # ## ### ##### ######## ############# 770a9b576a 2007-11-16 aku: } 770a9b576a 2007-11-16 aku: 770a9b576a 2007-11-16 aku: namespace eval ::vc::fossil::import::cvs { 770a9b576a 2007-11-16 aku: namespace export cyclebreaker 770a9b576a 2007-11-16 aku: namespace eval cyclebreaker { 770a9b576a 2007-11-16 aku: namespace eval project { 770a9b576a 2007-11-16 aku: namespace import ::vc::fossil::import::cvs::project::rev 770a9b576a 2007-11-16 aku: namespace import ::vc::fossil::import::cvs::project::revlink 770a9b576a 2007-11-16 aku: } 770a9b576a 2007-11-16 aku: namespace import ::vc::tools::misc::* 770a9b576a 2007-11-16 aku: namespace import ::vc::tools::log 2cf0462b82 2007-11-21 aku: namespace import ::vc::tools::trouble 7f15be9078 2007-11-20 aku: namespace import ::vc::tools::dot 770a9b576a 2007-11-16 aku: log register cyclebreaker 770a9b576a 2007-11-16 aku: } 770a9b576a 2007-11-16 aku: } 770a9b576a 2007-11-16 aku: 770a9b576a 2007-11-16 aku: # # ## ### ##### ######## ############# ##################### 770a9b576a 2007-11-16 aku: ## Ready 770a9b576a 2007-11-16 aku: 770a9b576a 2007-11-16 aku: package provide vc::fossil::import::cvs::cyclebreaker 1.0 770a9b576a 2007-11-16 aku: return
File Annotation