e701313733 2007-12-05 aku: ## -*- tcl -*- e701313733 2007-12-05 aku: # # ## ### ##### ######## ############# ##################### e701313733 2007-12-05 aku: ## Copyright (c) 2007 Andreas Kupries. e701313733 2007-12-05 aku: # e701313733 2007-12-05 aku: # This software is licensed as described in the file LICENSE, which e701313733 2007-12-05 aku: # you should have received as part of this distribution. e701313733 2007-12-05 aku: # e701313733 2007-12-05 aku: # This software consists of voluntary contributions made by many e701313733 2007-12-05 aku: # individuals. For exact contribution history, see the revision e701313733 2007-12-05 aku: # history and logs, available at http://fossil-scm.hwaci.com/fossil e701313733 2007-12-05 aku: # # ## ### ##### ######## ############# ##################### e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: ## This file provides a helper package implementing the core of e701313733 2007-12-05 aku: ## traversing the nodes of a graph in topological order. This is used e701313733 2007-12-05 aku: ## by the cycle breaker code (not yet), and the import backend. e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: # # ## ### ##### ######## ############# ##################### e701313733 2007-12-05 aku: ## Requirements e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: package require Tcl 8.4 ; # Required runtime. e701313733 2007-12-05 aku: package require snit ; # OO system. e701313733 2007-12-05 aku: package require struct::graph ; # Graph handling. e701313733 2007-12-05 aku: package require struct::list ; # Higher order list operations. e701313733 2007-12-05 aku: package require vc::tools::log ; # User feedback. e701313733 2007-12-05 aku: package require vc::tools::trouble ; # Error reporting. e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: # # ## ### ##### ######## ############# ##################### e701313733 2007-12-05 aku: ## e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: snit::type ::vc::fossil::import::cvs::gtcore { e701313733 2007-12-05 aku: # # ## ### ##### ######## ############# e701313733 2007-12-05 aku: ## Public API e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: typemethod savecmd {cmd} { ::variable mysavecmd $cmd ; return } e701313733 2007-12-05 aku: typemethod cyclecmd {cmd} { ::variable mycyclecmd $cmd ; return } e701313733 2007-12-05 aku: typemethod sortcmd {cmd} { ::variable mysortcmd $cmd ; return } e701313733 2007-12-05 aku: typemethod datacmd {cmd} { ::variable mydatacmd $cmd ; return } e701313733 2007-12-05 aku: typemethod formatcmd {cmd} { ::variable myformatcmd $cmd ; return } e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: # # ## ### ##### ######## ############# e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: typemethod traverse {graph} { e701313733 2007-12-05 aku: InitializeCandidates $graph e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: log write 3 gtcore {Traverse} e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: set k 0 e701313733 2007-12-05 aku: set max [llength [$graph nodes]] e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: while {1} { e701313733 2007-12-05 aku: while {[WithoutPredecessor $graph node]} { e701313733 2007-12-05 aku: log progress 2 gtcore $k $max e701313733 2007-12-05 aku: incr k e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: ProcessedHook $graph $node e701313733 2007-12-05 aku: ShowPendingNodes $graph e701313733 2007-12-05 aku: $graph node delete $node e701313733 2007-12-05 aku: } e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: if {![llength [$graph nodes]]} break e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: CycleHook $graph e701313733 2007-12-05 aku: InitializeCandidates $graph e701313733 2007-12-05 aku: } e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: $graph destroy e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: log write 3 gtcore Done. e701313733 2007-12-05 aku: ClearHooks e701313733 2007-12-05 aku: return e701313733 2007-12-05 aku: } e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: # # ## ### ##### ######## ############# e701313733 2007-12-05 aku: ## Internal methods e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: # Instead of searching the whole graph for the degree-0 nodes in e701313733 2007-12-05 aku: # each iteration we compute the list once to start, and then only e701313733 2007-12-05 aku: # update it incrementally based on the outgoing neighbours of the e701313733 2007-12-05 aku: # node chosen for commit. e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: proc InitializeCandidates {graph} { e701313733 2007-12-05 aku: # bottom = list (list (node, range min, range max)) e701313733 2007-12-05 aku: ::variable mybottom e701313733 2007-12-05 aku: foreach node [$graph nodes] { e701313733 2007-12-05 aku: if {[$graph node degree -in $node]} continue e701313733 2007-12-05 aku: lappend mybottom [list $node [DataHook $graph $node]] e701313733 2007-12-05 aku: } e701313733 2007-12-05 aku: ScheduleCandidates $graph e701313733 2007-12-05 aku: ShowPendingNodes $graph e701313733 2007-12-05 aku: return e701313733 2007-12-05 aku: } e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: proc WithoutPredecessor {graph nodevar} { e701313733 2007-12-05 aku: ::variable mybottom e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: upvar 1 $nodevar node e701313733 2007-12-05 aku: if {![llength $mybottom]} { return 0 } e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: set node [lindex [lindex $mybottom 0] 0] e701313733 2007-12-05 aku: set mybottom [lrange $mybottom 1 end] e701313733 2007-12-05 aku: set changed 0 e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: # Update list of nodes without predecessor, based on the e701313733 2007-12-05 aku: # outgoing neighbours of the chosen node. This should be e701313733 2007-12-05 aku: # faster than iterating of the whole set of nodes, finding all e701313733 2007-12-05 aku: # without predecessors, sorting them by time, etc. pp. e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: foreach out [$graph nodes -out $node] { e701313733 2007-12-05 aku: if {[$graph node degree -in $out] > 1} continue e701313733 2007-12-05 aku: # Degree-1 neighbour, will have no predecessors after the e701313733 2007-12-05 aku: # removal of n. Put on the list of candidates we can e701313733 2007-12-05 aku: # process. e701313733 2007-12-05 aku: lappend mybottom [list $out [DataHook $graph $out]] e701313733 2007-12-05 aku: set changed 1 e701313733 2007-12-05 aku: } e701313733 2007-12-05 aku: if {$changed} { e701313733 2007-12-05 aku: ScheduleCandidates $graph e701313733 2007-12-05 aku: } e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: # We do not delete the node immediately, to allow the Save e701313733 2007-12-05 aku: # procedure to save the dependencies as well (encoded in the e701313733 2007-12-05 aku: # arcs). e701313733 2007-12-05 aku: return 1 e701313733 2007-12-05 aku: } e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: proc ScheduleCandidates {graph} { e701313733 2007-12-05 aku: ::variable mybottom e701313733 2007-12-05 aku: ::variable mysortcmd e701313733 2007-12-05 aku: if {[llength $mysortcmd]} { e701313733 2007-12-05 aku: set mybottom [uplevel \#0 [linsert $mysortcmd end $graph $mybottom]] e701313733 2007-12-05 aku: } else { e701313733 2007-12-05 aku: set mybottom [lsort -index 0 -dict $mybottom] e701313733 2007-12-05 aku: } e701313733 2007-12-05 aku: return e701313733 2007-12-05 aku: } e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: proc ShowPendingNodes {graph} { e701313733 2007-12-05 aku: if {[log verbosity?] < 10} return e701313733 2007-12-05 aku: ::variable mybottom e701313733 2007-12-05 aku: ::variable myformatcmd e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: log write 10 gtcore "Pending..............................." e701313733 2007-12-05 aku: foreach item [struct::list map $mybottom \ e701313733 2007-12-05 aku: [linsert $myformatcmd end $graph]] { e701313733 2007-12-05 aku: log write 10 gtcore "Pending: $item" e701313733 2007-12-05 aku: } e701313733 2007-12-05 aku: return e701313733 2007-12-05 aku: } e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: # # ## ### ##### ######## ############# e701313733 2007-12-05 aku: ## Callback invokation ... e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: proc DataHook {graph node} { e701313733 2007-12-05 aku: # Allow the user of the traverser to a client data to a node e701313733 2007-12-05 aku: # in the list of nodes available for immediate processing. e701313733 2007-12-05 aku: # This data can be used by the sort callback. e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: ::variable mydatacmd e701313733 2007-12-05 aku: if {![llength $mydatacmd]} { return {} } e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: return [uplevel \#0 [linsert $mydatacmd end $graph $node]] e701313733 2007-12-05 aku: } e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: proc FormatHook {graph item} { e701313733 2007-12-05 aku: # Allow the user to format a pending item (node + client data) e701313733 2007-12-05 aku: # according to its wishes. e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: ::variable myformatcmd e701313733 2007-12-05 aku: if {![llength $myformatcmd]} { return $item } e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: return [uplevel \#0 [linsert $myformatcmd end $graph $item]] e701313733 2007-12-05 aku: } e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: proc ProcessedHook {graph node} { e701313733 2007-12-05 aku: # Give the user of the traverser the opportunity to work with e701313733 2007-12-05 aku: # the node before it is removed from the graph. e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: ::variable mysavecmd e701313733 2007-12-05 aku: if {![llength $mysavecmd]} return e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: uplevel \#0 [linsert $mysavecmd end $graph $node] e701313733 2007-12-05 aku: return e701313733 2007-12-05 aku: } e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: proc CycleHook {graph} { e701313733 2007-12-05 aku: # Call out to the chosen algorithm for handling cycles. It is e701313733 2007-12-05 aku: # an error to find a cycle if no hook was defined. e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: ::variable mycyclecmd e701313733 2007-12-05 aku: if {![llength $mycyclecmd]} { e701313733 2007-12-05 aku: trouble fatal "Found a cycle, expecting none." e701313733 2007-12-05 aku: exit 1 e701313733 2007-12-05 aku: } e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: uplevel \#0 [linsert $mycyclecmd end $graph] e701313733 2007-12-05 aku: return e701313733 2007-12-05 aku: } e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: proc ClearHooks {} { e701313733 2007-12-05 aku: ::variable mysortcmd {} e701313733 2007-12-05 aku: ::variable myformatcmd {} e701313733 2007-12-05 aku: ::variable mydatacmd {} e701313733 2007-12-05 aku: ::variable mysavecmd {} e701313733 2007-12-05 aku: ::variable mycyclecmd {} e701313733 2007-12-05 aku: return e701313733 2007-12-05 aku: } e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: # # ## ### ##### ######## ############# e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: typevariable mybottom {} ; # List of the nodes pending traversal. e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: typevariable mysortcmd {} ; # Callback, sort list of pending nodes e701313733 2007-12-05 aku: typevariable mydatacmd {} ; # Callback, get client data for a pending node e701313733 2007-12-05 aku: typevariable myformatcmd {} ; # Callback, format a pending node for display e701313733 2007-12-05 aku: typevariable mysavecmd {} ; # Callback, for each processed node. e701313733 2007-12-05 aku: typevariable mycyclecmd {} ; # Callback, when a cycle was encountered. e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: # # ## ### ##### ######## ############# e701313733 2007-12-05 aku: ## Configuration e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: pragma -hasinstances no ; # singleton e701313733 2007-12-05 aku: pragma -hastypeinfo no ; # no introspection e701313733 2007-12-05 aku: pragma -hastypedestroy no ; # immortal e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: # # ## ### ##### ######## ############# e701313733 2007-12-05 aku: } e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: namespace eval ::vc::fossil::import::cvs { e701313733 2007-12-05 aku: namespace export gtcore e701313733 2007-12-05 aku: namespace eval gtcore { e701313733 2007-12-05 aku: namespace import ::vc::tools::log e701313733 2007-12-05 aku: namespace import ::vc::tools::trouble e701313733 2007-12-05 aku: log register gtcore e701313733 2007-12-05 aku: } e701313733 2007-12-05 aku: } e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: # # ## ### ##### ######## ############# ##################### e701313733 2007-12-05 aku: ## Ready e701313733 2007-12-05 aku: e701313733 2007-12-05 aku: package provide vc::fossil::import::cvs::gtcore 1.0 e701313733 2007-12-05 aku: return
File Annotation