|
1
|
## -*- tcl -*- |
|
2
|
# # ## ### ##### ######## ############# ##################### |
|
3
|
## Copyright (c) 2007-2008 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
|
## Pass I. This pass scans the repository to import for RCS archives, |
|
14
|
## and sorts and filters them into the declared projects, if any |
|
15
|
## Without declared projects the whole repository is treated as a |
|
16
|
## single project. |
|
17
|
|
|
18
|
# # ## ### ##### ######## ############# ##################### |
|
19
|
## Requirements |
|
20
|
|
|
21
|
package require Tcl 8.4 ; # Required runtime. |
|
22
|
package require snit ; # OO system. |
|
23
|
package require fileutil::traverse ; # Directory traversal. |
|
24
|
package require fileutil ; # File & path utilities. |
|
25
|
package require vc::tools::trouble ; # Error reporting. |
|
26
|
package require vc::tools::log ; # User feedback. |
|
27
|
package require vc::tools::misc ; # Local file utilities. |
|
28
|
package require vc::fossil::import::cvs::pass ; # Pass management. |
|
29
|
package require vc::fossil::import::cvs::repository ; # Repository management. |
|
30
|
package require vc::fossil::import::cvs::state ; # State storage |
|
31
|
|
|
32
|
# # ## ### ##### ######## ############# ##################### |
|
33
|
## Register the pass with the management |
|
34
|
|
|
35
|
vc::fossil::import::cvs::pass define \ |
|
36
|
CollectAr \ |
|
37
|
{Collect archives in repository} \ |
|
38
|
::vc::fossil::import::cvs::pass::collar |
|
39
|
|
|
40
|
# # ## ### ##### ######## ############# ##################### |
|
41
|
## |
|
42
|
|
|
43
|
snit::type ::vc::fossil::import::cvs::pass::collar { |
|
44
|
# # ## ### ##### ######## ############# |
|
45
|
## Public API |
|
46
|
|
|
47
|
typemethod setup {} { |
|
48
|
# Define names and structure of the persistent state of this |
|
49
|
# pass. |
|
50
|
|
|
51
|
# We deal with repository projects, and the rcs archive files |
|
52
|
# in the projects. |
|
53
|
|
|
54
|
# For the first, projects, we keep their names, which are |
|
55
|
# their paths relative to the base directory of the whole |
|
56
|
# repository. These have to be globally unique, i.e. no two |
|
57
|
# projects can have the same name. |
|
58
|
|
|
59
|
# For the files we keep their names, which are their paths |
|
60
|
# relative to the base directory of the whole project! These |
|
61
|
# have to be unique within a project, however globally this |
|
62
|
# does not hold, a name may occur several times, in different |
|
63
|
# projects. We further store the user visible file name |
|
64
|
# associated with the rcs archive. |
|
65
|
|
|
66
|
# Both projects and files are identified by globally unique |
|
67
|
# integer ids, automatically assigned by the database. |
|
68
|
|
|
69
|
state extend project { |
|
70
|
pid INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT, |
|
71
|
name TEXT NOT NULL UNIQUE |
|
72
|
} |
|
73
|
state extend file { |
|
74
|
fid INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT, |
|
75
|
pid INTEGER NOT NULL REFERENCES project, -- project the file belongs to |
|
76
|
name TEXT NOT NULL, |
|
77
|
visible TEXT NOT NULL, |
|
78
|
exec INTEGER NOT NULL, -- boolean, 'file executable'. |
|
79
|
UNIQUE (pid, name) -- file names are unique within a project |
|
80
|
} |
|
81
|
return |
|
82
|
} |
|
83
|
|
|
84
|
typemethod load {} { |
|
85
|
# Pass manager interface. Executed for all passes before the |
|
86
|
# run passes, to load all data of their pass from the state, |
|
87
|
# as if it had been computed by the pass itself. |
|
88
|
|
|
89
|
state use project |
|
90
|
state use file |
|
91
|
|
|
92
|
repository load |
|
93
|
return |
|
94
|
} |
|
95
|
|
|
96
|
typemethod run {} { |
|
97
|
# Pass manager interface. Executed to perform the |
|
98
|
# functionality of the pass. |
|
99
|
|
|
100
|
set rbase [repository base?] |
|
101
|
foreach project [repository projects] { |
|
102
|
set base [::file join $rbase [$project base]] |
|
103
|
log write 1 collar "Scan $base" |
|
104
|
|
|
105
|
set traverse [fileutil::traverse %AUTO% $base \ |
|
106
|
-prefilter [myproc FilterAtticSubdir $base]] |
|
107
|
set n 0 |
|
108
|
set r {} |
|
109
|
|
|
110
|
$traverse foreach path { |
|
111
|
set rcs [fileutil::stripPath $base $path] |
|
112
|
if {[IsCVSAdmin $rcs]} continue |
|
113
|
if {![IsRCSArchive $path]} continue |
|
114
|
|
|
115
|
set usr [UserPath $rcs isattic] |
|
116
|
|
|
117
|
if {[CheckForAndReportPathConflicts $base $rcs $usr $isattic]} continue |
|
118
|
if {[HandleDotFile $base $rcs usr $isattic]} continue |
|
119
|
|
|
120
|
log write 4 collar "Found $rcs" |
|
121
|
$project addfile $rcs $usr [file executable $rcs] |
|
122
|
|
|
123
|
incr n |
|
124
|
if {[log verbosity?] < 4} { |
|
125
|
log progress 0 collar $n {} |
|
126
|
} |
|
127
|
} |
|
128
|
|
|
129
|
$traverse destroy |
|
130
|
} |
|
131
|
|
|
132
|
repository printstatistics |
|
133
|
repository persist |
|
134
|
|
|
135
|
log write 1 collar "Scan completed" |
|
136
|
return |
|
137
|
} |
|
138
|
|
|
139
|
typemethod discard {} { |
|
140
|
# Pass manager interface. Executed for all passes after the |
|
141
|
# run passes, to remove all data of this pass from the state, |
|
142
|
# as being out of date. |
|
143
|
|
|
144
|
state discard project |
|
145
|
state discard file |
|
146
|
return |
|
147
|
} |
|
148
|
|
|
149
|
typemethod ignore_conflicting_attics {} { |
|
150
|
set myignore 1 |
|
151
|
return |
|
152
|
} |
|
153
|
|
|
154
|
typemethod accept_and_convert_dotfiles {} { |
|
155
|
set myconvertdot 1 |
|
156
|
return |
|
157
|
} |
|
158
|
|
|
159
|
# # ## ### ##### ######## ############# |
|
160
|
## Internal methods |
|
161
|
|
|
162
|
typevariable myignore 0 ; # Flag. When set Attic files |
|
163
|
# superceded by regular files |
|
164
|
# ignored. |
|
165
|
typevariable myconvertdot 0 ; # Flag. When set dotfiles do not |
|
166
|
# cause rejection, but their names |
|
167
|
# are converted to a dotless form |
|
168
|
# ('dot-' prefix instead of '.'). |
|
169
|
|
|
170
|
proc FilterAtticSubdir {base path} { |
|
171
|
# This command is used by the traverser to prevent it from |
|
172
|
# scanning into subdirectories of an Attic. We get away with |
|
173
|
# checking the immediate parent directory of the current path |
|
174
|
# as our rejection means that deeper path do not occur. |
|
175
|
|
|
176
|
if {[file tail [file dirname $path]] eq "Attic"} { |
|
177
|
set ad [fileutil::stripPath $base $path] |
|
178
|
log write 1 collar "Directory $ad found in Attic, ignoring." |
|
179
|
return 0 |
|
180
|
} |
|
181
|
return 1 |
|
182
|
} |
|
183
|
|
|
184
|
proc IsRCSArchive {path} { |
|
185
|
if {![string match *,v $path]} {return 0} |
|
186
|
if {[fileutil::test $path fr msg]} {return 1} |
|
187
|
trouble warn $msg |
|
188
|
return 0 |
|
189
|
} |
|
190
|
|
|
191
|
proc IsCVSAdmin {rcs} { |
|
192
|
if { |
|
193
|
[string match {CVSROOT/*} $rcs] || |
|
194
|
[string match {.cvsignore*} [file tail $rcs]] |
|
195
|
} { |
|
196
|
log write 4 collar "Ignored $rcs, administrative archive" |
|
197
|
return 1 |
|
198
|
} |
|
199
|
return 0 |
|
200
|
} |
|
201
|
|
|
202
|
proc UserPath {rcs iav} { |
|
203
|
upvar 1 $iav isattic |
|
204
|
|
|
205
|
# Derive the user-visible path from the rcs path. Meaning: |
|
206
|
# Chop off the ",v" suffix, and remove a possible "Attic". |
|
207
|
|
|
208
|
set f [string range $rcs 0 end-2] |
|
209
|
|
|
210
|
if {"Attic" eq [lindex [file split $rcs] end-1]} { |
|
211
|
|
|
212
|
# The construction below ensures that Attic/X maps to X |
|
213
|
# instead of ./X. Otherwise, Y/Attic/X maps to Y/X. |
|
214
|
|
|
215
|
set fx [file dirname [file dirname $f]] |
|
216
|
set f [file tail $f] |
|
217
|
if {$fx ne "."} { set f [file join $fx $f] } |
|
218
|
|
|
219
|
set isattic 1 |
|
220
|
} else { |
|
221
|
set isattic 0 |
|
222
|
} |
|
223
|
|
|
224
|
return $f |
|
225
|
} |
|
226
|
|
|
227
|
proc IsSuperceded {base rcs usr isattic} { |
|
228
|
::variable myignore |
|
229
|
|
|
230
|
if {!$isattic} {return 0} |
|
231
|
if {![fileexists_cs $base/$usr,v]} {return 0} |
|
232
|
|
|
233
|
# We have a regular archive and an Attic archive refering to |
|
234
|
# the same user visible file. Ignore the file in the Attic. |
|
235
|
# |
|
236
|
# By default this is a problem causing an abort after the pass |
|
237
|
# has completed. The user can however force us to ignore it. |
|
238
|
# In that case the warning is still printed, but will not |
|
239
|
# induce an abort any longer. |
|
240
|
|
|
241
|
if {$myignore} { |
|
242
|
log write 2 collar "Ignored $rcs, superceded archive" |
|
243
|
} else { |
|
244
|
trouble warn "Ignored $rcs, superceded archive" |
|
245
|
} |
|
246
|
return 1 |
|
247
|
} |
|
248
|
|
|
249
|
# In the future we should move the activity below into the fossil |
|
250
|
# backend, as the exact set of paths requiring translation, and |
|
251
|
# how to translate them, depends entirely on the limitations |
|
252
|
# imposed by the destination repository. |
|
253
|
|
|
254
|
proc HandleDotFile {base rcs usrvar isattic} { |
|
255
|
::variable myconvertdot |
|
256
|
upvar 1 $usrvar usr |
|
257
|
|
|
258
|
set dedot [DeDot $usr] |
|
259
|
if {$dedot eq $usr} { return 0 } |
|
260
|
|
|
261
|
# Ok, we now have established that the path has to be |
|
262
|
# translated. Which as already happened as part of the check |
|
263
|
# above. Left is to report the action, and to check if the new |
|
264
|
# path collides with existing files and directories. |
|
265
|
|
|
266
|
if {!$myconvertdot} { |
|
267
|
trouble warn "Ignored $rcs, is a dot-file" |
|
268
|
return 1 |
|
269
|
} |
|
270
|
|
|
271
|
log write 2 collar "Convert $rcs, is a dot-file" |
|
272
|
set usr $dedot |
|
273
|
|
|
274
|
return [CheckForAndReportPathConflicts $base $rcs $usr $isattic] |
|
275
|
} |
|
276
|
|
|
277
|
proc DeDot {path} { |
|
278
|
set res {} |
|
279
|
foreach segment [file split $path] { |
|
280
|
lappend res [expr { |
|
281
|
[string match {.*} $segment] |
|
282
|
? "dot-[string range $segment 1 end]" |
|
283
|
: $segment |
|
284
|
}] |
|
285
|
} |
|
286
|
return [eval [linsert $res 0 file join]] |
|
287
|
#8.5: return [file join {*}$res] |
|
288
|
} |
|
289
|
|
|
290
|
proc CheckForAndReportPathConflicts {base rcs usr isattic {intro {}}} { |
|
291
|
if {[IsSuperceded $base $rcs $usr $isattic]} { return 1 } |
|
292
|
|
|
293
|
# XXX Checkme: not sure if this will still fail in the case |
|
294
|
# where a directory does conflict with a file XXX |
|
295
|
if { |
|
296
|
[fileexists_cs $base/$usr] && |
|
297
|
[fileisdir_cs $base/$usr] |
|
298
|
} { |
|
299
|
if {$intro ne {}} { |
|
300
|
trouble fatal $intro |
|
301
|
} |
|
302
|
trouble fatal "Directory name conflicts with filename." |
|
303
|
trouble fatal "Please remove or rename one of the following:" |
|
304
|
trouble fatal " $base/$usr" |
|
305
|
trouble fatal " $base/$rcs" |
|
306
|
return 1 |
|
307
|
} |
|
308
|
return 0 |
|
309
|
} |
|
310
|
|
|
311
|
# # ## ### ##### ######## ############# |
|
312
|
## Configuration |
|
313
|
|
|
314
|
pragma -hasinstances no ; # singleton |
|
315
|
pragma -hastypeinfo no ; # no introspection |
|
316
|
pragma -hastypedestroy no ; # immortal |
|
317
|
|
|
318
|
# # ## ### ##### ######## ############# |
|
319
|
} |
|
320
|
|
|
321
|
namespace eval ::vc::fossil::import::cvs::pass { |
|
322
|
namespace export collar |
|
323
|
namespace eval collar { |
|
324
|
namespace import ::vc::fossil::import::cvs::repository |
|
325
|
namespace import ::vc::fossil::import::cvs::state |
|
326
|
namespace import ::vc::tools::trouble |
|
327
|
namespace import ::vc::tools::log |
|
328
|
namespace import ::vc::tools::misc::file* |
|
329
|
log register collar |
|
330
|
} |
|
331
|
} |
|
332
|
|
|
333
|
# # ## ### ##### ######## ############# ##################### |
|
334
|
## Ready |
|
335
|
|
|
336
|
package provide vc::fossil::import::cvs::pass::collar 1.0 |
|
337
|
return |
|
338
|
|