Fossil SCM

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