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