Fossil SCM

fossil-scm / tools / cvs2fossil / lib / c2f_gtcore.tcl
Source Blame History 239 lines
e701313… aku 1 ## -*- tcl -*-
e701313… aku 2 # # ## ### ##### ######## ############# #####################
e701313… aku 3 ## Copyright (c) 2007 Andreas Kupries.
e701313… aku 4 #
e701313… aku 5 # This software is licensed as described in the file LICENSE, which
e701313… aku 6 # you should have received as part of this distribution.
e701313… aku 7 #
e701313… aku 8 # This software consists of voluntary contributions made by many
e701313… aku 9 # individuals. For exact contribution history, see the revision
e701313… aku 10 # history and logs, available at http://fossil-scm.hwaci.com/fossil
e701313… aku 11 # # ## ### ##### ######## ############# #####################
e701313… aku 12
e701313… aku 13 ## This file provides a helper package implementing the core of
e701313… aku 14 ## traversing the nodes of a graph in topological order. This is used
e701313… aku 15 ## by the cycle breaker code (not yet), and the import backend.
e701313… aku 16
e701313… aku 17 # # ## ### ##### ######## ############# #####################
e701313… aku 18 ## Requirements
e701313… aku 19
e701313… aku 20 package require Tcl 8.4 ; # Required runtime.
e701313… aku 21 package require snit ; # OO system.
e701313… aku 22 package require struct::graph ; # Graph handling.
e701313… aku 23 package require struct::list ; # Higher order list operations.
e701313… aku 24 package require vc::tools::log ; # User feedback.
e701313… aku 25 package require vc::tools::trouble ; # Error reporting.
e701313… aku 26
e701313… aku 27 # # ## ### ##### ######## ############# #####################
e701313… aku 28 ##
e701313… aku 29
e701313… aku 30 snit::type ::vc::fossil::import::cvs::gtcore {
e701313… aku 31 # # ## ### ##### ######## #############
e701313… aku 32 ## Public API
e701313… aku 33
e701313… aku 34 typemethod savecmd {cmd} { ::variable mysavecmd $cmd ; return }
e701313… aku 35 typemethod cyclecmd {cmd} { ::variable mycyclecmd $cmd ; return }
e701313… aku 36 typemethod sortcmd {cmd} { ::variable mysortcmd $cmd ; return }
e701313… aku 37 typemethod datacmd {cmd} { ::variable mydatacmd $cmd ; return }
e701313… aku 38 typemethod formatcmd {cmd} { ::variable myformatcmd $cmd ; return }
e701313… aku 39
e701313… aku 40 # # ## ### ##### ######## #############
e701313… aku 41
b81901a… aku 42 typemethod traverse {graph {label Traverse}} {
e701313… aku 43 InitializeCandidates $graph
e701313… aku 44
b81901a… aku 45 log write 3 gtcore {$label}
e701313… aku 46
e701313… aku 47 set k 0
e701313… aku 48 set max [llength [$graph nodes]]
e701313… aku 49
e701313… aku 50 while {1} {
e701313… aku 51 while {[WithoutPredecessor $graph node]} {
e701313… aku 52 log progress 2 gtcore $k $max
e701313… aku 53 incr k
e701313… aku 54
e701313… aku 55 ProcessedHook $graph $node
e701313… aku 56 ShowPendingNodes $graph
e701313… aku 57 $graph node delete $node
e701313… aku 58 }
e701313… aku 59
e701313… aku 60 if {![llength [$graph nodes]]} break
e701313… aku 61
e701313… aku 62 CycleHook $graph
e701313… aku 63 InitializeCandidates $graph
e701313… aku 64 }
e701313… aku 65
e701313… aku 66 log write 3 gtcore Done.
e701313… aku 67 ClearHooks
e701313… aku 68 return
e701313… aku 69 }
e701313… aku 70
e701313… aku 71 # # ## ### ##### ######## #############
e701313… aku 72 ## Internal methods
e701313… aku 73
e701313… aku 74 # Instead of searching the whole graph for the degree-0 nodes in
e701313… aku 75 # each iteration we compute the list once to start, and then only
e701313… aku 76 # update it incrementally based on the outgoing neighbours of the
e701313… aku 77 # node chosen for commit.
e701313… aku 78
e701313… aku 79 proc InitializeCandidates {graph} {
e701313… aku 80 # bottom = list (list (node, range min, range max))
e701313… aku 81 ::variable mybottom
e701313… aku 82 foreach node [$graph nodes] {
e701313… aku 83 if {[$graph node degree -in $node]} continue
e701313… aku 84 lappend mybottom [list $node [DataHook $graph $node]]
e701313… aku 85 }
e701313… aku 86 ScheduleCandidates $graph
e701313… aku 87 ShowPendingNodes $graph
e701313… aku 88 return
e701313… aku 89 }
e701313… aku 90
e701313… aku 91 proc WithoutPredecessor {graph nodevar} {
e701313… aku 92 ::variable mybottom
e701313… aku 93
e701313… aku 94 upvar 1 $nodevar node
e701313… aku 95 if {![llength $mybottom]} { return 0 }
e701313… aku 96
e701313… aku 97 set node [lindex [lindex $mybottom 0] 0]
e701313… aku 98 set mybottom [lrange $mybottom 1 end]
e701313… aku 99 set changed 0
e701313… aku 100
e701313… aku 101 # Update list of nodes without predecessor, based on the
e701313… aku 102 # outgoing neighbours of the chosen node. This should be
e701313… aku 103 # faster than iterating of the whole set of nodes, finding all
e701313… aku 104 # without predecessors, sorting them by time, etc. pp.
e701313… aku 105
e701313… aku 106 foreach out [$graph nodes -out $node] {
e701313… aku 107 if {[$graph node degree -in $out] > 1} continue
e701313… aku 108 # Degree-1 neighbour, will have no predecessors after the
e701313… aku 109 # removal of n. Put on the list of candidates we can
e701313… aku 110 # process.
e701313… aku 111 lappend mybottom [list $out [DataHook $graph $out]]
e701313… aku 112 set changed 1
e701313… aku 113 }
e701313… aku 114 if {$changed} {
e701313… aku 115 ScheduleCandidates $graph
e701313… aku 116 }
e701313… aku 117
e701313… aku 118 # We do not delete the node immediately, to allow the Save
e701313… aku 119 # procedure to save the dependencies as well (encoded in the
e701313… aku 120 # arcs).
e701313… aku 121 return 1
e701313… aku 122 }
e701313… aku 123
e701313… aku 124 proc ScheduleCandidates {graph} {
e701313… aku 125 ::variable mybottom
e701313… aku 126 ::variable mysortcmd
e701313… aku 127 if {[llength $mysortcmd]} {
e701313… aku 128 set mybottom [uplevel \#0 [linsert $mysortcmd end $graph $mybottom]]
e701313… aku 129 } else {
e701313… aku 130 set mybottom [lsort -index 0 -dict $mybottom]
e701313… aku 131 }
e701313… aku 132 return
e701313… aku 133 }
e701313… aku 134
e701313… aku 135 proc ShowPendingNodes {graph} {
e701313… aku 136 if {[log verbosity?] < 10} return
e701313… aku 137 ::variable mybottom
e701313… aku 138 ::variable myformatcmd
e701313… aku 139
e701313… aku 140 log write 10 gtcore "Pending..............................."
e701313… aku 141 foreach item [struct::list map $mybottom \
e701313… aku 142 [linsert $myformatcmd end $graph]] {
e701313… aku 143 log write 10 gtcore "Pending: $item"
e701313… aku 144 }
e701313… aku 145 return
e701313… aku 146 }
e701313… aku 147
e701313… aku 148 # # ## ### ##### ######## #############
e701313… aku 149 ## Callback invokation ...
e701313… aku 150
e701313… aku 151 proc DataHook {graph node} {
e701313… aku 152 # Allow the user of the traverser to a client data to a node
e701313… aku 153 # in the list of nodes available for immediate processing.
e701313… aku 154 # This data can be used by the sort callback.
e701313… aku 155
e701313… aku 156 ::variable mydatacmd
e701313… aku 157 if {![llength $mydatacmd]} { return {} }
e701313… aku 158
e701313… aku 159 return [uplevel \#0 [linsert $mydatacmd end $graph $node]]
e701313… aku 160 }
e701313… aku 161
e701313… aku 162 proc FormatHook {graph item} {
e701313… aku 163 # Allow the user to format a pending item (node + client data)
e701313… aku 164 # according to its wishes.
e701313… aku 165
e701313… aku 166 ::variable myformatcmd
e701313… aku 167 if {![llength $myformatcmd]} { return $item }
e701313… aku 168
e701313… aku 169 return [uplevel \#0 [linsert $myformatcmd end $graph $item]]
e701313… aku 170 }
e701313… aku 171
e701313… aku 172 proc ProcessedHook {graph node} {
e701313… aku 173 # Give the user of the traverser the opportunity to work with
e701313… aku 174 # the node before it is removed from the graph.
e701313… aku 175
e701313… aku 176 ::variable mysavecmd
e701313… aku 177 if {![llength $mysavecmd]} return
e701313… aku 178
e701313… aku 179 uplevel \#0 [linsert $mysavecmd end $graph $node]
e701313… aku 180 return
e701313… aku 181 }
e701313… aku 182
e701313… aku 183 proc CycleHook {graph} {
e701313… aku 184 # Call out to the chosen algorithm for handling cycles. It is
e701313… aku 185 # an error to find a cycle if no hook was defined.
e701313… aku 186
e701313… aku 187 ::variable mycyclecmd
e701313… aku 188 if {![llength $mycyclecmd]} {
e701313… aku 189 trouble fatal "Found a cycle, expecting none."
e701313… aku 190 exit 1
e701313… aku 191 }
e701313… aku 192
e701313… aku 193 uplevel \#0 [linsert $mycyclecmd end $graph]
e701313… aku 194 return
e701313… aku 195 }
e701313… aku 196
e701313… aku 197 proc ClearHooks {} {
e701313… aku 198 ::variable mysortcmd {}
e701313… aku 199 ::variable myformatcmd {}
e701313… aku 200 ::variable mydatacmd {}
e701313… aku 201 ::variable mysavecmd {}
e701313… aku 202 ::variable mycyclecmd {}
e701313… aku 203 return
e701313… aku 204 }
e701313… aku 205
e701313… aku 206 # # ## ### ##### ######## #############
e701313… aku 207
e701313… aku 208 typevariable mybottom {} ; # List of the nodes pending traversal.
e701313… aku 209
e701313… aku 210 typevariable mysortcmd {} ; # Callback, sort list of pending nodes
e701313… aku 211 typevariable mydatacmd {} ; # Callback, get client data for a pending node
e701313… aku 212 typevariable myformatcmd {} ; # Callback, format a pending node for display
e701313… aku 213 typevariable mysavecmd {} ; # Callback, for each processed node.
e701313… aku 214 typevariable mycyclecmd {} ; # Callback, when a cycle was encountered.
e701313… aku 215
e701313… aku 216 # # ## ### ##### ######## #############
e701313… aku 217 ## Configuration
e701313… aku 218
e701313… aku 219 pragma -hasinstances no ; # singleton
e701313… aku 220 pragma -hastypeinfo no ; # no introspection
e701313… aku 221 pragma -hastypedestroy no ; # immortal
e701313… aku 222
e701313… aku 223 # # ## ### ##### ######## #############
e701313… aku 224 }
e701313… aku 225
e701313… aku 226 namespace eval ::vc::fossil::import::cvs {
e701313… aku 227 namespace export gtcore
e701313… aku 228 namespace eval gtcore {
e701313… aku 229 namespace import ::vc::tools::log
e701313… aku 230 namespace import ::vc::tools::trouble
e701313… aku 231 log register gtcore
e701313… aku 232 }
e701313… aku 233 }
e701313… aku 234
e701313… aku 235 # # ## ### ##### ######## ############# #####################
e701313… aku 236 ## Ready
e701313… aku 237
e701313… aku 238 package provide vc::fossil::import::cvs::gtcore 1.0
e701313… aku 239 return

Keyboard Shortcuts

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