diff options
Diffstat (limited to 'tools/cvs2fossil/lib')
43 files changed, 14226 insertions, 0 deletions
diff --git a/tools/cvs2fossil/lib/c2f_blobstore.tcl b/tools/cvs2fossil/lib/c2f_blobstore.tcl new file mode 100644 index 0000000..824adeb --- /dev/null +++ b/tools/cvs2fossil/lib/c2f_blobstore.tcl @@ -0,0 +1,155 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2008 Andreas Kupries. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## Blob storage. Each instance stores the blob data of a single rcs +## archive file, i.e. which file, all text ranges, delta dependencies, +## and associated revisions (as object references). The data is +## persistent and used by the import pass(es) to expand the revisions +## of a file. + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.4 ; # Required runtime. +package require snit ; # OO system. +package require vc::fossil::import::cvs::state ; # State storage. +package require vc::fossil::import::cvs::integrity ; # State integrity checks. +package require vc::tools::trouble ; # Error reporting. +package require vc::tools::log ; # User feedback +#package require vc::tools::misc ; # Text formatting + +# # ## ### ##### ######## ############# ##################### +## + +snit::type ::vc::fossil::import::cvs::blobstore { + # # ## ### ##### ######## ############# + ## Public API + + constructor {fid} { + set myfile $fid + array set myparent {} + array set myblob {} + return + } + + method setid {id} { + integrity assert {$myfile eq ""} {Already has an id, '$myfile'} + set myfile $id + return + } + + # Remember the file revision object for the revision REVNR. + + method add {revnr rev} { + set myblob($revnr) $rev + return + } + + # Remember that the DELTA revision is specified as a delta against + # the BASE revision. Both are specified as revision numbers. + + method delta {delta base} { + set myparent($delta) $base + return + } + + # Specify the text range in the archive file for the data of the + # revision identified by REVNR. + + method extend {revnr textrange} { + struct::list assign $textrange coff end + set clen [expr {$end - $coff}] + lappend myblob($revnr) $coff $clen + return + } + + # Write the stored information into the persistent state. + + method persist {} { + array set bids {} + state transaction { + # Phase I: Store the basic blob information. + + foreach revnr [lsort [array names myblob]] { + struct::list assign $myblob($revnr) rev coff clen + state run { + INSERT INTO blob (bid, rid, fid, coff, clen, pid) + VALUES (NULL, NULL, $myfile, $coff, $clen, NULL) + } + set current [state id] + set bids($revnr) $current + + # Ia. Set the reference to the revision of the blob, + # if applicable. We can have blobs without revisions, + # their revisions were removed as irrelevant. We need + # them however for the proper delta ordering and patch + # application when expanding a file (-> Import passes). + + set rid [$rev id] + if {$rid eq ""} continue + state run { + UPDATE blob + SET rid = $rid + WHERE bid = $current + } + } + + # Phase II: Set the parent links for deltas. + foreach revnr [array names myparent] { + set bid $bids($revnr) + set pid $bids($myparent($revnr)) + + state run { + UPDATE blob + SET pid = $pid + WHERE bid = $bid + } + } + } + return + } + + # # ## ### ##### ######## ############# + ## State + + variable myfile {} ; # Id of the file the blobs belong to. + variable myparent -array {} ; # Map delta-encoded revision numbers + # to their baseline revisions. + variable myblob -array {} ; # Map revision numbers to associated + # file revision object and text + # range. + + # # ## ### ##### ######## ############# + ## Configuration + + pragma -hastypeinfo no ; # no type introspection + pragma -hasinfo no ; # no object introspection + pragma -hastypemethods no ; # type is not relevant. + + # # ## ### ##### ######## ############# +} + +namespace eval ::vc::fossil::import::cvs { + namespace export blobstore + namespace eval blobstore { + namespace import ::vc::tools::trouble + namespace import ::vc::tools::log + namespace import ::vc::fossil::import::cvs::state + namespace import ::vc::fossil::import::cvs::integrity + } +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide vc::fossil::import::cvs::blobstore 1.0 +return diff --git a/tools/cvs2fossil/lib/c2f_cyclebreaker.tcl b/tools/cvs2fossil/lib/c2f_cyclebreaker.tcl new file mode 100644 index 0000000..3d8a21c --- /dev/null +++ b/tools/cvs2fossil/lib/c2f_cyclebreaker.tcl @@ -0,0 +1,579 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2007 Andreas Kupries. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## This file provides a helper package for the passes 6 and 7 which +## contains the common code of the cycle breaking algorithm. + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.4 ; # Required runtime. +package require snit ; # OO system. +package require struct::graph ; # Graph handling. +package require struct::list ; # Higher order list operations. +package require vc::tools::dot ; # User feedback. DOT export. +package require vc::tools::log ; # User feedback. +package require vc::tools::trouble ; # Error reporting. +package require vc::tools::misc ; # Text formatting. +package require vc::fossil::import::cvs::project::rev ; # Project level changesets +package require vc::fossil::import::cvs::project::revlink ; # Cycle links. +package require vc::fossil::import::cvs::integrity ; # State integrity checks. + +# # ## ### ##### ######## ############# ##################### +## + +snit::type ::vc::fossil::import::cvs::cyclebreaker { + # # ## ### ##### ######## ############# + ## Public API + + typemethod precmd {cmd} { + ::variable myprecmd $cmd + return + } + + typemethod savecmd {cmd} { + ::variable mysavecmd $cmd + return + } + + typemethod breakcmd {cmd} { + ::variable mybreakcmd $cmd + return + } + + # # ## ### ##### ######## ############# + + typemethod dotsto {path} { + ::variable mydotdestination $path + return + } + + typemethod watch {id} { + ::variable mywatchids + lappend mywatchids $id + } + + typemethod dot {label changesets} { + ::variable mydotprefix $label + ::variable mydotid 0 + + set dg [Setup $changesets 0] + Mark $dg + $dg destroy + return + } + + typemethod mark {graph suffix {subgraph {}}} { + Mark $graph $suffix $subgraph + return + } + + # # ## ### ##### ######## ############# + + typemethod run {label changesetcmd} { + ::variable myat 0 + ::variable mydotprefix $label + ::variable mydotid 0 + + # We create a graph of the revision changesets, using the file + # level dependencies to construct a first approximation of the + # dependencies at the project level. Then we look for cycles + # in that graph and break them. + + # 1. Create nodes for all relevant changesets and a mapping + # from the revisions to their changesets/nodes. + + set changesets [uplevel #0 $changesetcmd] + set dg [Setup $changesets] + + # 3. Lastly we iterate the graph topologically. We mark off + # the nodes which have no predecessors, in order from + # oldest to youngest, saving and removing dependencies. If + # we find no nodes without predecessors we have a cycle, + # and work on breaking it. + + log write 3 cyclebreaker {Traverse changesets} + + InitializeCandidates $dg + + set k 0 + set max [llength [$dg nodes]] + while {1} { + while {[WithoutPredecessor $dg n]} { + log progress 2 cyclebreaker $k $max ; incr k + MarkWatch $dg + ProcessedHook $dg $n $myat + $dg node delete $n + incr myat + ShowPendingNodes + } + + if {![llength [$dg nodes]]} break + + BreakCycleHook $dg + InitializeCandidates $dg + MarkWatch $dg + } + + $dg destroy + + log write 3 cyclebreaker Done. + ClearHooks + + # Reread the graph and dump its final form, if graph export + # was activated. + + ::variable mydotdestination + if {$mydotdestination eq ""} return + + set dg [Setup [uplevel #0 $changesetcmd] 0] + Mark $dg -done + $dg destroy + return + } + + # # ## ### ##### ######## ############# + + typemethod break-segment {graph} { + BreakSegment $graph $path "segment ([project::rev strlist $path])" + return + } + + typemethod break {graph} { + set cycle [FindCycle $graph] + set label "cycle ([project::rev strlist $cycle])" + + # NOTE: cvs2svn uses the sequence "end-1, cycle, 0" to create + # the path from the cycle. The only effect I can see is + # that this causes the link-triples to be generated in a + # sightly different order, i.e. one link rotated to the + # right. This should have no effect on the search for + # the best of all. + + lappend cycle [lindex $cycle 0] [lindex $cycle 1] + BreakSegment $graph $cycle $label + return + } + + typemethod replace {graph n replacements} { + Replace $graph $n $replacements + return + } + + # # ## ### ##### ######## ############# + ## Internal methods + + proc Setup {changesets {log 1}} { + if {$log} { + log write 3 cyclebreaker "Creating graph of changesets" + } + + set dg [struct::graph dg] + + set n 0 + set max [llength $changesets] + + foreach cset $changesets { + log progress 2 cyclebreaker $n $max + set tr [$cset timerange] + $dg node insert $cset + $dg node set $cset timerange $tr + $dg node set $cset label "[$cset str]\\n[join [struct::list map $tr {::clock format}] "\\n"]" + $dg node set $cset __id__ [$cset id] + $dg node set $cset shape [expr {[$cset bysymbol] + ? "ellipse" + : "box"}] + incr n + } + + if {$log} { + log write 3 cyclebreaker "Has [nsp [llength $changesets] changeset]" + } + + # 2. Find for all relevant changeset their revisions and their + # dependencies. Map the latter back to changesets and + # construct the corresponding arcs. + + set n 0 + foreach cset $changesets { + log progress 2 cyclebreaker $n $max + foreach succ [$cset successors] { + # Changesets may have dependencies outside of the + # chosen set. These are ignored + if {![$dg node exists $succ]} continue + $dg arc insert $cset $succ + integrity assert { + $succ ne $cset + } {[$cset reportloop 0]Changeset loop was not detected during creation} + } + incr n + } + + if {$log} { + log write 3 cyclebreaker "Has [nsp [llength [$dg arcs]] dependency dependencies]" + } + + # Run the user hook to manipulate the graph before + # consummation. + + if {$log} { Mark $dg -start } + MarkWatch $dg + PreHook $dg + MarkWatch $dg + return $dg + } + + # Instead of searching the whole graph for the degree-0 nodes in + # each iteration we compute the list once to start, and then only + # update it incrementally based on the outgoing neighbours of the + # node chosen for commit. + + proc InitializeCandidates {dg} { + # bottom = list (list (node, range min, range max)) + ::variable mybottom + foreach n [$dg nodes] { + if {[$dg node degree -in $n]} continue + lappend mybottom [linsert [$dg node get $n timerange] 0 $n] + } + ScheduleCandidates + ShowPendingNodes + return + } + + proc WithoutPredecessor {dg nv} { + ::variable mybottom + + upvar 1 $nv n + if {![llength $mybottom]} { return 0 } + + set n [lindex [lindex $mybottom 0] 0] + set mybottom [lrange $mybottom 1 end] + set changed 0 + + # Update list of nodes without predecessor, based on the + # outgoing neighbours of the chosen node. This should be + # faster than iterating of the whole set of nodes, finding all + # without predecessors, sorting them by time, etc. pp. + foreach out [$dg nodes -out $n] { + if {[$dg node degree -in $out] > 1} continue + # Degree-1 neighbour, will have no predecessors after the + # removal of n. Put on the list. + lappend mybottom [linsert [$dg node get $out timerange] 0 $out] + set changed 1 + } + if {$changed} { + ScheduleCandidates + } + + # We do not delete the node immediately, to allow the Save + # procedure to save the dependencies as well (encoded in the + # arcs). + return 1 + } + + proc ScheduleCandidates {} { + ::variable mybottom + # Sort by cset object name, lower border of timerange, at last + # by the upper border. + set mybottom [lsort -index 2 -integer [lsort -index 1 -integer [lsort -index 0 -dict $mybottom]]] + return + } + + proc ShowPendingNodes {} { + if {[log verbosity?] < 10} return + ::variable mybottom + log write 10 cyclebreaker "Pending..............................." + foreach item [struct::list map $mybottom [myproc FormatPendingItem]] { + log write 10 cyclebreaker "Pending: $item" + } + return + } + + proc FormatPendingItem {item} { + join [list [[lindex $item 0] str] [clock format [lindex $item 1]] [clock format [lindex $item 2]]] + } + + proc FindCycle {dg} { + # This procedure is run if and only the graph is not empty and + # all nodes have predecessors. This means that each node is + # either part of a cycle or (indirectly) depending on a node + # in a cycle. We can start at an arbitrary node, follow its + # incoming edges to its predecessors until we see a node a + # second time. That node closes the cycle and the beginning is + # its first occurence. Note that we can choose an arbitrary + # predecessor of each node as well, we do not have to search. + + # We record for each node the index of the first appearance in + # the path, making it easy at the end to cut the cycle from + # it. + + # Choose arbitrary node to start our search at. + set start [lindex [$dg nodes] 0] + + # Initialize state, path of seen nodes, and when seen. + set path {} + array set seen {} + + while {1} { + # Stop searching when we have seen the current node + # already, the circle has been closed. + if {[info exists seen($start)]} break + lappend path $start + set seen($start) [expr {[llength $path]-1}] + # Choose arbitrary predecessor + set start [lindex [$dg nodes -in $start] 0] + } + + return [struct::list reverse [lrange $path $seen($start) end]] + } + + proc BreakSegment {dg path label} { + # The path, usually a cycle, we have gotten is broken by + # breaking apart one or more of the changesets in the + # cycle. This causes us to create one or more changesets which + # are to be committed, added to the graph, etc. pp. + + set bestlink {} + set bestnode {} + + foreach \ + prev [lrange $path 0 end-2] \ + cset [lrange $path 1 end-1] \ + next [lrange $path 2 end] { + + # Each triple PREV -> CSET -> NEXT of changesets, a + # 'link' in the cycle, is analysed and the best + # location where to at least weaken the cycle is + # chosen for further processing. + + set link [project::revlink %AUTO% $prev $cset $next] + if {$bestlink eq ""} { + set bestlink $link + set bestnode $cset + } elseif {[$link betterthan $bestlink]} { + $bestlink destroy + set bestlink $link + set bestnode $cset + } else { + $link destroy + } + } + + log write 5 cyclebreaker "Breaking $label by splitting changeset [$bestnode str]" + set ID [$bestnode id] + Mark $dg -${ID}-before + + set newcsets [$bestlink break] + $bestlink destroy + + # At this point the old changeset (BESTNODE) is gone + # already. We remove it from the graph as well and then enter + # the fragments generated for it. + + Replace $dg $bestnode $newcsets + + Mark $dg -${ID}-after + return + } + + # TODO: This should be a graph method. + proc HasArc {dg a b} { + #8.5: return [expr {$b in [$dg nodes -out $a]}] + if {[lsearch -exact [$dg nodes -out $a] $b] < 0} { return 0 } + return 1 + } + + proc Mark {dg {suffix {}} {subgraph {}}} { + ::variable mydotdestination + if {$mydotdestination eq ""} return + ::variable mydotprefix + ::variable mydotid + set fname $mydotdestination/${mydotprefix}${mydotid}${suffix}.dot + file mkdir [file dirname $fname] + dot write $dg $mydotprefix$suffix $fname $subgraph + incr mydotid + + log write 5 cyclebreaker ".dot export $fname" + return + } + + proc Replace {dg n replacements} { + # NOTE. We have to get the list of incoming neighbours and + # recompute their successors after the new nodes have been + # inserted. Their outgoing arcs will now go to one or both of + # the new nodes, and not redoing them may cause us to forget + # circles, leaving them in, unbroken. + + set pre [$dg nodes -in $n] + + $dg node delete $n + + foreach cset $replacements { + set tr [$cset timerange] + $dg node insert $cset + $dg node set $cset timerange $tr + $dg node set $cset label "[$cset str]\\n[join [struct::list map $tr {::clock format}] "\\n"]" + $dg node set $cset __id__ [$cset id] + $dg node set $cset shape [expr {[$cset bysymbol] + ? "ellipse" + : "box"}] + } + + foreach cset $replacements { + foreach succ [$cset successors] { + # The new changesets may have dependencies outside of + # the chosen set. These are ignored + if {![$dg node exists $succ]} continue + $dg arc insert $cset $succ + integrity assert { + $succ ne $cset + } {[$cset reportloop 0]Changeset loop was not detected during creation} + } + } + foreach cset $pre { + foreach succ [$cset successors] { + # Note that the arc may already exist in the graph. If + # so ignore it. The new changesets may have + # dependencies outside of the chosen set. These are + # ignored + if {![$dg node exists $succ]} continue + if {[HasArc $dg $cset $succ]} continue;# TODO should be graph method. + $dg arc insert $cset $succ + } + } + + return + } + + # # ## ### ##### ######## ############# + ## Callback invokation ... + + proc PreHook {graph} { + # Give the user of the cycle breaker the opportunity to work + # with the graph between setup and consummation. + + ::variable myprecmd + if {![llength $myprecmd]} return + + uplevel #0 [linsert $myprecmd end $graph] + Mark $graph -pre-done + return + } + + proc ProcessedHook {dg cset pos} { + # Give the user of the cycle breaker the opportunity to work + # with the changeset before it is removed from the graph. + + ::variable mysavecmd + if {![llength $mysavecmd]} return + + uplevel #0 [linsert $mysavecmd end $dg $pos $cset] + return + } + + proc BreakCycleHook {graph} { + # Call out to the chosen algorithm for cycle breaking. Finding + # a cycle if no breaker was chosen is an error. + + ::variable mybreakcmd + if {![llength $mybreakcmd]} { + trouble fatal "Found a cycle, expecting none." + exit 1 + } + + uplevel #0 [linsert $mybreakcmd end $graph] + return + } + + proc ClearHooks {} { + ::variable myprecmd {} + ::variable mysavecmd {} + ::variable mybreakcmd {} + return + } + + # # ## ### ##### ######## ############# + + proc MarkWatch {graph} { + ::variable mywatchids + set watched [Watched $graph $mywatchids] + if {![llength $watched]} return + set neighbours [eval [linsert $watched 0 $graph nodes -adj]] + #foreach n $neighbours { log write 6 cyclebreaker "Neighbor [$n id] => $n" } + Mark $graph watched [concat $watched $neighbours] + return + } + + proc Watched {graph watchids} { + set res {} + foreach id $watchids { + set nl [$graph nodes -key __id__ -value $id] + if {![llength $nl]} continue + lappend res $nl + #log write 6 breakrcycle "Watching $id => $nl" + $graph node set $nl fontcolor red + } + return $res + } + + # # ## ### ##### ######## ############# + + + typevariable myat 0 ; # Counter for commit ids for the + # changesets. + typevariable mybottom {} ; # List of the candidate nodes for + # committing. + + typevariable myprecmd {} ; # Callback, change graph before walk. + typevariable mysavecmd {} ; # Callback, for each processed node. + typevariable mybreakcmd {} ; # Callback, for each found cycle. + + typevariable mydotdestination {} ; # Destination directory for the + # generated .dot files. + typevariable mydotprefix {} ; # Prefix for dot files when + # exporting the graphs. + typevariable mydotid 0 ; # Counter for dot file name + # generation. + typevariable mywatchids {} ; # Changesets to watch the + # neighbourhood of. + + # # ## ### ##### ######## ############# + ## Configuration + + pragma -hasinstances no ; # singleton + pragma -hastypeinfo no ; # no introspection + pragma -hastypedestroy no ; # immortal + + # # ## ### ##### ######## ############# +} + +namespace eval ::vc::fossil::import::cvs { + namespace export cyclebreaker + namespace eval cyclebreaker { + namespace import ::vc::fossil::import::cvs::integrity + namespace eval project { + namespace import ::vc::fossil::import::cvs::project::rev + namespace import ::vc::fossil::import::cvs::project::revlink + } + namespace import ::vc::tools::misc::* + namespace import ::vc::tools::log + namespace import ::vc::tools::trouble + namespace import ::vc::tools::dot + log register cyclebreaker + } +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide vc::fossil::import::cvs::cyclebreaker 1.0 +return diff --git a/tools/cvs2fossil/lib/c2f_file.tcl b/tools/cvs2fossil/lib/c2f_file.tcl new file mode 100644 index 0000000..a113698 --- /dev/null +++ b/tools/cvs2fossil/lib/c2f_file.tcl @@ -0,0 +1,1452 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2007-2008 Andreas Kupries. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## File, part of a project, part of a CVS repository. Multiple +## instances are possible. + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.4 ; # Required runtime. +package require snit ; # OO system. +package require struct::set ; # Set operations. +package require struct::list ; # Higher order operations. +package require vc::fossil::import::cvs::blobstore ; # Blob storage. +package require vc::fossil::import::cvs::file::rev ; # CVS per file revisions. +package require vc::fossil::import::cvs::file::sym ; # CVS per file symbols. +package require vc::fossil::import::cvs::state ; # State storage. +package require vc::fossil::import::cvs::integrity ; # State integrity checks. +package require vc::fossil::import::cvs::gtcore ; # Graph traversal core. +package require vc::tools::trouble ; # Error reporting. +package require vc::tools::log ; # User feedback +package require vc::tools::misc ; # Text formatting + +# # ## ### ##### ######## ############# ##################### +## + +snit::type ::vc::fossil::import::cvs::file { + # # ## ### ##### ######## ############# + ## Public API + + constructor {id path usrpath executable project} { + set myid $id + set mypath $path + set myusrpath $usrpath + set myexecutable $executable + set myproject $project + set mytrunk [$myproject trunk] + set myblob [blobstore ${selfns}::%AUTO% $id] + return + } + + method setid {id} { + integrity assert {$myid eq ""} {File '$mypath' already has an id, '$myid'} + set myid $id + $myblob setid $id + return + } + + method id {} { return $myid } + method path {} { return $mypath } + method usrpath {} { return $myusrpath } + method project {} { return $myproject } + + delegate method commitmessageof to myproject + + # # ## ### ##### ######## ############# + ## Methods required for the class to be a sink of the rcs parser + + #method begin {} {puts begin} + #method sethead {h} {puts head=$h} + #method setprincipalbranch {b} {puts pb=$b} + #method deftag {s r} {puts $s=$r} + #method setcomment {c} {puts comment=$c} + #method admindone {} {puts admindone} + #method def {rev date author state next branches} {puts "def $rev $date $author $state $next $branches"} + #method defdone {} {puts def-done} + #method setdesc {d} {puts desc=$d} + #method extend {rev commitmsg deltarange} {puts "extend $commitmsg $deltarange"} + #method done {} {puts done} + + # # ## ### ##### ######## ############# + ## Persistence (pass II) + + method persist {} { + # First collect the reachable revisions and symbols, then + # assign id's to all. They are sorted so that we will have ids + # which sort in order of creation. Then we can save them. This + # is done bottom up. Revisions, then symbols. __NOTE__ This + # works only because sqlite is not checking foreign key + # references during insert. This allows to have dangling + # references which are fixed later. The longest dangling + # references are for the project level symbols, these we do + # not save here, but at the end of the pass. What we need are + # the ids, hence the two phases. + + struct::list assign [$self Active] revisions symbols + foreach rev $revisions { $rev defid } + foreach sym $symbols { $sym defid } + + state transaction { + foreach rev $revisions { $rev persist } + foreach sym $symbols { $sym persist } + $myblob persist + } + return + } + + method drop {} { + foreach {_ rev} [array get myrev] { $rev destroy } + foreach {_ branch} [array get mybranches] { $branch destroy } + foreach {_ taglist} [array get mytags] { + foreach tag $taglist { $tag destroy } + } + return + } + + # # ## ### ##### ######## ############# + ## Implement the sink + + method begin {} {#ignore} + + method sethead {revnr} { + set myheadrevnr $revnr + return + } + + method setprincipalbranch {branchnr} { + set myprincipal $branchnr + return + } + + method deftag {name revnr} { + # FUTURE: Perform symbol transformation here. + + if {[struct::set contains $mysymbols $name]} { + trouble fatal "Multiple definitions of the symbol '$name' in '$mypath'" + return + } + + struct::set add mysymbols $name + + if {[rev isbranchrevnr $revnr -> branchnr]} { + $self AddBranch $name $branchnr + } else { + $self AddTag $name $revnr + } + return + } + + method setcomment {c} {# ignore} + + method admindone {} { + # We do nothing at the boundary of admin and revision data + } + + method def {revnr date author state next branches} { + $self RecordBranchCommits $branches + + if {[info exists myrev($revnr)]} { + trouble fatal "File $mypath contains duplicate definitions for revision $revnr." + return + } + + set myaid($revnr) [$myproject defauthor $author] + set myrev($revnr) [rev %AUTO% $revnr $date $state $self] + + $myblob add $revnr $myrev($revnr) + + if {$next ne ""} { + # parent revision NEXT is a delta of current. + $myblob delta $next $revnr + } + foreach b $branches { + # branch child revision B is a delta of current. + $myblob delta $b $revnr + } + + $self RecordBasicDependencies $revnr $next + return + } + + method defdone {} { + # This is all done after the revision tree has been extracted + # from the file, before the commit mesages and delta texts are + # processed. + + $self ProcessPrimaryDependencies + $self ProcessBranchDependencies + $self SortBranches + $self ProcessTagDependencies + $self DetermineTheRootRevision + return + } + + method setdesc {d} {# ignore} + + method extend {revnr commitmsg textrange} { + set cmid [$myproject defcmessage [string trim $commitmsg]] + + set rev $myrev($revnr) + + if {[$rev hasmeta]} { + # Apparently repositories exist in which the delta data + # for revision 1.1 is provided several times, at least + # twice. The actual cause of this duplication is not + # known. Speculation centers on RCS/CVS bugs, or from + # manual edits of the repository which borked the + # internals. Whatever the cause, testing showed that both + # cvs and rcs use the first definition when performing a + # checkout, and we follow their lead. Side notes: 'cvs + # log' fails on such a file, and 'cvs rlog' prints the log + # message from the first delta, ignoring the second. + + log write 1 file "In file $mypath : Duplicate delta data for revision $revnr" + log write 1 file "Ignoring the duplicate" + return + } + + # Determine the line of development for the revision (project + # level). This gives us the branchid too, required for the + # meta data group the revision is in. (Note: By putting both + # branch/lod and project information into the group we ensure + # that any cross-project and cross-branch commits are + # separated into multiple commits, one in each of the projects + # and/or branches). + + set lod [$self GetLOD $revnr] + + $rev setmeta [$myproject defmeta [$lod id] $myaid($revnr) $cmid] + # Note: We keep settext on file::rev for the hastext queries + # used by several checks. + $rev settext $textrange + $rev setlod $lod + + $myblob extend $revnr $textrange + + # If this is revision 1.1, we have to determine whether the + # file seems to have been created through 'cvs add' instead of + # 'cvs import'. This can be done by looking at the un- + # adulterated commit message, as CVS uses a hardwired magic + # message for the latter, i.e. "Initial revision\n", no + # period. (This fact also helps us when the time comes to + # determine whether this file might have had a default branch + # in the past.) + + if {$revnr eq "1.1"} { + set myimported [expr {$commitmsg eq "Initial revision\n"}] + } + + # Here we also keep track of the order in which the revisions + # were added to the file. + + lappend myrevisions $rev + return + } + + method done {} { + # Complete the revisions, branches, and tags. This includes + # looking for a non-trunk default branch, marking its members + # and linking them into the trunk, possibly excluding + # non-trunk data, and collecting aggregate symbol statistics. + + $self DetermineRevisionOperations + $self DetermineLinesOfDevelopment + $self HandleNonTrunkDefaultBranch + $self RemoveIrrelevantDeletions + $self RemoveInitialBranchDeletions + + if {[$myproject trunkonly]} { + $self ExcludeNonTrunkInformation + } + + $self AggregateSymbolData + return + } + + # # ## ### ##### ######## ############# + ## Pass XII (Import). + + method pushto {repository} { + log write 2 file {Importing file "$mypath"} + + set ws [$repository workspace] + struct::list assign [$self Expand $ws] filemap revmap + # filemap = dict (path -> uuid) + # revmap = dict (path -> rid) + + array set idmap [$repository importfiles $filemap] + + # Wipe workspace clean of the imported files. + foreach x [glob -directory $ws r*] { ::file delete $x } + + foreach {path rid} $revmap { + set uuid $idmap($path) + state run { + INSERT INTO revuuid (rid, uuid) + VALUES ($rid, $uuid) + } + } + return + } + + method Expand {dir} { + set ex [struct::graph ex] ; # Expansion graph. + set zp [struct::graph zp] ; # Zip/Import graph. + + close [open $dir/r__empty__ w];# Base for detached roots on branches. + + # Phase I: Pull blobs and referenced revisions from the state + # and fill the graphs with them... + + # Note: We use the blobs for expansion because we need them + # all, even those without revision, for both proper + # ordering and exact patch application. + + set earcs {} ; # Arcs for expansion graph + set zarcs {} ; # Arcs for zip graph + set revmap {} ; # path -> rid map to later merge uuid information + + state foreachrow { + SELECT B.rid AS xrid, + R.rev AS revnr, + R.child AS xchild, + B.coff AS xcoff, + B.clen AS xclen, + B.bid AS cid, + B.pid AS cparent + FROM blob B + LEFT OUTER JOIN revision R + ON B.rid = R.rid + WHERE B.fid = $myid + } { + # Main data are blobs, most will have revisions, but not + # all. The expansion graph is blob based, whereas the + # recompression graph is revision based. + + if {$revnr ne ""} { + # Blob has revision, extend recompression graph. + + lappend revmap r$revnr $xrid + + $zp node insert $xrid + $zp node set $xrid revnr $revnr + $zp node set $xrid label <$revnr> + + if {$xchild ne ""} { + lappend zarcs $xchild $xrid + } + } else { + # We fake a revnr for the blobs which have no + # revision, for use in the expansion graph. + set revnr ghost$cid + } + + # Now the expansion graph. + + $ex node insert $cid + $ex node set $cid text [list $xcoff $xclen] + $ex node set $cid revnr $revnr + $ex node set $cid label <$revnr> + + if {$cparent ne ""} { + # The expansion arcs go from baseline to delta + # descendant, based on the blob information. + lappend earcs $cparent $cid + } + } + + # Phase II: Insert the accumulated dependencies + + foreach {from to} $earcs { $ex arc insert $from $to } + foreach {from to} $zarcs { $zp arc insert $from $to } + + # Phase III: Traverse the graphs, expand the file, and + # generate import instructions. + + set archive [::file join [$myproject fullpath] $mypath] + set ac [open $archive r] + fconfigure $ac -translation binary + + # First traverse the expansion graph, this gives us the + # revisions in the order we have to expand them, which we do. + + set max [llength [$ex nodes]] + set myimport 0 + + gtcore datacmd [mymethod ExpandData] + gtcore formatcmd [mymethod ExpandFormat] + gtcore sortcmd [mymethod ExpandSort] + gtcore savecmd [mymethod Expand1 $ac $dir $max] + + gtcore traverse $ex {Expanding revisions...} + close $ac + + # Now traverse the import graph, this builds the instruction + # map for the fossil deltas. + + gtcore datacmd [mymethod ExpandData] + gtcore formatcmd [mymethod ExpandFormat] + gtcore sortcmd [mymethod ExpandSort] + gtcore savecmd [mymethod Expand2] + + set myimport {} + gtcore traverse $zp {Generating revision order for import...} + set filemap $myimport + unset myimport + + # And back to import control + + $ex destroy + $zp destroy + + return [list $filemap $revmap] + } + + method ExpandData {graph node} { return [$graph node get $node revnr] } + method ExpandFormat {graph item} { return <[lindex $item 1]> } ; # revnr + method ExpandSort {graph candidates} { + # candidates = list(item), item = list(node revnr) + # Sort by node and revnr -> Trunk revisions come first. + return [lsort -index 1 -dict [lsort -index 0 -dict $candidates]] + } + method Expand1 {chan dir max graph node} { + log progress 3 file $myimport $max ; incr myimport + + set revnr [$graph node get $node revnr] + set fname r$revnr + struct::list assign [$graph node get $node text] offset length + + if {$length < 0} { + set data "" + } else { + seek $chan $offset start + set data [string map {@@ @} [read $chan $length]] + } + + if {![$graph node keyexists $node __base__]} { + # Full text node. Get the data, decode it, and save. + + log write 8 file {Expanding <$revnr>, full text} + + fileutil::writeFile -translation binary $dir/$fname $data + } else { + # Delta node. __base__ is the name of the file containing + # the baseline. The patch is at the specified location of + # the archive file. + + set fbase [$graph node get $node __base__] + log write 8 file {Expanding <$revnr>, is delta of <$fbase>} + + set base [fileutil::cat -translation binary $dir/$fbase] + + # Writing the patch to disk is just for better + # debugging. It is not used otherwise. + fileutil::writeFile $dir/rpatch $data + fileutil::writeFile -translation binary $dir/$fname \ + [Apply $base $data] + } + + # Post to all successors that the just generated file is their + # baseline. + + foreach out [$graph nodes -out $node] { + $graph node set $out __base__ $fname + } + return + } + + proc Apply {base delta} { + # base = base text. + # delta = delta in rcs format. + # + # Both strings are unencoded, i.e. things like @@, etc. have + # already been replaced with their proper characters. + # + # Return value is the patched text. + + set base [split $base \n] + set blen [llength $base] + set ooff 0 + set res "" + + set lines [split $delta \n] + set nlines [llength $lines] + + log write 11 file {Base lines = $blen} + log write 11 file {Delta lines = $nlines} + + for {set i 0} {$i < $nlines} {} { + log write 11 file { @ $i = [lindex $lines $i]} + log write 11 file { ooff $ooff} + + if {![regexp {^([ad])(\d+)\s(\d+)$} [lindex $lines $i] -> cmd sl cn]} { + trouble internal "Bad ed command '[lindex $lines $i]'" + } + + log write 11 file { cmd $cmd} + log write 11 file { sl $sl} + log write 11 file { cn $cn} + + incr i + set el [expr {$sl + $cn}] + + log write 11 file { el $el} + + switch -exact -- $cmd { + d { + incr sl -1 + incr el -1 + if {$sl < $ooff} { trouble internal {Deletion before last edit} } + if {$sl > $blen} { trouble internal {Deletion past file end} } + if {$el > $blen} { trouble internal {Deletion beyond file end} } + foreach x [lrange $base $ooff [expr {$sl - 1}]] { + log write 15 file {.|$x|} + lappend res $x + } + set ooff $el + } + a { + if {$sl < $ooff} { trouble internal {Insert before last edit} } + if {$sl > $blen} { trouble internal {Insert past file end} } + + foreach x [lrange $base $ooff [expr {$sl - 1}]] { + log write 15 file {.|$x|} + lappend res $x + } + foreach x [lrange $lines $i [expr {$i + $cn - 1}]] { + log write 15 file {+|$x|} + lappend res $x + } + set ooff $sl + incr i $cn + } + } + } + foreach x [lrange $base $ooff end] { lappend res $x } + return [join $res \n] + } + + method Expand2 {graph node} { + set revnr [$graph node get $node revnr] + + # First import the file. + lappend myimport [list A r$revnr {}] + + if {[$graph node keyexists $node __base__]} { + # Delta node. __base__ is the name of the file containing + # the baseline. Generate instruction to make the delta as + # well. + + set fbase [$graph node get $node __base__] + lappend myimport [list D r$revnr r$fbase] + } + + # Post to all successors that the just generated file is their + # baseline. Exception: Those which ave already a baseline set. + # Together with the sorting of trunk revisions first the trunk + # should one uninterupted line, with branch roots _not_ delta + # compressed per their branches. + + foreach out [$graph nodes -out $node] { + if {[$graph node keyexists $out __base__]} continue + $graph node set $out __base__ $revnr + } + return + } + + variable myimport + + # # ## ### ##### ######## ############# + ## State + + variable myid {} ; # File id in the persistent state. + variable mypath {} ; # Path of the file's rcs archive. + variable myusrpath {} ; # Path of the file as seen by users. + variable myexecutable 0 ; # Boolean flag 'file executable'. + variable myproject {} ; # Reference to the project object + # the file belongs to. + variable myrev -array {} ; # Maps revision number to the + # associated revision object. + variable myrevisions {} ; # Same as myrev, but a list, + # giving us the order of + # revisions. + variable myaid -array {} ; # Map revision numbers to the id + # of the author who committed + # it. This is later aggregated + # with commit message, branch name + # and project id for a meta id. + variable myheadrevnr {} ; # Head revision (revision number) + variable myprincipal {} ; # Principal branch (branch number). + # Contrary to the name this is the + # default branch. + variable mydependencies {} ; # Dictionary parent -> child, + # records primary dependencies. + variable myimported 0 ; # Boolean flag. Set if and only if + # rev 1.1 of the file seemingly + # was imported instead of added + # normally. + variable myroot {} ; # Reference to the revision object + # holding the root revision. Its + # number usually is '1.1'. Can be + # a different number, because of + # gaps created via 'cvsadmin -o'. + variable mybranches -array {} ; # Maps branch number to the symbol + # object handling the branch. + variable mytags -array {} ; # Maps revision number to the list + # of symbol objects for the tags + # associated with the revision. + variable mysymbols {} ; # Set of the symbol names found in + # this file. + + variable mybranchcnt 0 ; # Counter for branches, to record their + # order of definition. This also defines + # their order of creation, which is the + # reverse of definition. I.e. a smaller + # number means 'Defined earlier', means + # 'Created later'. + + variable mytrunk {} ; # Direct reference to myproject -> trunk. + variable myroots {} ; # List of roots in the forest of + # lod's. Object references to revisions and + # branches. The latter can appear when they + # are severed from their parent. + + variable myblob {} ; # Reference to the object managing the blob + # information (textrange of revisions, and + # delta dependencies) of this file. + + # # ## ### ##### ######## ############# + ## Internal methods + + method RecordBranchCommits {branches} { + foreach branchrevnr $branches { + if {[catch { + set branch [$self Rev2Branch $branchrevnr] + }]} { + set branch [$self AddUnlabeledBranch [rev 2branchnr $branchrevnr]] + } + + # Record the commit, just as revision number for + # now. ProcesBranchDependencies will extend that ito a + # proper object reference. + + $branch setchildrevnr $branchrevnr + } + return + } + + method Rev2Branch {revnr} { + integrity assert {![rev istrunkrevnr $revnr]} {Expected a branch revision number} + return $mybranches([rev 2branchnr $revnr]) + } + + method AddUnlabeledBranch {branchnr} { + return [$self AddBranch unlabeled-$branchnr $branchnr] + } + + method AddBranch {name branchnr} { + if {[info exists mybranches($branchnr)]} { + log write 1 file "In '$mypath': Branch '$branchnr' named '[$mybranches($branchnr) name]'" + log write 1 file "Cannot have second name '$name', ignoring it" + return + } + set branch [sym %AUTO% branch $branchnr [$myproject getsymbol $name] $self] + $branch setposition [incr mybranchcnt] + set mybranches($branchnr) $branch + return $branch + } + + method AddTag {name revnr} { + set tag [sym %AUTO% tag $revnr [$myproject getsymbol $name] $self] + lappend mytags($revnr) $tag + return $tag + } + + method RecordBasicDependencies {revnr next} { + # Handle the revision dependencies. Record them for now, do + # nothing with them yet. + + # On the trunk the 'next' field points to the previous + # revision, i.e. the _parent_ of the current one. Example: + # 1.6's next is 1.5 (modulo cvs admin -o). + + # Contrarily on a branch the 'next' field points to the + # primary _child_ of the current revision. As example, + # 1.1.3.2's 'next' will be 1.1.3.3. + + # The 'next' field actually always refers to the revision + # containing the delta needed to retrieve that revision. + + # The dependencies needed here are the logical structure, + # parent/child, and not the implementation dependent delta + # pointers. + + if {$next eq ""} return + # parent -> child + if {[rev istrunkrevnr $revnr]} { + lappend mydependencies $next $revnr + } else { + lappend mydependencies $revnr $next + } + return + } + + method ProcessPrimaryDependencies {} { + foreach {parentrevnr childrevnr} $mydependencies { + set parent $myrev($parentrevnr) + set child $myrev($childrevnr) + $parent setchild $child + $child setparent $parent + } + return + } + + method ProcessBranchDependencies {} { + foreach {branchnr branch} [array get mybranches] { + set revnr [$branch parentrevnr] + + if {![info exists myrev($revnr)]} { + log write 1 file "In '$mypath': The branch '[$branch name]' references" + log write 1 file "the bogus revision '$revnr' and will be ignored." + $branch destroy + unset mybranches($branchnr) + } else { + set rev $myrev($revnr) + $rev addbranch $branch + $branch setparent $rev + + # If revisions were committed on the branch we store a + # reference to the branch there, and further declare + # the first child's parent to be branch's parent, and + # list this child in the parent revision. + + if {[$branch haschildrev]} { + set childrevnr [$branch childrevnr] + set child $myrev($childrevnr) + $branch setchild $child + + $child setparentbranch $branch + $child setparent $rev + $rev addchildonbranch $child + } + } + } + return + } + + method SortBranches {} { + foreach {revnr rev} [array get myrev] { $rev sortbranches } + return + } + + method ProcessTagDependencies {} { + foreach {revnr taglist} [array get mytags] { + if {![info exists myrev($revnr)]} { + set n [llength $taglist] + log write 1 file "In '$mypath': The following [nsp $n tag] reference" + log write 1 file "the bogus revision '$revnr' and will be ignored." + foreach tag $taglist { + log write 1 file " [$tag name]" + $tag destroy + } + unset mytags($revnr) + } else { + set rev $myrev($revnr) + foreach tag $taglist { + $rev addtag $tag + $tag settagrev $rev + } + } + } + return + } + + method DetermineTheRootRevision {} { + # The root is the one revision which has no parent. By + # checking all revisions we ensure that we can detect and + # report the case of multiple roots. Without that we could + # simply take one revision and follow the parent links to + # their root (sic!). + + foreach {revnr rev} [array get myrev] { + if {[$rev hasparent]} continue + integrity assert {$myroot eq ""} {Multiple root revisions found} + set myroot $rev + } + + # In the future we also need a list, as branches can become + # severed from their parent, making them their own root. + set myroots [list $myroot] + return + } + + method DetermineRevisionOperations {} { + foreach rev $myrevisions { $rev determineoperation } + return + } + + method DetermineLinesOfDevelopment {} { + # For revisions this has been done already, in 'extend'. Now + # we do this for the branches and tags. + + foreach {_ branch} [array get mybranches] { + $branch setlod [$self GetLOD [$branch parentrevnr]] + } + + foreach {_ taglist} [array get mytags] { + foreach tag $taglist { + $tag setlod [$self GetLOD [$tag tagrevnr]] + } + } + return + } + + method GetLOD {revnr} { + if {[rev istrunkrevnr $revnr]} { + return $mytrunk + } else { + return [$self Rev2Branch $revnr] + } + } + + method HandleNonTrunkDefaultBranch {} { + set revlist [$self NonTrunkDefaultRevisions] + if {![llength $revlist]} return + + $self AdjustNonTrunkDefaultBranch $revlist + $self CheckLODs + return + } + + method NonTrunkDefaultRevisions {} { + # From cvs2svn the following explanation (with modifications + # for our algorithm): + + # Determine whether there are any non-trunk default branch + # revisions. + + # If a non-trunk default branch is determined to have existed, + # return a list of objects for all revisions that were once + # non-trunk default revisions, in dependency order (i.e. root + # first). + + # There are two cases to handle: + + # One case is simple. The RCS file lists a default branch + # explicitly in its header, such as '1.1.1'. In this case, we + # know that every revision on the vendor branch is to be + # treated as head of trunk at that point in time. + + # But there's also a degenerate case. The RCS file does not + # currently have a default branch, yet we can deduce that for + # some period in the past it probably *did* have one. For + # example, the file has vendor revisions 1.1.1.1 -> 1.1.1.96, + # all of which are dated before 1.2, and then it has 1.1.1.97 + # -> 1.1.1.100 dated after 1.2. In this case, we should + # record 1.1.1.96 as the last vendor revision to have been the + # head of the default branch. + + if {$myprincipal ne ""} { + # There is still a default branch; that means that all + # revisions on that branch get marked. + + log write 5 file "Found explicitly marked NTDB" + + set rnext [$myroot child] + if {$rnext ne ""} { + trouble fatal "File with default branch $myprincipal also has revision [$rnext revnr]" + return + } + + set rev [$mybranches($myprincipal) child] + set res {} + + while {$rev ne ""} { + lappend res $rev + set rev [$rev child] + } + + return $res + + } elseif {$myimported} { + # No default branch, but the file appears to have been + # imported. So our educated guess is that all revisions + # on the '1.1.1' branch with timestamps prior to the + # timestamp of '1.2' were non-trunk default branch + # revisions. + + # This really only processes standard '1.1.1.*'-style + # vendor revisions. One could conceivably have a file + # whose default branch is 1.1.3 or whatever, or was that + # at some point in time, with vendor revisions 1.1.3.1, + # 1.1.3.2, etc. But with the default branch gone now, + # we'd have no basis for assuming that the non-standard + # vendor branch had ever been the default branch anyway. + + # Note that we rely on comparisons between the timestamps + # of the revisions on the vendor branch and that of + # revision 1.2, even though the timestamps might be + # incorrect due to clock skew. We could do a slightly + # better job if we used the changeset timestamps, as it is + # possible that the dependencies that went into + # determining those timestamps are more accurate. But + # that would require an extra pass or two. + + if {![info exists mybranches(1.1.1)]} { return {} } + + log write 5 file "Deduced existence of NTDB" + + set rev [$mybranches(1.1.1) child] + set res {} + set stop [$myroot child] + + if {$stop eq ""} { + # Get everything on the branch + while {$rev ne ""} { + lappend res $rev + set rev [$rev child] + } + } else { + # Collect everything on the branch which seems to have + # been committed before the first primary child of the + # root revision. + set stopdate [$stop date] + while {$rev ne ""} { + if {[$rev date] >= $stopdate} break + lappend res $rev + set rev [$rev child] + } + } + + return $res + + } else { + return {} + } + } + + # General note: In the following methods we only modify the links + # between revisions and symbols to restructure the revision + # tree. We do __not__ destroy the objects. Given the complex links + # GC is difficult at this level. It is much easier to drop + # everything when we we are done. This happens in 'drop', using + # the state variable 'myrev', 'mybranches', and 'mytags'. What we + # have to persist, performed by 'persist', we know will be + # reachable through the revisions listed in 'myroots' and their + # children and symbols. + + method AdjustNonTrunkDefaultBranch {revlist} { + set stop [$myroot child] ;# rev '1.2' + + log write 5 file "Adjusting NTDB containing [nsp [llength $revlist] revision]" + + # From cvs2svn the following explanation (with modifications + # for our algorithm): + + # Adjust the non-trunk default branch revisions found in the + # 'revlist'. + + # 'myimported' is a boolean flag indicating whether this file + # appears to have been imported, which also means that + # revision 1.1 has a generated log message that need not be + # preserved. 'revlist' is a list of object references for the + # revisions that have been determined to be non-trunk default + # branch revisions. + + # Note that the first revision on the default branch is + # handled strangely by CVS. If a file is imported (as opposed + # to being added), CVS creates a 1.1 revision, then creates a + # vendor branch 1.1.1 based on 1.1, then creates a 1.1.1.1 + # revision that is identical to the 1.1 revision (i.e., its + # deltatext is empty). The log message that the user typed + # when importing is stored with the 1.1.1.1 revision. The 1.1 + # revision always contains a standard, generated log message, + # 'Initial revision\n'. + + # When we detect a straightforward import like this, we want + # to handle it by deleting the 1.1 revision (which doesn't + # contain any useful information) and making 1.1.1.1 into an + # independent root in the file's dependency tree. In SVN, + # 1.1.1.1 will be added directly to the vendor branch with its + # initial content. Then in a special 'post-commit', the + # 1.1.1.1 revision is copied back to trunk. + + # If the user imports again to the same vendor branch, then CVS + # creates revisions 1.1.1.2, 1.1.1.3, etc. on the vendor branch, + # *without* counterparts in trunk (even though these revisions + # effectively play the role of trunk revisions). So after we add + # such revisions to the vendor branch, we also copy them back to + # trunk in post-commits. + + # We mark the revisions found in 'revlist' as default branch + # revisions. Also, if the root revision has a primary child + # we set that revision to depend on the last non-trunk default + # branch revision and possibly adjust its type accordingly. + + set first [lindex $revlist 0] + + log write 6 file "<[$first revnr]> [expr {$myimported ? "imported" : "not imported"}], [$first operation], [expr {[$first hastext] ? "has text" : "no text"}]" + + if {$myimported && + [$first revnr] eq "1.1.1.1" && + [$first operation] eq "change" && + ![$first hastext]} { + + set rev11 [$first parent] ; # Assert: Should be myroot. + log write 3 file "Removing irrelevant revision [$rev11 revnr]" + + # Cut out the old myroot revision. + + ldelete myroots $rev11 ; # Not a root any longer. + + $first cutfromparent ; # Sever revision from parent revision. + if {$stop ne ""} { + $stop cutfromparent + lappend myroots $stop ; # New root, after vendor branch + } + + # Cut out the vendor branch symbol + + set vendor [$first parentbranch] + integrity assert {$vendor ne ""} {First NTDB revision has no branch} + if {[$vendor parent] eq $rev11} { + $rev11 removebranch $vendor + $rev11 removechildonbranch $first + $vendor cutbranchparent ;# bp = rev11, about to be gone + $first cutfromparentbranch ;# pb = vendor, to be a detached LOD + lappend myroots $first + } + + # Change the type of first (typically from Change to Add): + $first retype add + + # Move any tags and branches from the old to the new root. + $rev11 movesymbolsto $first + } + + # Mark all the special revisions as such + foreach rev $revlist { + log write 3 file "Revision on default branch: [$rev revnr]" + $rev setondefaultbranch 1 + } + + if {$stop ne ""} { + # Revision 1.2 logically follows the imported revisions, + # not 1.1. Accordingly, connect it to the last NTDBR and + # possibly change its type. + + set last [lindex $revlist end] + $stop setdefaultbranchparent $last ; # Retypes the revision too. + $last setdefaultbranchchild $stop + } + return + } + + method CheckLODs {} { + foreach {_ branch} [array get mybranches] { $branch checklod } + foreach {_ taglist} [array get mytags] { + foreach tag $taglist { $tag checklod } + } + return + } + + method RemoveIrrelevantDeletions {} { + # From cvs2svn: If a file is added on a branch, then a trunk + # revision is added at the same time in the 'Dead' state. + # This revision doesn't do anything useful, so delete it. + + foreach root $myroots { + if {[$root isneeded]} continue + log write 2 file "Removing unnecessary dead revision [$root revnr]" + + # Remove as root, make its child new root after + # disconnecting it from the revision just going away. + + ldelete myroots $root + if {[$root haschild]} { + set child [$root child] + $child cutfromparent + lappend myroots $child + } + + # Cut out the branches spawned by the revision to be + # deleted. If the branch has revisions they should already + # use operation 'add', no need to change that. The first + # revision on each branch becomes a new and disconnected + # root. + + foreach branch [$root branches] { + $branch cutbranchparent + if {![$branch haschild]} continue + set first [$branch child] + $first cutfromparent + lappend myroots $first + } + $root removeallbranches + + # Tagging a dead revision doesn't do anything, so remove + # any tags that were set on it. + + $root removealltags + + # This can only happen once per file, and we might have + # just changed myroots, so end the loop + break + } + return + } + + method RemoveInitialBranchDeletions {} { + # From cvs2svn: If the first revision on a branch is an + # unnecessary delete, remove it. + # + # If a file is added on a branch (whether or not it already + # existed on trunk), then new versions of CVS add a first + # branch revision in the 'dead' state (to indicate that the + # file did not exist on the branch when the branch was + # created) followed by the second branch revision, which is an + # add. When we encounter this situation, we sever the branch + # from trunk and delete the first branch revision. + + # At this point we may have already multiple roots in myroots, + # we have to process them all. + + foreach root [$self LinesOfDevelopment] { + if {[$root isneededbranchdel]} continue + log write 2 file "Removing unnecessary initial branch delete [$root revnr]" + + set branch [$root parentbranch] + set parent [$root parent] + set child [$root child] + + ldelete myroots $root + lappend myroots $child + + $branch cutbranchparent + $branch cutchild + $child cutfromparent + + $branch setchild $child + $child setparentbranch $branch + + $parent removebranch $branch + $parent removechildonbranch $root + } + return + } + + method LinesOfDevelopment {} { + # Determine all lines of development for the file. This are + # the known roots, and the root of all branches found on the + # line of primary children. + + set lodroots {} + foreach root $myroots { + $self AddBranchedLinesOfDevelopment lodroots $root + lappend lodroots $root + } + return $lodroots + } + + method AddBranchedLinesOfDevelopment {lv root} { + upvar 1 $lv lodroots + while {$root ne ""} { + foreach branch [$root branches] { + if {![$branch haschild]} continue + set child [$branch child] + # Recurse into the branch for deeper branches. + $self AddBranchedLinesOfDevelopment lodroots $child + lappend lodroots $child + } + set root [$root child] + } + return + } + + method ExcludeNonTrunkInformation {} { + # Remove all non-trunk branches, revisions, and tags. We do + # keep the tags which are on the trunk. + + set ntdbroot "" + foreach root [$self LinesOfDevelopment] { + # Note: Here the order of the roots is important, + # i.e. that we get them in depth first order. This ensures + # that the removal of a branch happens only after the + # branches spawned from it were removed. Otherwise the + # system might try to access deleted objects. + + # Do not exclude the trunk. + if {[[$root lod] istrunk]} continue + $self ExcludeBranch $root ntdbroot + } + + if {$ntdbroot ne ""} { + $self GraftNTDB2Trunk $ntdbroot + } + return + } + + method ExcludeBranch {root nv} { + # Exclude the branch/lod starting at root, a revision. + # + # If the LOD starts with non-trunk default branch revisions, + # we leave them in place and do not delete the branch. In that + # case the command sets the variable in NV so that we can + # later rework these revisons to be purely trunk. + + if {[$root isondefaultbranch]} { + # Handling a NTDB. This branch may consists not only of + # NTDB revisions, but also some non-NTDB. The latter are + # truly on a branch and have to be excluded. The following + # loop determines if there are such revisions. + + upvar 1 $nv ntdbroot + set ntdbroot $root + $root cutfromparentbranch + + set rev $root + while {$rev ne ""} { + $rev removeallbranches + # See note [x]. + + if {[$rev isondefaultbranch]} { + set rev [$rev child] + } else { + break + } + } + + # rev now contains the first non-NTDB revision after the + # NTDB, or is empty if there is no such. If we have some + # they have to removed. + + if {$rev ne ""} { + set lastntdb [$rev parent] + $lastntdb cutfromchild + while {$rev ne ""} { + $rev removealltags + $rev removeallbranches + # Note [x]: We may still have had branches on the + # revision. Branches without revisions committed + # on them do not show up in the list of roots aka + # lines of development. + set rev [$rev child] + } + } + return + } + + # No NTDB stuff to deal with. First delete the branch object + # itself, after cutting all the various connections. + + set branch [$root parentbranch] + if {$branch ne ""} { + set branchparent [$branch parent] + $branchparent removebranch $branch + $branchparent removechildonbranch $root + } + + # The root is no such any longer either. + ldelete myroots $root + + # Now go through the line and remove all its revisions. + + while {$root ne ""} { + $root removealltags + $root removeallbranches + # Note: See the note [x]. + + # From cvs2svn: If this is the last default revision on a + # non-trunk default branch followed by a 1.2 revision, + # then the 1.2 revision depends on this one. FIXME: It is + # questionable whether this handling is correct, since the + # non-trunk default branch revisions affect trunk and + # should therefore not just be discarded even if + # --trunk-only. + + if {[$root hasdefaultbranchchild]} { + set ntdbchild [$root defaultbranchchild] + integrity assert { + [$ntdbchild defaultbranchparent] eq $ntdbchild + } {ntdb - trunk linkage broken} + $ntdbchild cutdefaultbranchparent + if {[$ntdbchild hasparent]} { + lappend myroots [$ntdbchild parent] + } + } + + set root [$root child] + } + + return + } + + method GraftNTDB2Trunk {root} { + # We can now graft the non-trunk default branch revisions to + # trunk. They should already be alone on a CVSBranch-less + # branch. + + integrity assert {![$root hasparentbranch]} {NTDB root still has its branch symbol} + integrity assert {![$root hasbranches]} {NTDB root still has spawned branches} + + set last $root + while {[$last haschild]} {set last [$last child]} + + if {[$last hasdefaultbranchchild]} { + + set rev12 [$last defaultbranchchild] + $rev12 cutdefaultbranchparent + $last cutdefaultbranchchild + + $rev12 changeparent $last + $last changechild $rev12 + + ldelete myroots $rev12 + + # Note and remember that the type of rev12 was already + # adjusted by AdjustNonTrunkDefaultBranch, so we don't + # have to change its type here. + } + + while {$root ne ""} { + $root setondefaultbranch 0 + $root setlod $mytrunk + foreach tag [$root tags] { + $tag setlod $mytrunk + } + set root [$root child] + } + + return + } + + method Active {} { + set revisions {} + set symbols {} + + foreach root [$self LinesOfDevelopment] { + if {[$root hasparentbranch]} { lappend symbols [$root parentbranch] } + while {$root ne ""} { + lappend revisions $root + foreach tag [$root tags] { lappend symbols $tag } + foreach branch [$root branches] { + integrity assert { + [$branch parent] eq $root + } {Backreference branch to its root is missing or wrong} + lappend symbols $branch + } + set lod [$root lod] + if {![$lod istrunk]} { + integrity assert { + [$lod haschild] + } {Branch is LOD symbol without revisions} + lappend symbols $lod + } + set root [$root child] + } + } + + return [list [lsort -unique -dict $revisions] [lsort -unique -dict $symbols]] + } + + + method AggregateSymbolData {} { + # Now that the exact set of revisions (and through that + # branches and tags) is known we can update the aggregate + # symbol statistics. + + foreach root [$self LinesOfDevelopment] { + set lod [$root lod] + + # Note: If the LOD is the trunk the count*, etc. methods + # will do nothing, as it is always present (cannot be + # excluded), and is always a branch too. + + # Lines of development count as branches and have a commit + # on them (root). If they are still attached to a tree we + # have to compute and register possible parents. + + $lod countasbranch + $lod countacommit + + if {[$root hasparentbranch]} { + # Note lod == [$root parentbranch] + $lod possibleparents + } elseif {![$lod istrunk] && [$root isondefaultbranch]} { + # This is the root revision of a detached NTDB. We + # have to manually set the only possible parent for + # this LOD, the trunk itself. + + [$lod symbol] possibleparent $mytrunk + } + + # For the revisions in the line we register their branches + # and tags as blockers for the lod, and update the type + # counters as well. As branch symbols without commits on + # them are not listed as lines of development, we have to + # count them here as well, as plain branches. At last we + # have to compute and register the possible parents of the + # tags, in case they are later converted as branches. + + while {$root ne ""} { + foreach branch [$root branches] { + $lod blockedby $branch + $branch possibleparents + if {[$branch haschild]} continue + $branch countasbranch + } + + foreach tag [$root tags] { + $lod blockedby $tag + $tag possibleparents + $tag countastag + } + + set root [$root child] + } + } + + return + } + + # # ## ### ##### ######## ############# + ## Configuration + + pragma -hastypeinfo no ; # no type introspection + pragma -hasinfo no ; # no object introspection + pragma -hastypemethods no ; # type is not relevant. + + # # ## ### ##### ######## ############# +} + +namespace eval ::vc::fossil::import::cvs { + namespace export file + namespace eval file { + # Import not required, already a child namespace. + # namespace import ::vc::fossil::import::cvs::file::rev + # namespace import ::vc::fossil::import::cvs::file::sym + namespace import ::vc::tools::misc::* + namespace import ::vc::tools::trouble + namespace import ::vc::tools::log + namespace import ::vc::fossil::import::cvs::blobstore + namespace import ::vc::fossil::import::cvs::state + namespace import ::vc::fossil::import::cvs::integrity + namespace import ::vc::fossil::import::cvs::gtcore + } +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide vc::fossil::import::cvs::file 1.0 +return diff --git a/tools/cvs2fossil/lib/c2f_fossil.tcl b/tools/cvs2fossil/lib/c2f_fossil.tcl new file mode 100644 index 0000000..6465d98 --- /dev/null +++ b/tools/cvs2fossil/lib/c2f_fossil.tcl @@ -0,0 +1,273 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2007-2008 Andreas Kupries. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## Fossil, a helper class managing the access to fossil repositories. + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.4 ; # Required runtime. +package require fileutil ; # Temp.dir/file +package require snit ; # OO system. +package require vc::tools::trouble ; # Error reporting. +package require vc::tools::log ; # User feedback +package require vc::fossil::import::cvs::integrity ; # State integrity checks. + +# # ## ### ##### ######## ############# ##################### +## + +snit::type ::vc::fossil::import::cvs::fossil { + # # ## ### ##### ######## ############# + ## Public API + + constructor {} { + return + } + + method initialize {} { + set myrepository [fileutil::tempfile cvs2fossil_repo_] + set myworkspace [fileutil::tempfile cvs2fossil_wspc_] + ::file delete $myworkspace + ::file mkdir $myworkspace + + Do new [::file nativename $myrepository] + $self InWorkspace ; Do open [::file nativename $myrepository] + $self RestorePwd + + log write 8 fossil {Scratch repository created @ $myrepository} + log write 8 fossil {Scratch workspace created @ $myworkspace } + return + } + + method load {r w} { + set myrepository $r + set myworkspace $w + + log write 8 fossil {Scratch repository found @ $myrepository} + log write 8 fossil {Scratch workspace found @ $myworkspace} + return + } + + method space {} { + return [list $myrepository $myworkspace] + } + + # # ## ### ##### ######## ############# + ## + + method root {} { + # The id of the root manifest is hardwired into fossil. This + # manifest is created when a new repository is made (See + # 'new', in the constructor). + return 1 + } + + method workspace {} { return $myworkspace } + + method importfiles {map} { + # map = list (instruction), instruction = add|delta + # add = list ('A', path) + # delta = list ('D', path, src) + + log write 3 fossil {Importing revisions...} + + array set id {} + $self InWorkspace + + set n 0 + set max [llength $map] + + foreach insn $map { + log progress 3 fossil $n $max ; incr n + + struct::list assign $insn cmd pa pb + switch -exact -- $cmd { + A { + log write 8 fossil {Importing <$pa>,} + + # Result = 'inserted as record :FOO:' + # 0 1 2 3 + set res [Do test-content-put $pa] + integrity assert { + [regexp {^inserted as record \d+$} $res] + } {Unable to process unexpected fossil output '$res'} + set id($pa) [lindex $res 3] + } + D { + log write 8 fossil {Compressing <$pa>, as delta of <$pb>} + + Do test-content-deltify $id($pa) $id($pb) 1 + } + } + } + $self RestorePwd + + log write 3 fossil Done. + return [array get id] + } + + method importrevision {label user message date parent revisions} { + # Massage the commit message to remember the old user name + # which did the commit in CVS. + + set message "By $user:\n$message" + + log write 2 fossil {== $user @ [clock format $date]} + log write 2 fossil {-> $parent} + log write 9 fossil {%% [join [split $message \n] "\n%% "]} + + lappend cmd Do test-import-manifest $date $message + if {$parent ne ""} { lappend cmd -p $parent } + foreach {frid fpath flabel} $revisions { + lappend cmd -f $frid $fpath + log write 12 fossil {** <[format %5d $frid]> = <$flabel>} + } + + # run fossil test-command performing the import. + log write 12 fossil { [lreplace $cmd 3 3 @@]} + + $self InWorkspace + set res [eval $cmd] + $self RestorePwd + + integrity assert { + [regexp {^inserted as record \d+, [0-9a-fA-F]+$} $res] + } {Unable to process unexpected fossil output '$res'} + set rid [string trim [lindex $res 3] ,] + set uuid [lindex $res 4] + + log write 2 fossil {== $rid ($uuid)} + + return [list $rid $uuid] + } + + method tag {uuid name} { + log write 2 fossil {Tag '$name' @ $uuid} + + $self InWorkspace + Do tag add sym-$name $uuid + $self RestorePwd + return + } + + method branchmark {uuid name} { + # We do not mark the trunk + if {$name eq ":trunk:"} return + + log write 2 fossil {Begin branch '$name' @ $uuid} + + $self InWorkspace + Do tag branch sym-$name $uuid + $self RestorePwd + return + } + + method branchcancel {uuid name} { + # The trunk is unmarked, thus cancellation is not needed + # either. + if {$name eq ":trunk:"} return + + log write 2 fossil {Cancel branch '$name' @ $uuid} + + $self InWorkspace + Do tag delete sym-$name $uuid + $self RestorePwd + return + } + + method finalize {destination} { + log write 2 fossil {Finalize, rebuilding repository} + Do rebuild [::file nativename $myrepository] + + ::file rename -force $myrepository $destination + ::file delete -force $myworkspace + $self destroy + + log write 2 fossil {destination $destination} + return + } + + # # ## ### ##### ######## ############# + ## + + typemethod setlocation {path} { + set myfossilcmd $path + set myneedlocation 0 + return + } + + typemethod validate {} { + if {!$myneedlocation} { + if {![fileutil::test $myfossilcmd efrx msg]} { + trouble fatal "Bad path for fossil executable: $msg" + } + } else { + trouble fatal "Don't know where to find the 'fossil' executable" + } + return + } + + typeconstructor { + set location [auto_execok fossil] + set myneedlocation [expr {$location eq ""}] + if {$myneedlocation} return + $type setlocation $location + return + } + + # # ## ### ##### ######## ############# + ## State + + variable mypwd {} ; # Path to last CWD + variable myrepository {} ; # Path to our fossil database. + variable myworkspace {} ; # Path to the workspace for our fossil + # database. + + typevariable myfossilcmd ; # Path to fossil executable. + typevariable myneedlocation ; # Boolean, indicates if user has to + # tell us where fossil lives or not. + + # # ## ### ##### ######## ############# + ## Internal methods + + proc Do {args} { + # 8.5: exec $myfossilcmd {*}$args + log write 14 fossil {Doing '$args'} + return [eval [linsert $args 0 exec $myfossilcmd]] + } + + method InWorkspace {} { set mypwd [pwd] ; cd $myworkspace ; return } + method RestorePwd {} { cd $mypwd ; set mypwd {} ; return } + + # # ## ### ##### ######## ############# + ## Configuration + + pragma -hastypeinfo no ; # no type introspection + pragma -hasinfo no ; # no object introspection + + # # ## ### ##### ######## ############# +} + +namespace eval ::vc::fossil::import::cvs { + namespace export fossil + namespace eval fossil { + namespace import ::vc::tools::trouble + namespace import ::vc::tools::log + namespace import ::vc::fossil::import::cvs::integrity + } +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide vc::fossil::import::cvs::fossil 1.0 +return diff --git a/tools/cvs2fossil/lib/c2f_frev.tcl b/tools/cvs2fossil/lib/c2f_frev.tcl new file mode 100644 index 0000000..fa05513 --- /dev/null +++ b/tools/cvs2fossil/lib/c2f_frev.tcl @@ -0,0 +1,552 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2007-2008 Andreas Kupries. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## Revisions per file. + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.4 ; # Required runtime. +package require snit ; # OO system. +package require vc::tools::misc ; # Text formatting +package require vc::fossil::import::cvs::state ; # State storage. +package require vc::fossil::import::cvs::integrity ; # State integrity checks. + +# # ## ### ##### ######## ############# ##################### +## + +snit::type ::vc::fossil::import::cvs::file::rev { + # # ## ### ##### ######## ############# + ## Public API + + constructor {revnr date state thefile} { + set myrevnr $revnr + set mydate $date + set myorigdate $date + set mystate $state + set myfile $thefile + return + } + + method defid {} { + set myid [incr myidcounter] + return + } + + method id {} { return $myid } + method file {} { return $myfile } + + # Basic pieces ________________________ + + method hasmeta {} { return [expr {$mymetaid ne ""}] } + method hastext {} { + return [expr {$mytextstart <= $mytextend}] + } + + method setmeta {meta} { set mymetaid $meta ; return } + method settext {text} { + struct::list assign $text mytextstart mytextend + return + } + method setlod {lod} { set mylod $lod ; return } + + method revnr {} { return $myrevnr } + method state {} { return $mystate } + method lod {} { return $mylod } + method date {} { return $mydate } + + method isneeded {} { + if {$myoperation ne "nothing"} {return 1} + if {$myrevnr ne "1.1"} {return 1} + if {![$mylod istrunk]} {return 1} + if {![llength $mybranches]} {return 1} + set firstbranch [lindex $mybranches 0] + if {![$firstbranch haschild]} {return 1} + if {$myisondefaultbranch} {return 1} + + # FIX: This message will not match if the RCS file was renamed + # manually after it was created. + + set gen "file [file tail [$myfile usrpath]] was initially added on branch [$firstbranch name]." + set log [$myfile commitmessageof $mymetaid] + + return [expr {$log ne $gen}] + } + + method isneededbranchdel {} { + if {$myparentbranch eq ""} {return 1} ; # not first on a branch, needed + set base [$myparentbranch parent] + if {$base eq ""} {return 1} ; # branch has parent lod, needed + if {[$self LODLength] < 2} {return 1} ; # our lod contains only ourselves, needed. + if {$myoperation ne "delete"} {return 1} ; # Not a deletion, needed + if {[llength $mytags]} {return 1} ; # Have tags, needed + if {[llength $mybranches]} {return 1} ; # Have other branches, needed + if {abs($mydate - [$base date]) > 2} {return 1} ; # Next rev > 2 seconds apart, needed + + # FIXME: This message will not match if the RCS file was + # renamed manually after it was created. + + set qfile [string map { + . \\. ? \\? * \\* \\ \\\\ + \\+ ^ \\^ $ \\$ + \[ \\\[ \] \\\] ( \\( ) \\) \{ \\\{ \} \\\} + } [file tail [$myfile usrpath]]] + set pattern "file $qfile was added on branch .* on \\d{4}-\\d{2}-\\d{2} \\d{2}:\\d{2}:\\d{2}( \[+-\]\\d{4})?" + set log [$myfile commitmessageof $mymetaid] + + # Not the special message, needed + if {![regexp -- $pattern $log]} {return 1} + + # This is an unneeded initial branch delete. + return 0 + } + + method LODLength {} { + set n 1 ; # count self + set rev $mychild + while {$rev ne ""} { + incr n + set rev [$rev child] + } + return $n + } + + # Basic parent/child linkage __________ + + method hasparent {} { return [expr {$myparent ne ""}] } + method haschild {} { return [expr {$mychild ne ""}] } + + method setparent {parent} { + integrity assert {$myparent eq ""} {Parent already defined} + set myparent $parent + return + } + + method cutfromparent {} { set myparent "" ; return } + method cutfromchild {} { set mychild "" ; return } + + method setchild {child} { + integrity assert {$mychild eq ""} {Child already defined} + set mychild $child + return + } + + method changeparent {parent} { set myparent $parent ; return } + method changechild {child} { set mychild $child ; return } + + method parent {} { return $myparent } + method child {} { return $mychild } + + # Branch linkage ______________________ + + method setparentbranch {branch} { + integrity assert {$myparentbranch eq ""} {Branch parent already defined} + set myparentbranch $branch + return + } + + method hasparentbranch {} { return [expr {$myparentbranch ne ""}] } + method hasbranches {} { return [llength $mybranches] } + + method parentbranch {} { return $myparentbranch } + method branches {} { return $mybranches } + + method addbranch {branch} { + lappend mybranches $branch + return + } + + method addchildonbranch {child} { + lappend mybranchchildren $child + return + } + + method cutfromparentbranch {} { set myparentbranch "" ; return } + + method removebranch {branch} { + ldelete mybranches $branch + return + } + + method removechildonbranch {rev} { + ldelete mybranchchildren $rev + return + } + + method sortbranches {} { + # Pass 2: CollectRev + + if {[llength $mybranches] < 2} return + + # Sort the branches spawned by this revision in creation + # order. To help in this our file gave all branches a position + # id, in order of their definition by the RCS archive. + # + # The creation order is (apparently) the reverse of the + # definition order. (If a branch is created then deleted, a + # later branch can be assigned the recycled branch number; + # therefore branch numbers are not an indication of creation + # order.) + + set tmp {} + foreach branch $mybranches { + lappend tmp [list $branch [$branch position]] + } + + set mybranches {} + foreach item [lsort -index 1 -decreasing $tmp] { + struct::list assign $item branch position + lappend mybranches $branch + } + return + } + + method movebranchesto {rev} { + set revlod [$rev lod] + foreach branch $mybranches { + $rev addbranch $branch + $branch setparent $rev + $branch setlod $revlod + } + foreach branchrev $mybranchchildren { + $rev addchildonbranch $branchrev + $branchrev cutfromparent + $branchrev setparent $rev + } + set mybranches {} + set mybranchchildren {} + return + } + + method removeallbranches {} { + set mybranches {} + set mybranchchildren {} + return + } + + # Tag linkage _________________________ + + method addtag {tag} { + lappend mytags $tag + return + } + + method tags {} { return $mytags } + + method removealltags {} { + set mytags {} + return + } + + method movetagsto {rev} { + set revlod [$rev lod] + foreach tag $mytags { + $rev addtag $tag + $tag settagrev $rev + $tag setlod $revlod + } + set mytags {} + return + } + + # general symbol operations ___________ + + method movesymbolsto {rev} { + # Move the tags and branches attached to this revision to the + # destination and fix all pointers. + + $self movetagsto $rev + $self movebranchesto $rev + return + } + + # Derived stuff _______________________ + + method determineoperation {} { + # Look at the state of both this revision and its parent to + # determine the type opf operation which was performed (add, + # modify, delete, none). + # + # The important information is dead vs not-dead for both, + # giving rise to four possible types. + + set sdead [expr {$mystate eq "dead"}] + set pdead [expr {$myparent eq "" || [$myparent state] eq "dead"}] + + set myoperation $myopstate([list $pdead $sdead]) + return + } + + method operation {} { return $myoperation } + method retype {x} { set myoperation $x ; return } + + method isondefaultbranch {} { return $myisondefaultbranch } + + method setondefaultbranch {x} { set myisondefaultbranch $x ; return } + + method setdefaultbranchchild {rev} { set mydbchild $rev ; return } + method setdefaultbranchparent {rev} { + set mydbparent $rev + + # Retype the revision (may change from 'add' to 'change'). + + set sdead [expr {$myoperation ne "change"}] + set pdead [expr {[$rev operation] ne "change"}] + set myoperation $myopstate([list $pdead $sdead]) + return + } + + method cutdefaultbranchparent {} { set mydbparent "" ; return } + method cutdefaultbranchchild {} { set mydbchild "" ; return } + + method defaultbranchchild {} { return $mydbchild } + method defaultbranchparent {} { return $mydbparent } + + method hasdefaultbranchchild {} { return [expr {$mydbchild ne ""}] } + method hasdefaultbranchparent {} { return [expr {$mydbparent ne ""}] } + + # # ## ### ##### ######## ############# + ## Type API + + typemethod istrunkrevnr {revnr} { + return [expr {[llength [split $revnr .]] == 2}] + } + + typemethod isbranchrevnr {revnr _ bv} { + if {[regexp $mybranchpattern $revnr -> head tail]} { + upvar 1 $bv branchnr + set branchnr ${head}$tail + return 1 + } + return 0 + } + + typemethod 2branchnr {revnr} { + # Input is a branch revision number, i.e. a revision number + # with an even number of components; for example '2.9.2.1' + # (never '2.9.2' nor '2.9.0.2'). The return value is the + # branch number (for example, '2.9.2'). For trunk revisions, + # like '3.4', we return the empty string. + + if {[$type istrunkrevnr $revnr]} { + return "" + } + return [join [lrange [split $revnr .] 0 end-1] .] + } + + typemethod 2branchparentrevnr {branchnr} { + # Chop the last segment off + return [join [lrange [split $branchnr .] 0 end-1] .] + } + + # # ## ### ##### ######## ############# + + method persist {} { + set fid [$myfile id] + set lod [$mylod id] + set op $myopcode($myoperation) + set idb $myisondefaultbranch + + lappend map @P@ [expr { ($myparent eq "") ? "NULL" : [$myparent id] }] + lappend map @C@ [expr { ($mychild eq "") ? "NULL" : [$mychild id] }] + lappend map @DP [expr { ($mydbparent eq "") ? "NULL" : [$mydbparent id] }] + lappend map @DC [expr { ($mydbchild eq "") ? "NULL" : [$mydbchild id] }] + lappend map @BP [expr { ($myparentbranch eq "") ? "NULL" : [$myparentbranch id] }] + + set cmd { + INSERT INTO revision ( rid, fid, rev, lod, parent, child, isdefault, dbparent, dbchild, bparent, op, date, state, mid) + VALUES ($myid, $fid, $myrevnr, $lod, @P@, @C@, $idb, @DP, @DC, @BP , $op, $mydate, $mystate, $mymetaid); + } + + state transaction { + state run [string map $map $cmd] + + # And the branch children as well, for pass 5. + foreach bc $mybranchchildren { + set bcid [$bc id] + state run { + INSERT INTO revisionbranchchildren (rid, brid) + VALUES ($myid, $bcid); + } + } + } + return + } + + # # ## ### ##### ######## ############# + ## State + + # Persistent: myid - revision.rid + # myfile - revision.fid + # mylod - revision.lod + # myrevnr - revision.rev + # mydate - revision.date + # mystate - revision.state + # mymetaid - revision.mid + # mytext{start,end} - revision.{cs,ce} + # myparent - revision.parent + # mychild - revision.child + # myparentbranch - revision.bparent + # myoperation - revision.op + # myisondefaultbranch - revision.isdefault + # mydbparent - revision.dbparent + # mydbchild - revision.dbchild + + method DUMP {label} { + puts "$label = $self <$myrevnr> (NTDB=$myisondefaultbranch) \{" + puts "\tP\t$myparent" + puts "\tC\t$mychild" + puts "\tPB\t$myparentbranch" + puts "\tdbP\t$mydbparent" + puts "\tdbC\t$mydbchild" + foreach b $mybranches { + puts \t\tB\t$b + } + foreach b $mybranchchildren { + puts \t\tBC\t$b + } + puts "\}" + return + } + + typevariable mybranchpattern {^((?:\d+\.\d+\.)+)(?:0\.)?(\d+)$} + # First a nonzero even number of digit groups with trailing dot + # CVS then sticks an extra 0 in here; RCS does not. + # And the last digit group. + + typevariable myidcounter 0 ; # Counter for revision ids. + variable myid {} ; # Revision id. + + variable myrevnr {} ; # Revision number of the revision. + variable mydate {} ; # Timestamp of the revision, seconds since epoch + variable myorigdate {} ; # Original unmodified timestamp. + variable mystate {} ; # State of the revision. + variable myfile {} ; # Ref to the file object the revision belongs to. + variable mytextstart {} ; # Start of the range of the (delta) text + # for this revision in the file. + variable mytextend {} ; # End of the range of the (delta) text + # for this revision in the file. + variable mymetaid {} ; # Id of the meta data group the revision + # belongs to. This is later used to put + # the file revisions into preliminary + # changesets (aka project revisions). + # This id encodes 4 pieces of data, + # namely: the project and branch the + # revision was committed to, the author + # who did the commit, and the message + # used. + variable mylod {} ; # Reference to the line-of-development + # object the revision belongs to. An + # alternative idiom would be to call it + # the branch the revision is on. This + # reference is to either project-level + # trunk or file-level symbol. + + # Basic parent/child linkage (lines of development) + + variable myparent {} ; # Ref to parent revision object. Link required because of + # ; # 'cvsadmin -o', which can create arbitrary gaps in the + # ; # numbering sequence. This is in the same line of development + # ; # Note: For the first revision on a branch the revision + # ; # it was spawned from is the parent. Only the root revision + # ; # of myfile's revision tree has nothing set here. + # ; # + + variable mychild {} ; # Ref to the primary child revision object, i.e. the next + # ; # revision in the same line of development. + + # Branch linkage ____________________ + + variable mybranches {} ; # List of the branches (objs) spawned by this revision. + variable myparentbranch {} ; # For the first revision on a branch the relevant + # ; # branch object. This also allows us to determine if + # ; # myparent is in the same LOD, or the revision the + # ; # branch spawned from. + + # List of the revision objects of the first commits on any + # branches spawned by this revision on which commits occurred. + # This dependency is kept explicitly because otherwise a + # revision-only topological sort would miss the dependency that + # exists via -> mybranches. + + variable mybranchchildren {} ; # List of the revisions (objs) which are the first + # ; # commits on any of the branches spawned from this + # ; # revision. The dependency is kept explicitly to + # ; # ensure that a revision-only topological sort will + # ; # not miss it, as it otherwise exists only via + # ; # mybranches. + + # Tag linkage ________________________ + + variable mytags {} ; # List of tags (objs) associated with this revision. + + # More derived data + + variable myoperation {} ; # One of 'add', 'change', 'delete', or + # 'nothing'. Derived from our and + # its parent's state. + variable myisondefaultbranch 0 ; # Boolean flag, set if the + # revision is on the non-trunk + # default branch, aka vendor + # branch. + variable mydbparent {} ; # Reference to the last revision + # on the vendor branch if this is + # the primary child of the + # regular root. + variable mydbchild {} ; # Reference to the primary child + # of the regular root if this is + # the last revision on the vendor + # branch. + + # dead(self) x dead(parent) -> operation + typevariable myopstate -array { + {0 0} change + {0 1} delete + {1 0} add + {1 1} nothing + } + + typemethod getopcodes {} { + state foreachrow { + SELECT oid, name FROM optype; + } { set myopcode($name) $oid } + return + } + + typevariable myopcode -array {} + + # # ## ### ##### ######## ############# + ## Internal methods + + # # ## ### ##### ######## ############# + ## Configuration + + pragma -hastypeinfo no ; # no type introspection + pragma -hasinfo no ; # no object introspection + pragma -simpledispatch yes ; # simple fast dispatch + + # # ## ### ##### ######## ############# +} + +namespace eval ::vc::fossil::import::cvs::file { + namespace export rev + namespace eval rev { + namespace import ::vc::tools::misc::* + namespace import ::vc::fossil::import::cvs::state + namespace import ::vc::fossil::import::cvs::integrity + } +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide vc::fossil::import::cvs::file::rev 1.0 +return diff --git a/tools/cvs2fossil/lib/c2f_fsym.tcl b/tools/cvs2fossil/lib/c2f_fsym.tcl new file mode 100644 index 0000000..d61b46e --- /dev/null +++ b/tools/cvs2fossil/lib/c2f_fsym.tcl @@ -0,0 +1,325 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2007-2008 Andreas Kupries. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## Symbols (Tags, Branches) per file. + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.4 ; # Required runtime. +package require snit ; # OO system. +package require vc::tools::trouble ; # Error reporting. +package require vc::fossil::import::cvs::file::rev ; # CVS per file revisions. +package require vc::fossil::import::cvs::state ; # State storage. +package require vc::fossil::import::cvs::integrity ; # State integrity checks. + +# # ## ### ##### ######## ############# ##################### +## + +snit::type ::vc::fossil::import::cvs::file::sym { + # # ## ### ##### ######## ############# + ## Public API + + constructor {symtype nr symbol file} { + set myfile $file + set mytype $symtype + set mynr $nr + set mysymbol $symbol + + switch -exact -- $mytype { + branch { SetupBranch ; return } + tag { return } + } + integrity assert 0 {Bad symbol type '$mytype'} + return + } + + method defid {} { + set myid [incr myidcounter] + return + } + + method fid {} { return $myid } + method symbol {} { return $mysymbol } + + # Symbol acessor methods. + + delegate method name to mysymbol + delegate method id to mysymbol + + # Symbol aggregation methods + + delegate method countasbranch to mysymbol + delegate method countastag to mysymbol + delegate method countacommit to mysymbol + + method blockedby {fsymbol} { + $mysymbol blockedby [$fsymbol symbol] + return + } + + method possibleparents {} { + switch -exact -- $mytype { + branch { $self BranchParents } + tag { $self TagParents } + } + return + } + + method BranchParents {} { + # The "obvious" parent of a branch is the branch holding the + # revision spawning the branch. Any other branches that are + # rooted at the same revision and were committed earlier than + # the branch are also possible parents. + + # Ignore this if the branch symbol is detached. + if {$mybranchparent eq ""} return + + $mysymbol possibleparent [[$mybranchparent lod] symbol] + + foreach branch [$mybranchparent branches] { + # A branch cannot be its own parent. Nor can a branch + # created after this one be its parent. This means that we + # can abort the loop when we have reached ourselves in the + # list of branches. Here the order of file::rev.mybranches + # comes into play, as created by file::rev::sortbranches. + + if {$branch eq $self} break + $mysymbol possibleparent [$branch symbol] + } + return + } + + method TagParents {} { + # The "obvious" parent of a tag is the branch holding the + # revision spawning the tag. Branches that are spawned by the + # same revision are also possible parents. + + $mysymbol possibleparent [[$mytagrev lod] symbol] + + foreach branch [$mytagrev branches] { + $mysymbol possibleparent [$branch symbol] + } + return + } + + # + + method istrunk {} { return 0 } + + # Branch acessor methods. + + method setchildrevnr {revnr} { + integrity assert {$mybranchchildrevnr eq ""} {Child already defined} + set mybranchchildrevnr $revnr + return + } + + method setposition {n} { set mybranchposition $n ; return } + method setparent {rev} { set mybranchparent $rev ; return } + method setchild {rev} { set mybranchchild $rev ; return } + method cutchild {} { set mybranchchild "" ; return } + method cutbranchparent {} { set mybranchparent "" ; return } + + method branchnr {} { return $mynr } + method parentrevnr {} { return $mybranchparentrevnr } + method childrevnr {} { return $mybranchchildrevnr } + method haschildrev {} { return [expr {$mybranchchildrevnr ne ""}] } + method haschild {} { return [expr {$mybranchchild ne ""}] } + method parent {} { return $mybranchparent } + method child {} { return $mybranchchild } + method position {} { return $mybranchposition } + + # Tag acessor methods. + + method tagrevnr {} { return $mynr } + method settagrev {rev} { set mytagrev $rev ; return } + + # Derived information + + method lod {} { return $mylod } + + method setlod {lod} { + set mylod $lod + $self checklod + return + } + + method checklod {} { + # Consistency check. The symbol's line-of-development has to + # be same as the line-of-development of its source (parent + # revision of a branch, revision of a tag itself). + + switch -exact -- $mytype { + branch { + # However, ignore this if the branch symbol is + # detached. + if {$mybranchparent eq ""} return + + set slod [$mybranchparent lod] + } + tag { set slod [$mytagrev lod] } + } + + if {$mylod ne $slod} { + trouble fatal "For $mytype [$mysymbol name]: LOD conflict with source, '[$mylod name]' vs. '[$slod name]'" + return + } + return + } + + # # ## ### ##### ######## ############# + + method persist {} { + # Save the information we need after the collection pass. + + set fid [$myfile id] + set sid [$mysymbol id] + set lod [$mylod id] + + switch -exact -- $mytype { + tag { + set rid [$mytagrev id] + state transaction { + state run { + INSERT INTO tag ( tid, fid, lod, sid, rev) + VALUES ($myid, $fid, $lod, $sid, $rid); + } + } + } + branch { + lappend map @F@ [expr { ($mybranchchild eq "") ? "NULL" : [$mybranchchild id] }] + lappend map @P@ [expr { ($mybranchparent eq "") ? "NULL" : [$mybranchparent id] }] + + set cmd { + INSERT INTO branch ( bid, fid, lod, sid, root, first, bra, pos ) + VALUES ($myid, $fid, $lod, $sid, @P@, @F@, $mynr, $mybranchposition); + } + state transaction { + state run [string map $map $cmd] + } + } + } + + return + } + + method DUMP {label} { + puts "$label = $self $mytype [$self name] \{" + switch -exact -- $mytype { + tag { + puts "\tR\t$mytagrev" + } + branch { + puts "\tP\t$mybranchparent" + puts "\tC\t$mybranchchild" + puts "\t\t<$mynr>" + } + } + puts "\}" + return + } + + # # ## ### ##### ######## ############# + ## State + + # Persistent: + # Tag: myid - tag.tid + # myfile - tag.fid + # mylod - tag.lod + # mysymbol - tag.sid + # mytagrev - tag.rev + # + # Branch: myid - branch.bid + # myfile - branch.fid + # mylod - branch.lod + # mysymbol - branch.sid + # mybranchparent - branch.root + # mybranchchild - branch.first + # mynr - branch.bra + + typevariable myidcounter 0 ; # Counter for symbol ids. + variable myid {} ; # Symbol id. + + ## Basic, all symbols _________________ + + variable myfile {} ; # Reference to the file the symbol is in. + variable mytype {} ; # Symbol type, 'tag', or 'branch'. + variable mynr {} ; # Revision number of a 'tag', branch number + # of a 'branch'. + variable mysymbol {} ; # Reference to the symbol object of this + # symbol at the project level. + variable mylod {} ; # Reference to the line-of-development + # object the symbol belongs to. An + # alternative idiom would be to call it the + # branch the symbol is on. This reference + # is to a project-level object (symbol or + # trunk). + + ## Branch symbols _____________________ + + variable mybranchparentrevnr {} ; # The number of the parent + # revision, derived from our + # branch number (mynr). + variable mybranchparent {} ; # Reference to the revision + # (object) which spawns the + # branch. + variable mybranchchildrevnr {} ; # Number of the first revision + # committed on this branch. + variable mybranchchild {} ; # Reference to the revision + # (object) first committed on + # this branch. + variable mybranchposition {} ; # Relative id of the branch in + # the file, to sort into + # creation order. + + ## Tag symbols ________________________ + + variable mytagrev {} ; # Reference to the revision object the tag + # is on, identified by 'mynr'. + + # ... nothing special ... (only mynr, see basic) + + # # ## ### ##### ######## ############# + ## Internal methods + + proc SetupBranch {} { + upvar 1 mybranchparentrevnr mybranchparentrevnr mynr mynr + set mybranchparentrevnr [rev 2branchparentrevnr $mynr] + return + } + + # # ## ### ##### ######## ############# + ## Configuration + + pragma -hastypeinfo no ; # no type introspection + pragma -hasinfo no ; # no object introspection + pragma -hastypemethods no ; # type is not relevant. + + # # ## ### ##### ######## ############# +} + +namespace eval ::vc::fossil::import::cvs::file { + namespace export sym + namespace eval sym { + namespace import ::vc::fossil::import::cvs::file::rev + namespace import ::vc::fossil::import::cvs::state + namespace import ::vc::fossil::import::cvs::integrity + namespace import ::vc::tools::trouble + } +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide vc::fossil::import::cvs::file::sym 1.0 +return diff --git a/tools/cvs2fossil/lib/c2f_ftrunk.tcl b/tools/cvs2fossil/lib/c2f_ftrunk.tcl new file mode 100644 index 0000000..75ecbef --- /dev/null +++ b/tools/cvs2fossil/lib/c2f_ftrunk.tcl @@ -0,0 +1,57 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2007 Andreas Kupries. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## Trunk, the special main line of development in a file. + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.4 ; # Required runtime. +package require snit ; # OO system. + +# # ## ### ##### ######## ############# ##################### +## + +snit::type ::vc::fossil::import::cvs::file::trunk { + # # ## ### ##### ######## ############# + ## Public API + + constructor {} { + return + } + + # # ## ### ##### ######## ############# + ## State + + # # ## ### ##### ######## ############# + ## Internal methods + + # # ## ### ##### ######## ############# + ## Configuration + + pragma -hastypeinfo no ; # no type introspection + pragma -hasinfo no ; # no object introspection + pragma -hastypemethods no ; # type is not relevant. + pragma -simpledispatch yes ; # simple fast dispatch + + # # ## ### ##### ######## ############# +} + +namespace eval ::vc::fossil::import::cvs::file { + namespace export trunk +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide vc::fossil::import::cvs::file::trunk 1.0 +return diff --git a/tools/cvs2fossil/lib/c2f_gtcore.tcl b/tools/cvs2fossil/lib/c2f_gtcore.tcl new file mode 100644 index 0000000..8087bf3 --- /dev/null +++ b/tools/cvs2fossil/lib/c2f_gtcore.tcl @@ -0,0 +1,239 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2007 Andreas Kupries. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## This file provides a helper package implementing the core of +## traversing the nodes of a graph in topological order. This is used +## by the cycle breaker code (not yet), and the import backend. + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.4 ; # Required runtime. +package require snit ; # OO system. +package require struct::graph ; # Graph handling. +package require struct::list ; # Higher order list operations. +package require vc::tools::log ; # User feedback. +package require vc::tools::trouble ; # Error reporting. + +# # ## ### ##### ######## ############# ##################### +## + +snit::type ::vc::fossil::import::cvs::gtcore { + # # ## ### ##### ######## ############# + ## Public API + + typemethod savecmd {cmd} { ::variable mysavecmd $cmd ; return } + typemethod cyclecmd {cmd} { ::variable mycyclecmd $cmd ; return } + typemethod sortcmd {cmd} { ::variable mysortcmd $cmd ; return } + typemethod datacmd {cmd} { ::variable mydatacmd $cmd ; return } + typemethod formatcmd {cmd} { ::variable myformatcmd $cmd ; return } + + # # ## ### ##### ######## ############# + + typemethod traverse {graph {label Traverse}} { + InitializeCandidates $graph + + log write 3 gtcore {$label} + + set k 0 + set max [llength [$graph nodes]] + + while {1} { + while {[WithoutPredecessor $graph node]} { + log progress 2 gtcore $k $max + incr k + + ProcessedHook $graph $node + ShowPendingNodes $graph + $graph node delete $node + } + + if {![llength [$graph nodes]]} break + + CycleHook $graph + InitializeCandidates $graph + } + + log write 3 gtcore Done. + ClearHooks + return + } + + # # ## ### ##### ######## ############# + ## Internal methods + + # Instead of searching the whole graph for the degree-0 nodes in + # each iteration we compute the list once to start, and then only + # update it incrementally based on the outgoing neighbours of the + # node chosen for commit. + + proc InitializeCandidates {graph} { + # bottom = list (list (node, range min, range max)) + ::variable mybottom + foreach node [$graph nodes] { + if {[$graph node degree -in $node]} continue + lappend mybottom [list $node [DataHook $graph $node]] + } + ScheduleCandidates $graph + ShowPendingNodes $graph + return + } + + proc WithoutPredecessor {graph nodevar} { + ::variable mybottom + + upvar 1 $nodevar node + if {![llength $mybottom]} { return 0 } + + set node [lindex [lindex $mybottom 0] 0] + set mybottom [lrange $mybottom 1 end] + set changed 0 + + # Update list of nodes without predecessor, based on the + # outgoing neighbours of the chosen node. This should be + # faster than iterating of the whole set of nodes, finding all + # without predecessors, sorting them by time, etc. pp. + + foreach out [$graph nodes -out $node] { + if {[$graph node degree -in $out] > 1} continue + # Degree-1 neighbour, will have no predecessors after the + # removal of n. Put on the list of candidates we can + # process. + lappend mybottom [list $out [DataHook $graph $out]] + set changed 1 + } + if {$changed} { + ScheduleCandidates $graph + } + + # We do not delete the node immediately, to allow the Save + # procedure to save the dependencies as well (encoded in the + # arcs). + return 1 + } + + proc ScheduleCandidates {graph} { + ::variable mybottom + ::variable mysortcmd + if {[llength $mysortcmd]} { + set mybottom [uplevel \#0 [linsert $mysortcmd end $graph $mybottom]] + } else { + set mybottom [lsort -index 0 -dict $mybottom] + } + return + } + + proc ShowPendingNodes {graph} { + if {[log verbosity?] < 10} return + ::variable mybottom + ::variable myformatcmd + + log write 10 gtcore "Pending..............................." + foreach item [struct::list map $mybottom \ + [linsert $myformatcmd end $graph]] { + log write 10 gtcore "Pending: $item" + } + return + } + + # # ## ### ##### ######## ############# + ## Callback invokation ... + + proc DataHook {graph node} { + # Allow the user of the traverser to a client data to a node + # in the list of nodes available for immediate processing. + # This data can be used by the sort callback. + + ::variable mydatacmd + if {![llength $mydatacmd]} { return {} } + + return [uplevel \#0 [linsert $mydatacmd end $graph $node]] + } + + proc FormatHook {graph item} { + # Allow the user to format a pending item (node + client data) + # according to its wishes. + + ::variable myformatcmd + if {![llength $myformatcmd]} { return $item } + + return [uplevel \#0 [linsert $myformatcmd end $graph $item]] + } + + proc ProcessedHook {graph node} { + # Give the user of the traverser the opportunity to work with + # the node before it is removed from the graph. + + ::variable mysavecmd + if {![llength $mysavecmd]} return + + uplevel \#0 [linsert $mysavecmd end $graph $node] + return + } + + proc CycleHook {graph} { + # Call out to the chosen algorithm for handling cycles. It is + # an error to find a cycle if no hook was defined. + + ::variable mycyclecmd + if {![llength $mycyclecmd]} { + trouble fatal "Found a cycle, expecting none." + exit 1 + } + + uplevel \#0 [linsert $mycyclecmd end $graph] + return + } + + proc ClearHooks {} { + ::variable mysortcmd {} + ::variable myformatcmd {} + ::variable mydatacmd {} + ::variable mysavecmd {} + ::variable mycyclecmd {} + return + } + + # # ## ### ##### ######## ############# + + typevariable mybottom {} ; # List of the nodes pending traversal. + + typevariable mysortcmd {} ; # Callback, sort list of pending nodes + typevariable mydatacmd {} ; # Callback, get client data for a pending node + typevariable myformatcmd {} ; # Callback, format a pending node for display + typevariable mysavecmd {} ; # Callback, for each processed node. + typevariable mycyclecmd {} ; # Callback, when a cycle was encountered. + + # # ## ### ##### ######## ############# + ## Configuration + + pragma -hasinstances no ; # singleton + pragma -hastypeinfo no ; # no introspection + pragma -hastypedestroy no ; # immortal + + # # ## ### ##### ######## ############# +} + +namespace eval ::vc::fossil::import::cvs { + namespace export gtcore + namespace eval gtcore { + namespace import ::vc::tools::log + namespace import ::vc::tools::trouble + log register gtcore + } +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide vc::fossil::import::cvs::gtcore 1.0 +return diff --git a/tools/cvs2fossil/lib/c2f_integrity.tcl b/tools/cvs2fossil/lib/c2f_integrity.tcl new file mode 100644 index 0000000..05c17fc --- /dev/null +++ b/tools/cvs2fossil/lib/c2f_integrity.tcl @@ -0,0 +1,964 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2007-2008 Andreas Kupries. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## This package holds a number of integrity checks done on the +## persistent state. This is used by the passes II and IV. + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.4 ; # Required runtime. +package require snit ; # OO system. +package require vc::tools::trouble ; # Error reporting. +package require vc::tools::log ; # User feedback. +package require vc::fossil::import::cvs::state ; # State storage. + +# # ## ### ##### ######## ############# ##################### +## + +snit::type ::vc::fossil::import::cvs::integrity { + # # ## ### ##### ######## ############# + ## Public API + + typemethod assert {expression failmessage} { + set ok [uplevel 1 [list ::expr $expression]] + if {$ok} return + trouble internal [uplevel 1 [list ::subst $failmessage]] + return + } + + typemethod strict {} { + log write 4 integrity {Check database consistency} + + set n 0 + AllButMeta + Meta + return + } + + typemethod metarelaxed {} { + log write 4 integrity {Check database consistency} + + set n 0 + AllButMeta + return + } + + typemethod changesets {} { + log write 4 integrity {Check database consistency} + + set n 0 + RevisionChangesets + TagChangesets + BranchChangesets + return + } + + # # ## ### ##### ######## ############# + ## Internal methods + + proc AllButMeta {} { + # This code performs a number of paranoid checks of the + # database, searching for inconsistent cross-references. + + upvar 1 n n ; # Counter for the checks (we print an id before + # the main label). + + # Find all revisions which disagree with their line of + # development about the project they are owned by. + CheckRev \ + {Revisions and their LODs have to be in the same project} \ + {disagrees with its LOD about owning project} { + SELECT F.name, R.rev + FROM revision R, file F, symbol S + WHERE R.fid = F.fid -- get file of rev + AND R.lod = S.sid -- get symbol of its lod + AND F.pid != S.pid -- disagreement about the owning project + ; + } + # Find all revisions which disgree with their meta data about + # the project they are owned by. + CheckRev \ + {Revisions and their meta data have to be in the same project} \ + {disagrees with its meta data about owning project} { + SELECT F.name, R.rev + FROM revision R, file F, meta M + WHERE R.fid = F.fid -- get file of rev + AND R.mid = M.mid -- get meta of rev + AND F.pid != M.pid -- disagreement about owning project + ; + } + # Find all revisions with a primary child which disagrees + # about the file they belong to. + CheckRev \ + {Revisions and their primary children have to be in the same file} \ + {disagrees with its primary child about the owning file} { + SELECT F.name, R.rev + FROM revision R, revision C, file F + WHERE R.fid = F.fid -- get file of rev + AND R.child IS NOT NULL -- get all with primary children + AND R.child = C.rid -- get primary child + AND C.fid != R.fid -- wrongly in different file + ; + } + + # Find all revisions with a branch parent symbol whose parent + # disagrees about the file they belong to. + CheckRev \ + {Revisions and their branch children have to be in the same file} \ + {at the beginning of its branch and its parent disagree about the owning file} { + SELECT F.name, R.rev + FROM revision R, revision P, file F + WHERE R.fid = F.fid -- get file of rev + AND R.bparent IS NOT NULL -- get first-of-branch revisions + AND R.parent = P.rid -- get out-of-branch parent + AND R.fid != P.fid -- wrongly in different file + ; + } + # Find all revisions with a non-NTDB child which disagrees + # about the file they belong to. + CheckRev \ + {Revisions and their non-NTDB children have to be in the same file} \ + {disagrees with its non-NTDB child about the owning file} { + SELECT F.name, R.rev + FROM revision R, revision C, file F + WHERE R.fid = F.fid -- get file of rev + AND R.dbchild IS NOT NULL -- get last NTDB revisions + AND R.dbchild = C.rid -- get their child + AND C.fid != R.fid -- wrongly in different file + ; + } + # Find all revisions which have a primary child, but the child + # does not have them as parent. + CheckRev \ + {Revisions have to be parents of their primary children} \ + {is not the parent of its primary child} { + SELECT F.name, R.rev + FROM revision R, revision C, file F + WHERE R.fid = F.fid -- get file of rev + AND R.child IS NOT NULL -- get all with primary children + AND R.child = C.rid -- get primary child + AND C.parent != R.rid -- child's parent wrongly not us + ; + } + # Find all revisions which have a primrary child, but the + # child has a branch parent symbol making them brach starters. + CheckRev \ + {Primary children of revisions must not start branches} \ + {is parent of a primary child which is the beginning of a branch} { + SELECT F.name, R.rev + FROM revision R, revision C, file F + WHERE R.fid = F.fid -- get file of rev + AND R.child IS NOT NULL -- get all with primary children + AND R.child = C.rid -- get primary child + AND C.bparent IS NOT NULL -- but indicates to be on branch + ; + } + # Find all revisions without branch parent symbol which have a + # parent, but the parent does not have them as primary child. + CheckRev \ + {Revisions have to be primary children of their parents, if any} \ + {is not the child of its parent} { + SELECT F.name, R.rev + FROM revision R, revision P, file F + WHERE R.fid = F.fid -- get file of revision + AND R.bparent IS NULL -- exclude all first-on-branch revisions + AND R.parent IS NOT NULL -- which are not root of their line + AND R.parent = P.rid -- get in-lod parent + AND P.child != R.rid -- but does not have rev as primary child + ; + } + # Find all revisions with a branch parent symbol which do not + # have a parent. + CheckRev \ + {Branch starting revisions have to have a parent, if not detached} \ + {at the beginning of its branch has no parent, but its branch has} { + SELECT F.name, R.rev + FROM revision R, file F, branch B + WHERE R.fid = F.fid -- get file of revision + AND R.bparent IS NOT NULL -- limit to first-on-branch revisions + AND R.parent IS NULL -- which are detached + AND B.sid = R.bparent -- get branch governing the rev + AND B.fid = R.fid -- in the revision's file + AND B.root IS NOT NULL -- but says that branch is attached + ; + } + # Find all revisions with a branch parent symbol whose parent + # has them as primary child. + CheckRev \ + {Branch starting revisions must not be primary children of their parents} \ + {at the beginning of its branch is the primary child of its parent} { + SELECT F.name, R.rev + FROM revision R, revision P, file F + WHERE R.fid = F.fid -- get file of revision + AND R.bparent IS NOT NULL -- limit to first-on-branch revisions + AND R.parent IS NOT NULL -- which are attached + AND R.parent = P.rid -- get out-of-branch parent + AND P.child = R.rid -- wrongly has rev as primary child + ; + } + # Find all revisions with a non-NTDB child which are not on + # the NTDB. + CheckRev \ + {NTDB to trunk transition has to begin on NTDB} \ + {has a non-NTDB child, yet is not on the NTDB} { + SELECT F.name, R.rev + FROM revision R, file F + WHERE R.fid = F.fid -- get file of revision + AND R.dbchild IS NOT NULL -- limit to last NTDB revision + AND NOT R.isdefault -- but signals not-NTDB + ; + } + # Find all revisions with a NTDB parent which are on the NTDB. + CheckRev \ + {NTDB to trunk transition has to end on non-NTDB} \ + {has a NTDB parent, yet is on the NTDB} { + SELECT F.name, R.rev + FROM revision R, file F + WHERE R.fid = F.fid -- get file of revision + AND R.dbparent IS NOT NULL -- limit to roots of non-NTDB + AND R.isdefault -- but signals to be NTDB + ; + } + # Find all revisions with a child which disagrees about the + # line of development they belong to. + CheckRev \ + {Revisions and their primary children have to be in the same LOD} \ + {and its primary child disagree about their LOD} { + SELECT F.name, R.rev + FROM revision R, revision C, file F + WHERE R.fid = F.fid -- get file of revision + AND R.child IS NOT NULL -- revision has a primary child + AND R.child = C.rid -- get that child + AND C.lod != R.lod -- child wrongly disagrees with lod + ; + } + # Find all revisions with a non-NTDB child which agrees about + # the line of development they belong to. + CheckRev \ + {NTDB and trunk revisions have to be in different LODs} \ + {on NTDB and its non-NTDB child wrongly agree about their LOD} { + SELECT F.name, R.rev + FROM revision R, revision C, file F + WHERE R.fid = F.fid -- get file of revision + AND R.dbchild IS NOT NULL -- limit to last NTDB revision + AND R.dbchild = C.rid -- get non-NTDB child + AND C.lod = R.lod -- child wrongly has same lod + ; + } + # Find all revisions with a branch parent symbol which is not + # their LOD. + CheckRev \ + {Branch starting revisions have to have their LOD as branch parent symbol} \ + {at the beginning of its branch does not have the branch symbol as its LOD} { + SELECT F.name, R.rev + FROM revision R, file F + WHERE R.fid = F.fid -- get file of revision + AND R.bparent IS NOT NULL -- limit to branch-first revisions + AND R.lod != R.bparent -- out-of-branch parent wrongly is not the lod + ; + } + # Find all revisions with a branch parent symbol whose parent + # is in the same line of development. + CheckRev \ + {Revisions and their branch children have to be in different LODs} \ + {at the beginning of its branch and its parent wrongly agree about their LOD} { + SELECT F.name, R.rev + FROM revision R, revision P, file F + WHERE R.fid = F.fid -- get file of revision + AND R.bparent IS NOT NULL -- limit to branch-first revisions + AND R.parent = P.rid -- get out-of-branch parent of revision + AND R.lod = P.lod -- rev and parent wrongly agree on lod + ; + } + return + } + + proc Meta {} { + # This code performs a number of paranoid checks of the + # database, searching for inconsistent cross-references. + + upvar 1 n n ; # Counter for the checks (we print an id before + # the main label). + + # Find all revisions which disgree with their meta data about + # the branch/line of development they belong to. + CheckRev \ + {Revisions and their meta data have to be in the same LOD} \ + {disagrees with its meta data about owning LOD} { + SELECT F.name, R.rev + FROM revision R, meta M, file F + WHERE R.mid = M.mid -- get meta data of revision + AND R.lod != M.bid -- rev wrongly disagrees with meta about lod + AND R.fid = F.fid -- get file of revision + ; + } + return + } + + proc RevisionChangesets {} { + # This code performs a number of paranoid checks of the + # database, searching for inconsistent changeset/revision + # information. + + upvar 1 n n ; # Counter for the checks (we print an id before + # the main label). + + # Find all revisions which are not used by at least one + # changeset. + CheckRev \ + {All revisions have to be used by least one changeset} \ + {is not used by a revision changeset} { + -- Unused revisions = All revisions + -- - revisions used by revision changesets. + -- + -- Both sets can be computed easily, and subtracted + -- from each other. Then we can get the associated + -- file (name) for display. + + SELECT F.name, R.rev + FROM revision R, file F + WHERE R.rid IN (SELECT rid + FROM revision -- All revisions + EXCEPT -- subtract + SELECT CI.iid + FROM csitem CI, changeset C -- revisions used + WHERE C.cid = CI.cid -- by any revision + AND C.type = 0) -- changeset + AND R.fid = F.fid -- get file of unused revision + } + # Find all revisions which are used by more than one + # changeset. + CheckRev \ + {All revisions have to be used by at most one changeset} \ + {is used by multiple changesets} { + -- Principle of operation: Get all revision/changeset + -- pairs for all revision changesets, group by + -- revision to aggregate the changeset, counting + -- them. From the resulting revision/count table + -- select those with more than one user, and get their + -- associated file (name) for display. + + SELECT F.name, R.rev + FROM revision R, file F, + (SELECT CI.iid AS rid, -- revision item + count(CI.cid) AS count -- number of csets using item + FROM csitem CI, changeset C + WHERE C.type = 0 -- limit to revision csets + AND C.cid = CI.cid -- get item in changeset + GROUP BY CI.iid -- aggregate by item, count csets/item + ) AS U + WHERE U.count > 1 -- limit to item with multiple users + AND R.rid = U.rid -- get revision of item + AND R.fid = F.fid -- get file of revision + } + # All revisions have to refer to the same meta information as + # their changeset. + CheckRevCS \ + {All revisions have to agree with their changeset about the used meta information} \ + {disagrees with its changeset @ about the meta information} { + SELECT CT.name, C.cid, F.name, R.rev + FROM changeset C, cstype CT, revision R, file F, csitem CI + WHERE C.type = 0 -- revision changesets only + AND C.cid = CI.cid -- changeset --> its revisions + AND R.rid = CI.iid -- look at them + AND R.mid != C.src -- Only those which disagree with changeset about the meta + AND R.fid = F.fid -- get file of the revision + AND CT.tid = C.type -- get changeset type, for labeling + } + # All revisions have to agree on the LOD their changeset + # belongs to. In other words, all revisions in a changeset + # have to refer to the same line of development. + # + # Instead of looking at all pairs of revisions in all + # changesets we generate the distinct set of all LODs + # referenced by the revisions of a changeset, look for those + # with cardinality > 1, and get the identifying information + # for the changesets found thusly. + CheckCS \ + {All revisions in a changeset have to belong to the same LOD} \ + {: Its revisions disagree about the LOD they belong to} { + SELECT T.name, C.cid + FROM changeset C, cstype T + WHERE C.cid IN (SELECT U.cid + FROM (SELECT DISTINCT -- unique cset/lod pairs + CI.cid AS cid, -- revision cset + R.lod AS lod -- lod of item in cset + FROM csitem CI, changeset C, revision R + WHERE CI.iid = R.rid -- get rev of item in cset + AND C.cid = CI.cid -- get changeset of item + AND C.type = 0 -- limit to rev csets + ) AS U + GROUP BY U.cid -- aggregate by cset, count lods/cset + HAVING COUNT(U.lod) > 1 -- find csets with multiple lods + ) + AND T.tid = C.type + } + # All revisions have to agree on the project their changeset + # belongs to. In other words, all revisions in a changeset + # have to refer to the same project. + # + # Instead of looking at all pairs of revisions in all + # changesets we generate the distinct set of all projects + # referenced by the revisions of a changeset, look for those + # with cardinality > 1, and get the identifying information + # for the changesets found thusly. + CheckCS \ + {All revisions in a changeset have to belong to the same project} \ + {: Its revisions disagree about the project they belong to} { + SELECT T.name, C.cid + FROM changeset C, cstype T + WHERE C.cid IN (SELECT U.cid + FROM (SELECT DISTINCT -- unique cset/proj pairs + CI.cid AS cid, -- rev cset + F.pid AS pid -- project of item in cset + FROM csitem CI, changeset C, revision R, file F + WHERE CI.iid = R.rid -- get rev of item in cset + AND C.cid = CI.cid -- get changeset of item + AND C.type = 0 -- limit to rev changesets + AND F.fid = R.fid -- get file of revision + ) AS U + GROUP BY U.cid -- aggregate by csets, count proj/cset + HAVING COUNT(U.pid) > 1 -- find csets with multiple projects + ) + AND T.tid = C.type -- get readable changeset type + } + # All revisions in a single changeset have to belong to + # different files. Conversely: No two revisions of a single + # file are allowed to be in the same changeset. + # + # Instead of looking at all pairs of revisions in all + # changesets we generate the distinct set of all files + # referenced by the revisions of a changeset, and look for + # those with cardinality < the cardinality of the set of + # revisions, and get the identifying information for the + # changesets found thusly. + CheckCS \ + {All revisions in a changeset have to belong to different files} \ + {: Its revisions share files} { + SELECT T.name, C.cid + FROM changeset C, cstype T + WHERE C.cid IN (SELECT VV.cid + FROM (SELECT U.cid AS cid, -- rev changeset + COUNT (U.fid) AS fcount -- number of files by items + FROM (SELECT DISTINCT -- unique cset/file pairs + CI.cid AS cid, -- rev changeset + R.fid AS fid -- file of item in changeset + FROM csitem CI, changeset C, revision R + WHERE CI.iid = R.rid -- get rev of item in changeset + AND C.cid = CI.cid -- get changeset of item + AND C.type = 0 -- limit to rev csets + ) AS U + GROUP BY U.cid -- aggregate by csets, count files/cset + ) AS UU, + (SELECT V.cid AS cid, -- rev changeset + COUNT (V.iid) AS rcount -- number of items + FROM csitem V, changeset X + WHERE X.cid = V.cid -- get changeset of item + AND X.type = 0 -- limit to rev csets + GROUP BY V.cid -- aggregate by csets, count items/cset + ) AS VV + WHERE VV.cid = UU.cid -- sync #items/cset with #files/cset + AND UU.fcount < VV.rcount -- less files than items + -- => items belong to the same file. + ) + AND T.tid = C.type -- get readable changeset type + } + return + } + + proc TagChangesets {} { + # This code performs a number of paranoid checks of the + # database, searching for inconsistent changeset/revision + # information. + + upvar 1 n n ; # Counter for the checks (we print an id before + # the main label). + + # Find all tags which are not used by at least one changeset. + CheckTag \ + {All tags have to be used by least one changeset} \ + {is not used by a tag symbol changeset} { + -- Unused tags = All tags + -- - revisions used by tag changesets. + -- + -- Both sets can be computed easily, and subtracted + -- from each other. Then we can get the associated + -- file (name) for display. + + SELECT P.name, S.name + FROM project P, tag T, symbol S + WHERE T.tid IN (SELECT tid -- All tags + FROM tag + EXCEPT -- subtract + SELECT CI.iid -- tags used + FROM csitem CI, changeset C + WHERE C.cid = CI.cid -- by any tag + AND C.type = 1) -- changeset + AND S.sid = T.sid -- get symbol of tag + AND P.pid = S.pid -- get project of symbol + } + # Find all tags which are used by more than one changeset. + CheckRev \ + {All tags have to be used by at most one changeset} \ + {is used by multiple changesets} { + -- Principle of operation: Get all tag/changeset pairs + -- for all tag changesets, group by tag to aggregate + -- the changeset, counting them. From the resulting + -- tag/count table select those with more than one + -- user, and get their associated file (name) for + -- display. + + SELECT P.name, S.name + FROM tag T, project P, symbol S, + (SELECT CI.iid AS iid, -- item + count(CI.cid) AS count -- number of csets using item + FROM csitem CI, changeset C + WHERE C.type = 1 -- limit to tag csets + AND C.cid = CI.cid -- get items of cset + GROUP BY CI.iid -- aggregate by item, count csets/item + ) AS U + WHERE U.count > 1 -- find tag item used multiple times + AND T.tid = U.iid -- get tag of item + AND S.sid = T.sid -- get symbol of tag + AND P.pid = S.pid -- get project of symbol + } + if 0 { + # This check is disabled for the moment. Apparently tags + # can cross lines of development, at least if the involved + # LODs are the trunk, and the NTDB. That makes sense, as + # the NTDB revisions are initially logically a part of the + # trunk. The standard check below however does not capture + # this. When I manage to rephrase it to accept this type + # of cross-over it will be re-activated. + + # All tags have to agree on the LOD their changeset + # belongs to. In other words, all tags in a changeset have + # to refer to the same line of development. + # + # Instead of looking at all pairs of tags in all + # changesets we generate the distinct set of all LODs + # referenced by the tags of a changeset, look for those + # with cardinality > 1, and get the identifying + # information for the changesets found thusly. + CheckCS \ + {All tags in a changeset have to belong to the same LOD} \ + {: Its tags disagree about the LOD they belong to} { + SELECT T.name, C.cid + FROM changeset C, cstype T + WHERE C.cid IN (SELECT U.cid + FROM (SELECT DISTINCT CI.cid AS cid, T.lod AS lod + FROM csitem CI, changeset C, tag T + WHERE CI.iid = T.tid + AND C.cid = CI.cid + AND C.type = 1) AS U + GROUP BY U.cid HAVING COUNT(U.lod) > 1) + AND T.tid = C.type + } + } + # All tags have to agree on the project their changeset + # belongs to. In other words, all tags in a changeset have to + # refer to the same project. + # + # Instead of looking at all pairs of tags in all changesets we + # generate the distinct set of all projects referenced by the + # tags of a changeset, look for those with cardinality > 1, + # and get the identifying information for the changesets found + # thusly. + CheckCS \ + {All tags in a changeset have to belong to the same project} \ + {: Its tags disagree about the project they belong to} { + SELECT T.name, C.cid + FROM changeset C, cstype T + WHERE C.cid IN (SELECT U.cid + FROM (SELECT DISTINCT -- unique cset/proj pairs + CI.cid AS cid, -- tag cset + F.pid AS pid -- project of item in cset + FROM csitem CI, changeset C, tag T, file F + WHERE CI.iid = T.tid -- get tag of item in cset + AND C.cid = CI.cid -- get changeset of item + AND C.type = 1 -- limit to tag changesets + AND F.fid = T.fid -- get file of tag + ) AS U + GROUP BY U.cid -- aggregate by csets, count proj/cset + HAVING COUNT(U.pid) > 1 -- find csets with multiple projects + ) + AND T.tid = C.type -- get readable changeset type + } + # All tags in a single changeset have to belong to different + # files. Conversely: No two tags of a single file are allowed + # to be in the same changeset. + # + # Instead of looking at all pairs of tags in all changesets we + # generate the distinct set of all files referenced by the + # tags of a changeset, and look for those with cardinality < + # the cardinality of the set of tags, and get the identifying + # information for the changesets found thusly. + CheckCS \ + {All tags in a changeset have to belong to different files} \ + {: Its tags share files} { + SELECT T.name, C.cid + FROM changeset C, cstype T + WHERE C.cid IN (SELECT VV.cid + FROM (SELECT U.cid AS cid, -- changeset + COUNT (U.fid) AS fcount -- number of files by items + FROM (SELECT DISTINCT -- unique cset/file pairs + CI.cid AS cid, -- tag changeset + T.fid AS fid -- file of item in changeset + FROM csitem CI, changeset C, tag T + WHERE CI.iid = T.tid -- get tag of item in changeset + AND C.cid = CI.cid -- get changeset of item + AND C.type = 1 -- limit to tag changesets + ) AS U + GROUP BY U.cid -- aggregate by csets, count files/cset + ) AS UU, + (SELECT V.cid AS cid, -- changeset + COUNT (V.iid) AS rcount -- number of items in cset + FROM csitem V, changeset X + WHERE X.cid = V.cid -- get changeset of item + AND X.type = 1 -- limit to tag changesets + GROUP BY V.cid -- aggregate by csets, count items/cset + ) AS VV + WHERE VV.cid = UU.cid -- sync #items/cset with #files/cset + AND UU.fcount < VV.rcount -- less files than items + -- => items belong to the same file. + ) + AND T.tid = C.type -- get readable changeset type + } + return + } + + proc BranchChangesets {} { + # This code performs a number of paranoid checks of the + # database, searching for inconsistent changeset/revision + # information. + + upvar 1 n n ; # Counter for the checks (we print an id before + # the main label). + + # Find all branches which are not used by at least one + # changeset. + CheckBranch \ + {All branches have to be used by least one changeset} \ + {is not used by a branch symbol changeset} { + -- Unused branches = All branches + -- - branches used by branch changesets. + -- + -- Both sets can be computed easily, and subtracted + -- from each other. Then we can get the associated + -- file (name) for display. + + SELECT P.name, S.name + FROM project P, branch B, symbol S + WHERE B.bid IN (SELECT bid -- All branches + FROM branch + EXCEPT -- subtract + SELECT CI.iid -- branches used + FROM csitem CI, changeset C + WHERE C.cid = CI.cid -- by any branch + AND C.type = 2 -- changeset + ) + AND S.sid = B.sid -- get symbol of branch + AND P.pid = S.pid -- get project of symbol + } + # Find all branches which are used by more than one changeset. + CheckRev \ + {All branches have to be used by at most one changeset} \ + {is used by multiple changesets} { + -- Principle of operation: Get all branch/changeset + -- pairs for all branch changesets, group by tag to + -- aggregate the changeset, counting them. From the + -- resulting branch/count table select those with more + -- than one user, and get their associated file (name) + -- for display. + + SELECT P.name, S.name + FROM branch B, project P, symbol S, + (SELECT CI.iid AS iid, -- item + count(CI.cid) AS count -- number of csets for item + FROM csitem CI, changeset C + WHERE C.type = 2 -- limit to branch changesets, + AND C.cid = CI.cid -- get the items they contain, + GROUP BY CI.iid -- aggregate by items, count csets/item (x) + ) AS U + WHERE U.count > 1 -- find items used multiple times + AND B.bid = U.iid -- get the users (branch changesets) + AND S.sid = B.sid -- get symbol of branch + AND P.pid = S.pid -- get project of symbol + } + if 0 { + # This check has been disabled. When the converter was run + # on the Tcl CVS several branches tripped this + # constraint. One of them was a free-floating branch, and + # its handling has been fixed by now. The others however + # seem semi-legitimate, in the sense that they show + # inconsistencies in the CVS history the user is not + # really able to solve, but it might be possible to simply + # ignore them. + + # For example in Tcl we have a branch X with a prefered + # parent Y, except for a single file where the prefered + # parent seems to be created after its current parent, + # making re-parenting impossible. However we may be able + # to ignore this, it should only cause the branch to have + # more than one predecessor, and shifting it around in the + # commit order. The backend would still use the prefered + # parent for the attachment point in fossil. + + # So, for now I have decided to disable this and press + # forward. Of course, if we run into actual trouble we + # will have to go back here see what can be done to fix + # this. Even if only giving the user the instruction how + # to edit the CVS repository to remove the inconsistency. + + # All branches have to agree on the LOD their changeset + # belongs to. In other words, all branches in a changeset + # have to refer to the same line of development. + # + # Instead of looking at all pairs of branches in all + # changesets we generate the distinct set of all LODs + # referenced by the branches of a changeset, look for + # those with cardinality > 1, and get the identifying + # information for the changesets found thusly. + CheckCS \ + {All branches in a changeset have to belong to the same LOD} \ + {: Its branches disagree about the LOD they belong to} { + SELECT T.name, C.cid + FROM changeset C, cstype T + WHERE C.cid IN (SELECT U.cid + FROM (SELECT DISTINCT CI.cid AS cid, B.lod AS lod + FROM csitem CI, changeset C, branch B + WHERE CI.iid = B.bid + AND C.cid = CI.cid + AND C.type = 2) AS U + GROUP BY U.cid HAVING COUNT(U.lod) > 1) + AND T.tid = C.type + } + } + # All branches have to agree on the project their changeset + # belongs to. In other words, all branches in a changeset have + # to refer to the same project. + # + # Instead of looking at all pairs of branches in all + # changesets we generate the distinct set of all projects + # referenced by the branches of a changeset, look for those + # with cardinality > 1, and get the identifying information + # for the changesets found thusly. + CheckCS \ + {All branches in a changeset have to belong to the same project} \ + {: Its branches disagree about the project they belong to} { + SELECT T.name, C.cid + FROM changeset C, cstype T + WHERE C.cid IN (SELECT U.cid + FROM (SELECT DISTINCT -- Unique cset/proj pairs + CI.cid AS cid, -- Branch cset + F.pid AS pid -- Project of item in cset + FROM csitem CI, changeset C, branch B, file F + WHERE CI.iid = B.bid -- get branch of item in cset + AND C.cid = CI.cid -- get changeset of item + AND C.type = 2 -- limit to branch changesets + AND F.fid = B.fid -- get file of branch + ) AS U + GROUP BY U.cid -- aggregate by csets, count proj/cset + HAVING COUNT(U.pid) > 1 -- find cset with multiple projects + ) + AND T.tid = C.type -- get readable changeset type + } + # All branches in a single changeset have to belong to + # different files. Conversely: No two branches of a single + # file are allowed to be in the same changeset. + # + # Instead of looking at all pairs of branches in all + # changesets we generate the distinct set of all files + # referenced by the branches of a changeset, and look for + # those with cardinality < the cardinality of the set of + # branches, and get the identifying information for the + # changesets found thusly. + CheckCS \ + {All branches in a changeset have to belong to different files} \ + {: Its branches share files} { + SELECT T.name, C.cid + FROM changeset C, cstype T + WHERE C.cid IN (SELECT VV.cid + FROM (SELECT U.cid AS cid, -- changeset + COUNT (U.fid) AS fcount -- number of files by items + FROM (SELECT DISTINCT -- unique cset/file pairs + CI.cid AS cid, -- Branch changeset + B.fid AS fid -- File of item in changeset + FROM csitem CI, changeset C, branch B + WHERE CI.iid = B.bid -- get tag of item in changeset + AND C.cid = CI.cid -- get changeset of item + AND C.type = 2 -- limit to branch changesets + ) AS U + GROUP BY U.cid -- aggregate by csets, count files/cset + ) AS UU, + (SELECT V.cid AS cid, -- changeset + COUNT (V.iid) AS rcount -- number of items in cset + FROM csitem V, changeset X + WHERE X.cid = V.cid -- get changeset of item + AND X.type = 2 -- limit to branch changesets + GROUP BY V.cid -- aggregate by csets, count items/cset + ) AS VV + WHERE VV.cid = UU.cid -- sync #items/cset with #files/cset + AND UU.fcount < VV.rcount -- less files than items + -- => items belong to the same file. + ) + AND T.tid = C.type -- get readable changeset type + } + return + } + + proc ___UnusedChangesetChecks___ {} { + # This code performs a number of paranoid checks of the + # database, searching for inconsistent changeset/revision + # information. + + return ; # Disabled for now, bottlenecks ... + + upvar 1 n n ; # Counter for the checks (we print an id before + # the main label). + + # The next two checks are BOTTLENECKS. In essence we are + # checking each symbol changeset one by one. + + # TODO: Try to rephrase the checks to make more use of + # indices, set and stream operations. + + # All revisions used by tag symbol changesets have to have the + # changeset's tag associated with them. + CheckRevCS \ + {All revisions used by tag symbol changesets have to have the changeset's tag attached to them} \ + {does not have the tag of its symbol changeset @ attached to it} { + SELECT CT.name, C.cid, F.name, R.rev + FROM changeset C, cstype CT, revision R, file F, csitem CI, tag T + WHERE C.type = 1 -- symbol changesets only + AND C.src = T.sid -- tag only, linked by symbol id + AND C.cid = CI.cid -- changeset --> its revisions + AND R.rid = CI.iid -- look at the revisions + -- and look for the tag among the attached ones. + AND T.sid NOT IN (SELECT TB.sid + FROM tag TB + WHERE TB.rev = R.rid) + AND R.fid = F.fid -- get file of revision + } + + # All revisions used by branch symbol changesets have to have + # the changeset's branch associated with them. + + CheckRevCS \ + {All revisions used by branch symbol changesets have to have the changeset's branch attached to them} \ + {does not have the branch of its symbol changeset @ attached to it} { + SELECT CT.name, C.cid, F.name, R.rev, C.cid + FROM changeset C, cstype CT, revision R, file F, csitem CI, branch B + WHERE C.type = 1 -- symbol changesets only + AND C.src = B.sid -- branches only + AND C.cid = CI.cid -- changeset --> its revisions + AND R.rid = CI.iid -- look at the revisions + -- and look for the branch among the attached ones. + AND B.sid NOT IN (SELECT BB.sid + FROM branch BB + WHERE BB.root = R.rid) + AND R.fid = F.fid -- get file of revision + } + + # TODO + # The state has to contain at least one tag symbol changeset + # for all known tags. + + # TODO + # The state has to contain at least one branch symbol changeset + # for all known branches. + return + } + + + proc CheckRev {header label sql} { + upvar 1 n n + set ok 1 + foreach {fname revnr} [state run $sql] { + set ok 0 + trouble fatal "${revnr}::$fname $label" + } + log write 5 integrity {\[[format %02d [incr n]]\] [expr {$ok ? "Ok " : "Failed"}] ... $header} + return + } + + proc CheckTag {header label sql} { + upvar 1 n n + set ok 1 + foreach {pname sname} [state run $sql] { + set ok 0 + trouble fatal "<$pname tag '$sname'> $label" + } + log write 5 integrity {\[[format %02d [incr n]]\] [expr {$ok ? "Ok " : "Failed"}] ... $header} + return + } + + proc CheckBranch {header label sql} { + upvar 1 n n + set ok 1 + foreach {pname sname} [state run $sql] { + set ok 0 + trouble fatal "<$pname branch '$sname'> $label" + } + log write 5 integrity {\[[format %02d [incr n]]\] [expr {$ok ? "Ok " : "Failed"}] ... $header} + return + } + + proc CheckCS {header label sql} { + upvar 1 n n + set ok 1 + foreach {ctype cid} [state run $sql] { + set ok 0 + trouble fatal "<$ctype $cid> $label" + } + log write 5 integrity {\[[format %02d [incr n]]\] [expr {$ok ? "Ok " : "Failed"}] ... $header} + return + } + + proc CheckRevCS {header label sql} { + upvar 1 n n + set ok 1 + foreach {cstype csid fname revnr} [state run $sql] { + set ok 0 + set b "<$cstype $csid>" + trouble fatal "$fname <$revnr> [string map [list @ $b] $label]" + } + log write 5 integrity {\[[format %02d [incr n]]\] [expr {$ok ? "Ok " : "Failed"}] ... $header} + return + } + + # # ## ### ##### ######## ############# + ## Configuration + + pragma -hasinstances no ; # singleton + pragma -hastypeinfo no ; # no introspection + pragma -hastypedestroy no ; # immortal + + # # ## ### ##### ######## ############# +} + +namespace eval ::vc::fossil::import::cvs { + namespace export integrity + namespace eval integrity { + namespace import ::vc::fossil::import::cvs::state + namespace import ::vc::tools::trouble + namespace import ::vc::tools::log + log register integrity + } +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide vc::fossil::import::cvs::integrity 1.0 +return diff --git a/tools/cvs2fossil/lib/c2f_option.tcl b/tools/cvs2fossil/lib/c2f_option.tcl new file mode 100644 index 0000000..71fbbc8 --- /dev/null +++ b/tools/cvs2fossil/lib/c2f_option.tcl @@ -0,0 +1,284 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2007 Andreas Kupries. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## Option database, processes the command line. Note that not all of +## the option information is stored here. Parts are propagated to +## other pieces of the system and handled there, via option +## delegation + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.4 ; # Required runtime. +package require snit ; # OO system. +package require fileutil ; # Setting a tempdir. +package require vc::tools::trouble ; # Error reporting. +package require vc::tools::log ; # User feedback. +package require vc::tools::mem ; # Memory tracking. +package require vc::tools::misc ; # Misc. path reformatting. +package require vc::fossil::import::cvs::fossil ; # Fossil repository access +package require vc::fossil::import::cvs::pass ; # Pass management +package require vc::fossil::import::cvs::pass::collar ; # Pass I. +package require vc::fossil::import::cvs::repository ; # Repository management +package require vc::fossil::import::cvs::state ; # State storage +package require vc::fossil::import::cvs::integrity ; # State integrity checks. +package require vc::fossil::import::cvs::project::sym ; # Project level symbols +package require vc::fossil::import::cvs::cyclebreaker ; # Breaking dependency cycles. + +# # ## ### ##### ######## ############# ##################### +## + +snit::type ::vc::fossil::import::cvs::option { + # # ## ### ##### ######## ############# + ## Public API, Options. + + # --help, --help-passes, -h + # --version + # -p, --pass, --passes + # --ignore-conflicting-attics + # --convert-dotfiles + # --project + # -v, --verbose + # -q, --quiet + # --state (conversion status, ala config.cache) + # --trunk-only + # --exclude, --force-tag, --force-branch + # --batch + # --fossil PATH + + # -o, --output + # --dry-run + # --symbol-transform RE:XX + + # # ## ### ##### ######## ############# + ## Public API, Methods + + typemethod process {arguments} { + # Syntax of arguments: ?option ?value?...? /path/to/cvs/repository + + while {[IsOption arguments -> option]} { + switch -exact -- $option { + -h - + --help { PrintHelp ; exit 0 } + --help-passes { pass help ; exit 0 } + --version { PrintVersion ; exit 0 } + -p - + --pass - + --passes { pass select [Value arguments] } + --ignore-conflicting-attics { collar ignore_conflicting_attics } + --convert-dotfiles { collar accept_and_convert_dotfiles } + --project { repository add [Value arguments] } + -v - + --verbose { log verbose } + -q - + --quiet { log quiet } + --state { state usedb [Value arguments] } + --trunk-only { repository trunkonly! } + --exclude { project::sym exclude [Value arguments] } + --force-tag { project::sym forcetag [Value arguments] } + --force-branch { project::sym forcebranch [Value arguments] } + --batch { log noprogress } + --dots { cyclebreaker dotsto [Value arguments] } + --watch { cyclebreaker watch [Value arguments] } + --statesavequeriesto { state savequeriesto [Value arguments] } + --fossil { fossil setlocation [Value arguments] } + --memory-limit { mem::setlimit [Value arguments] } + --memory-track { mem::track } + -t - + --tempdir { fileutil::tempdir [Value arguments] } + default { + Usage $badoption$option\n$gethelp + } + } + } + + if {[llength $arguments] > 1} Usage + if {[llength $arguments] < 1} { Usage $nocvs } + repository base [striptrailingslash [lindex $arguments 0]] + + Validate + return + } + + # # ## ### ##### ######## ############# + ## Internal methods, printing information. + + proc PrintHelp {} { + global argv0 + trouble info "Usage: $argv0 $usage" + trouble info "" + trouble info " Information options" + trouble info "" + trouble info " -h, --help Print this message and exit with success" + trouble info " --help-passes Print list of passes and exit with success" + trouble info " --version Print version number of $argv0" + trouble info " -v, --verbose Increase application's verbosity" + trouble info " -q, --quiet Decrease application's verbosity" + trouble info " --batch Disable the progress feedback standard to" + trouble info " interactive use." + trouble info "" + trouble info " Conversion control options" + trouble info "" + trouble info " -p, --pass PASS Run only the specified conversion pass" + trouble info " -p, --passes ?START?:?END? Run only the passes START through END," + trouble info " inclusive." + trouble info "" + trouble info " Passes are specified by name." + trouble info "" + trouble info " --ignore-conflicting-attics" + trouble info " Prevent abort when conflicting archives" + trouble info " were found in both regular and Attic." + trouble info "" + trouble info " --convert-dotfiles" + trouble info " Prevent abort when dot-files were found," + trouble info " causing their conversion to nondot-form" + trouble info " instead." + trouble info "" + trouble info " --state PATH Save state to the specified file, and" + trouble info " load state of previous runs from it too." + trouble info "" + trouble info " --exclude ?PROJECT:?SYMBOL Exclude the named symbol from all or" + trouble info " just the specified project. Both project" + trouble info " and symbol names are glob patterns." + trouble info "" + trouble info " --force-tag ?PROJECT:?SYMBOL" + trouble info " Force the named symbol from all or just" + trouble info " the specified project to be converted as" + trouble info " tag. Both project and symbol names are" + trouble info " glob patterns." + trouble info "" + trouble info " --force-branch ?PROJECT:?SYMBOL" + trouble info " Force the named symbol from all or just" + trouble info " the specified project to be converted as" + trouble info " branch. Both project and symbol names" + trouble info " are glob patterns." + trouble info "" + trouble info " Output control options" + trouble info "" + trouble info " --fossil PATH Specify where to find the fossil execu-" + trouble info " table if cv2fossil could not find it in" + trouble info " the PATH." + trouble info "" + trouble info " --tempdir PATH, -t PATH Specify the path where temporary files" + trouble info " and directories shall go." + trouble info "" + trouble info " Debug options" + trouble info "" + trouble info " --dots PATH Write the changeset graphs before, after," + trouble info " and during breaking the of cycles to the" + trouble info " directory PATH, using GraphViz's dot format" + trouble info "" + trouble info " --memory-track Activate internal tracking of memory usage." + trouble info " Requires execution of cvs2fossil by a tclsh" + trouble info " which provides the \[memory\] command." + trouble info "" + trouble info " --memory-limit BYTES Like --memory-track, but additionally imposes" + trouble info " a limit on the maximual amount of memory the" + trouble info " application is allowed to use." + trouble info "" + + # --project, --cache + # ... + return + } + + proc PrintVersion {} { + global argv0 + set v [package require vc::fossil::import::cvs] + trouble info "$argv0 v$v" + return + } + + proc Usage {{text {}}} { + global argv0 + trouble fatal "Usage: $argv0 $usage" + if {$text ne ""} { trouble fatal "$text" } + exit 1 + } + + # # ## ### ##### ######## ############# + ## Internal methods, command line processing + + typevariable usage "?option ?value?...? cvs-repository-path" + typevariable nocvs " The cvs-repository-path is missing." + typevariable badoption " Bad option " + typevariable gethelp " Use --help to get help." + + proc IsOption {av _ ov} { + upvar 1 $av arguments $ov option + set candidate [lindex $arguments 0] + if {![string match -* $candidate]} {return 0} + set option $candidate + set arguments [lrange $arguments 1 end] + return 1 + } + + proc Value {av} { + upvar 1 $av arguments + set v [lindex $arguments 0] + set arguments [lrange $arguments 1 end] + return $v + } + + # # ## ### ##### ######## ############# + ## Internal methods, state validation + + proc Validate {} { + # Prevent in-depth validation if the options were already bad. + trouble abort? + + fossil validate + repository validate + state setup + + trouble abort? + return + } + + # # ## ### ##### ######## ############# + ## Configuration + + pragma -hasinstances no ; # singleton + pragma -hastypeinfo no ; # no introspection + pragma -hastypedestroy no ; # immortal + + # # ## ### ##### ######## ############# +} + +namespace eval ::vc::fossil::import::cvs { + namespace export option + namespace eval option { + namespace import ::vc::tools::misc::striptrailingslash + namespace import ::vc::fossil::import::cvs::fossil + namespace import ::vc::fossil::import::cvs::pass + namespace import ::vc::fossil::import::cvs::pass::collar + namespace import ::vc::fossil::import::cvs::cyclebreaker + namespace import ::vc::fossil::import::cvs::repository + namespace import ::vc::fossil::import::cvs::state + namespace import ::vc::fossil::import::cvs::integrity + namespace eval project { + namespace import ::vc::fossil::import::cvs::project::sym + } + namespace eval mem { + namespace import ::vc::tools::mem::setlimit + namespace import ::vc::tools::mem::track + } + namespace import ::vc::tools::trouble + namespace import ::vc::tools::log + } +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide vc::fossil::import::cvs::option 1.0 +return diff --git a/tools/cvs2fossil/lib/c2f_pass.tcl b/tools/cvs2fossil/lib/c2f_pass.tcl new file mode 100644 index 0000000..bd8b54a --- /dev/null +++ b/tools/cvs2fossil/lib/c2f_pass.tcl @@ -0,0 +1,243 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2007 Andreas Kupries. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## Pass manager. All passes register here, with code, description, and +## callbacks (... setup, run, finalize). Option processing and help +## query this manager to dynamically create the relevant texts. + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.4 ; # Required runtime. +package require snit ; # OO system. +package require vc::fossil::import::cvs::state ; # State storage +package require vc::fossil::import::cvs::integrity ; # State integrity checks. +package require vc::tools::misc ; # Text formatting +package require vc::tools::trouble ; # Error reporting. +package require vc::tools::log ; # User feedback. +package require struct::list ; # Portable lassign + +# # ## ### ##### ######## ############# ##################### +## + +snit::type ::vc::fossil::import::cvs::pass { + # # ## ### ##### ######## ############# + ## Public API, Methods (Setup, query) + + typemethod define {name description command} { + integrity assert { + ![info exists mydesc($name)] + } {Multiple definitions for pass code '$name'} + lappend mypasses $name + set mydesc($name) $description + set mycmd($name) $command + return + } + + typemethod help {} { + trouble info "" + trouble info "Conversion passes:" + trouble info "" + set n 0 + + set clen [max [struct::list map $mypasses {string length}]] + set cfmt %-${clen}s + set nfmt %[string length [llength $mypasses]]s + + foreach code $mypasses { + trouble info " [format $nfmt $n]: [format $cfmt $code] : $mydesc($code)" + incr n + } + trouble info "" + return + } + + # # ## ### ##### ######## ############# + ## Public API, Methods (Execution) + + typemethod select {passdef} { + set pl [split $passdef :] + if {[llength $pl] > 2} { + trouble fatal "Bad pass definition '$passdef'" + trouble fatal "Expected at most one ':'" + } elseif {[llength $pl] == 2} { + struct::list assign $pl start end + + if {($start eq "") && ($end eq "")} { + trouble fatal "Specify at least one of start- or end-pass" + set ok 0 + } else { + set ok 1 + Ok? $start start ok + Ok? $end end ok + } + + if {$ok} { + set mystart [Convert $start 0] + set myend [Convert $end [expr {[llength $mypasses] - 1}]] + if {$mystart > $myend} { + trouble fatal "Start pass is after end pass" + } + } + } elseif {[llength $pl] < 2} { + set start [lindex $pl 0] + Ok? $start "" __dummy__ 0 + set mystart [Id $start] + set myend $mystart + } + } + + typemethod run {} { + if {$mystart < 0} {set mystart 0} + if {$myend < 0} {set myend [expr {[llength $mypasses] - 1}]} + + set skipped [lrange $mypasses 0 [expr {$mystart - 1}]] + set run [lrange $mypasses $mystart $myend] + set defered [lrange $mypasses [expr {$myend + 1}] end] + + foreach p $skipped { + log write 0 pass "Skip $p" + Call $p load + } + foreach p $run { + log write 0 pass "Setup $p" + Call $p setup + } + foreach p $run { + log write 0 pass "Begin $p" + set secbegin [clock seconds] + Call $p run + set secstop [clock seconds] + log write 0 pass "Done $p" + Time $p [expr {$secstop - $secbegin}] + trouble abort? + } + foreach p $defered { + log write 0 pass "Defer $p" + Call $p discard + } + + state release + ShowTimes + return + } + + typemethod current {} { return $mycurrentpass } + + # # ## ### ##### ######## ############# + ## Internal methods + + proc Time {pass seconds} { + ::variable mytime + lappend mytime $pass $seconds + ShowTime $pass $seconds + return + } + + proc ShowTimes {} { + ::variable mytime + set total 0 + foreach {pass seconds} $mytime { + ShowTime $pass $seconds + incr total $seconds + } + ShowTime Total $total + return + } + + proc ShowTime {pass seconds} { + if {$seconds > 3600} { + set hr [expr {$seconds / 3600}] + set min [expr {$seconds % 3600}] + set sec [expr {$min % 60}] + set min [expr {$min / 60}] + + log write 0 pass "[format %8d $seconds] sec/$pass ([nsp $hr hour] [nsp $min minute] [nsp $sec second])" + } elseif {$seconds > 60} { + set min [expr {$seconds / 60}] + set sec [expr {$seconds % 60}] + + log write 0 pass "[format %8d $seconds] sec/$pass ([nsp $min minute] [nsp $sec second])" + } else { + log write 0 pass "[format %8d $seconds] sec/$pass" + } + return + } + + proc Ok? {code label ov {emptyok 1}} { + upvar 1 $ov ok + ::variable mydesc + if {$emptyok && ($code eq "")} return + if {[info exists mydesc($code)]} return + if {$label ne ""} {append label " "} + trouble fatal "Bad ${label}pass code $code" + set ok 0 + return + } + + proc Convert {code default} { + ::variable mypasses + return [expr {($code eq "") ? $default : [Id $code]}] + } + + proc Id {code} { + ::variable mypasses + return [lsearch -exact $mypasses $code] + } + + proc Call {code args} { + ::variable mycmd + set cmd $mycmd($code) + foreach a $args { lappend cmd $a } + eval $cmd + return + } + + # # ## ### ##### ######## ############# + ## Internal, state + + typevariable mypasses {} ; # List of registered passes (codes). + typevariable mydesc -array {} ; # Pass descriptions (one line). + typevariable mycmd -array {} ; # Pass callback command. + + typevariable mystart -1 + typevariable myend -1 + typevariable mytime {} ; # Timing data for each executed pass. + typevariable mycurrentpass {} ; # Pass currently running. + + # # ## ### ##### ######## ############# + ## Configuration + + pragma -hasinstances no ; # singleton + pragma -hastypeinfo no ; # no introspection + pragma -hastypedestroy no ; # immortal + + # # ## ### ##### ######## ############# +} + +namespace eval ::vc::fossil::import::cvs { + namespace export pass + namespace eval pass { + namespace import ::vc::fossil::import::cvs::state + namespace import ::vc::fossil::import::cvs::integrity + namespace import ::vc::tools::misc::* + namespace import ::vc::tools::trouble + namespace import ::vc::tools::log + log register pass + } +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide vc::fossil::import::cvs::pass 1.0 +return diff --git a/tools/cvs2fossil/lib/c2f_patopsort.tcl b/tools/cvs2fossil/lib/c2f_patopsort.tcl new file mode 100644 index 0000000..e0dd439 --- /dev/null +++ b/tools/cvs2fossil/lib/c2f_patopsort.tcl @@ -0,0 +1,210 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2007 Andreas Kupries. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## Pass XI. This pass goes over all changesets and sorts them +## topologically. It assumes that there are no cycles which could +## impede it, any remaining having been broken by the previous two +## passes, and aborts if that condition doesn't hold. + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.4 ; # Required runtime. +package require snit ; # OO system. +package require struct::list ; # Higher order list operations. +package require vc::tools::log ; # User feedback. +package require vc::fossil::import::cvs::cyclebreaker ; # Breaking dependency cycles. +package require vc::fossil::import::cvs::state ; # State storage. +package require vc::fossil::import::cvs::project::rev ; # Project level changesets + +# # ## ### ##### ######## ############# ##################### +## Register the pass with the management + +vc::fossil::import::cvs::pass define \ + AllTopologicalSort \ + {Topologically Sort All ChangeSets} \ + ::vc::fossil::import::cvs::pass::atopsort + +# # ## ### ##### ######## ############# ##################### +## + +snit::type ::vc::fossil::import::cvs::pass::atopsort { + # # ## ### ##### ######## ############# + ## Public API + + typemethod setup {} { + # Define the names and structure of the persistent state of + # this pass. + + state use revision + state use tag + state use branch + state use symbol + state use changeset + state use csitem + state use cssuccessor + state use csorder + + state extend cstimestamp { + -- Commit order of all changesets based on their + -- dependencies, plus a monotonically increasing + -- timestamp. + + cid INTEGER NOT NULL REFERENCES changeset, + pos INTEGER NOT NULL, + date INTEGER NOT NULL, + UNIQUE (cid), + UNIQUE (pos), + UNIQUE (date) + } + return + } + + typemethod load {} { + # Pass manager interface. Executed to load data computed by + # this pass into memory when this pass is skipped instead of + # executed. + return + } + + typemethod run {} { + # Pass manager interface. Executed to perform the + # functionality of the pass. + + set len [string length [project::rev num]] + set myatfmt %${len}s + incr len 12 + set mycsfmt %${len}s + + cyclebreaker savecmd [myproc SaveTimestamps] + + state transaction { + LoadSymbolChangesets + cyclebreaker run tsort-all [myproc Changesets] + } + return + } + + typemethod discard {} { + # Pass manager interface. Executed for all passes after the + # run passes, to remove all data of this pass from the state, + # as being out of date. + + state discard cstimestamp + return + } + + # # ## ### ##### ######## ############# + ## Internal methods + + proc Changesets {} { project::rev all } + + proc LoadSymbolChangesets {} { + # Consider use of 'project::rev sym' here. + set mysymchangesets [struct::list filter [project::rev all] [myproc IsBySymbol]] + return + } + + proc IsBySymbol {cset} { $cset bysymbol } + + proc SaveTimestamps {graph at cset} { + set cid [$cset id] + + set date [GetTime [lindex [$graph node get $cset timerange] 1] \ + [struct::set contains $mysymchangesets $cset] \ + message] + + log write 4 atopsort "Changeset @ [format $myatfmt $at]: [format $mycsfmt [$cset str]] '[$cset lod]' $message" + + state run { + INSERT INTO cstimestamp (cid, pos, date) + VALUES ($cid, $at, $date) + } + return + } + + proc GetTime {stamp expectchange mv} { + ::variable mylasttimestamp + upvar 1 $mv message + set message "" + if {$stamp > $mymaxtimestamp} { + # A timestamp in the future is believed to be bogus and + # shifted backwars in time to prevent it from forcing + # other timestamps to be pushed even further in the + # future. + + # From cvs2svn: Note that this is not nearly a complete + # solution to the bogus timestamp problem. A timestamp in + # the future still affects the ordering of changesets, and + # a changeset having such a timestamp will not be + # committed until all changesets with earlier timestamps + # have been committed, even if other changesets with even + # earlier timestamps depend on this one. + + incr mylasttimestamp + if {!$expectchange} { + set message " Timestamp [clock format $stamp] is in the future; shifted back to [clock format $mylasttimestamp] ([expr {$mylasttimestamp - $stamp}])" + } + } elseif {$stamp < ($mylasttimestamp)+1} { + incr mylasttimestamp + if {!$expectchange} { + set message " Timestamp [clock format $stamp] adjusted to [clock format $mylasttimestamp] (+[expr {$mylasttimestamp - $stamp}])" + } + } else { + set mylasttimestamp $stamp + } + return $mylasttimestamp + } + + typevariable myatfmt ; # Format for log output to gain better alignment of the various columns. + typevariable mycsfmt ; # Ditto for the changesets. + + typevariable mysymchangesets {} ; # Set of the symbol changesets. + typevariable mylasttimestamp 0 ; # Last delivered timestamp. + typevariable mymaxtimestamp + + typeconstructor { + # The maximum timestamp considered as reasonable is + # "now + 1 day". + set mymaxtimestamp [clock seconds] + incr mymaxtimestamp 86400 ; # 24h * 60min * 60sec + return + } + + # # ## ### ##### ######## ############# + ## Configuration + + pragma -hasinstances no ; # singleton + pragma -hastypeinfo no ; # no introspection + pragma -hastypedestroy no ; # immortal + + # # ## ### ##### ######## ############# +} + +namespace eval ::vc::fossil::import::cvs::pass { + namespace export atopsort + namespace eval atopsort { + namespace import ::vc::fossil::import::cvs::cyclebreaker + namespace import ::vc::fossil::import::cvs::state + namespace eval project { + namespace import ::vc::fossil::import::cvs::project::rev + } + namespace import ::vc::tools::log + log register atopsort + } +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide vc::fossil::import::cvs::pass::atopsort 1.0 +return diff --git a/tools/cvs2fossil/lib/c2f_pbreakacycle.tcl b/tools/cvs2fossil/lib/c2f_pbreakacycle.tcl new file mode 100644 index 0000000..59841c1 --- /dev/null +++ b/tools/cvs2fossil/lib/c2f_pbreakacycle.tcl @@ -0,0 +1,433 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2007 Andreas Kupries. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## Pass X. This is the final pass for breaking changeset dependency +## cycles. The previous breaker passes (7 and 9) broke cycles covering +## revision and symbol changesets, respectively. This pass now breaks +## any remaining cycles, each of which has to contain at least one +## revision and at least one symbol changeset. + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.4 ; # Required runtime. +package require snit ; # OO system. +package require struct::list ; # Higher order list operations. +package require struct::set ; # Set operations. +package require vc::tools::misc ; # Min, max. +package require vc::tools::log ; # User feedback. +package require vc::tools::trouble ; # Error reporting. +package require vc::fossil::import::cvs::repository ; # Repository management. +package require vc::fossil::import::cvs::cyclebreaker ; # Breaking dependency cycles. +package require vc::fossil::import::cvs::state ; # State storage. +package require vc::fossil::import::cvs::integrity ; # State integrity checks. +package require vc::fossil::import::cvs::project::rev ; # Project level changesets + +# # ## ### ##### ######## ############# ##################### +## Register the pass with the management + +vc::fossil::import::cvs::pass define \ + BreakAllCsetCycles \ + {Break Remaining ChangeSet Dependency Cycles} \ + ::vc::fossil::import::cvs::pass::breakacycle + +# # ## ### ##### ######## ############# ##################### +## + +snit::type ::vc::fossil::import::cvs::pass::breakacycle { + # # ## ### ##### ######## ############# + ## Public API + + typemethod setup {} { + # Define the names and structure of the persistent state of + # this pass. + + state use revision + state use tag + state use branch + state use symbol + state use changeset + state use csitem + state use cssuccessor + return + } + + typemethod load {} { + # Pass manager interface. Executed to load data computed by + # this pass into memory when this pass is skipped instead of + # executed. + return + } + + typemethod run {} { + # Pass manager interface. Executed to perform the + # functionality of the pass. + + set len [string length [project::rev num]] + set myatfmt %${len}s + incr len 12 + set mycsfmt %${len}s + + cyclebreaker precmd [myproc BreakBackward] + cyclebreaker savecmd [myproc KeepOrder] + + state transaction { + LoadCommitOrder + cyclebreaker run break-all [myproc Changesets] + } + + repository printcsetstatistics + integrity changesets + return + } + + typemethod discard {} { + # Pass manager interface. Executed for all passes after the + # run passes, to remove all data of this pass from the state, + # as being out of date. + return + } + + # # ## ### ##### ######## ############# + ## Internal methods + + proc Changesets {} { + log write 2 breakrcycle {Selecting all changesets} + return [project::rev all] + } + + proc LoadCommitOrder {} { + ::variable mycset + ::variable myrevisionchangesets + + log write 2 breakacycle {Loading revision commit order} + + set n 0 + state transaction { + state foreachrow { + SELECT cid, pos FROM csorder + } { + log progress 2 breakacycle $n {} + set cset [project::rev of $cid] + $cset setpos $pos + set mycset($pos) $cset + lappend myrevisionchangesets $cset + incr n + } + } + return + } + + # # ## ### ##### ######## ############# + + proc BreakBackward {graph} { + # We go over all branch changesets, i.e. the changesets + # created by the symbols which are translated as branches, and + # break any which are 'backward', which means that they have + # at least one incoming revision changeset which is committed + # after at least one of the outgoing revision changesets, per + # the order computed in pass 6. In "cvs2svn" this is called + # "retrograde". + + set n 0 + set max [llength [$graph nodes]] + foreach cset [$graph nodes] { + log progress 2 breakacycle $n $max ; incr n + if {![$cset isbranch]} continue + CheckAndBreakBackward $graph $cset + } + return + } + + proc CheckAndBreakBackward {graph cset} { + while {[IsBackward $graph $cset]} { + # Knowing that the branch changeset is backward we now + # look at the individual branches in the changeset and + # determine which of them are responsible for the + # overlap. This allows us to split them into two sets, one + # of non-overlapping branches, and of overlapping + # ones. Each set induces a new changeset, and the second + # one may still be backward and in need of further + # splitting. Hence the looping. + + # The border used for the split is the minimal commit + # position among the minimal sucessor commit positions for + # the branches in the changeset. We sort the file level + # items based on there they sit relative to the border + # into before and after the border. As the branches cannot + # be backward at file level thos before the border cannot + # generate a backward symbol changeset, however the + # branches after may constitute another backward branch + # with a new border. + + # limits : dict (revision -> list (max predecessor commit, min sucessor commit)) + + ComputeLimits $cset limits border + + log write 5 breakacycle "Breaking backward changeset [$cset str] using commit position $border as border" + + SplitItems $limits $border normalitems backwarditems + + set replacements [project::rev split $cset $normalitems $backwarditems] + cyclebreaker replace $graph $cset $replacements + + # At last we check that the normal frament is indeed not + # backward, and iterate over the possibly still backward + # second fragment. + + struct::list assign $replacements normal backward + integrity assert { + ![IsBackward $graph $normal] + } {The normal fragment is unexpectedly backward} + + set cset $backward + } + return + } + + proc IsBackward {dg cset} { + # A branch is "backward" if it has at least one incoming + # revision changeset which is committed after at least one of + # the outgoing revision changesets, per the order computed by + # pass 6. + + # Rephrased, the maximal commit position found among the + # incoming revision changesets is larger than the minimal + # commit position found among the outgoing revision + # changesets. Assuming that we have both incoming and outgoing + # revision changesets for the branch. + + # The helper "Positions" computes the set of commit positions + # for a set of changesets, which can be a mix of revision and + # symbol changesets. + + set predecessors [Positions [$dg nodes -in $cset]] + set successors [Positions [$dg nodes -out $cset]] + + return [expr { + [llength $predecessors] && + [llength $successors] && + ([max $predecessors] >= [min $successors]) + }] + } + + proc Positions {changesets} { + # To compute the set of commit positions from the set of + # changesets we first map each changeset to its position (*) + # and then filter out the invalid responses (the empty string) + # returned by the symbol changesets. + # + # (*) This data was loaded into memory earlir in the pass, by + # LoadCommitOrder. + + return [struct::list filter [struct::list map $changesets \ + [myproc ToPosition]] \ + [myproc ValidPosition]] + } + + proc ToPosition {cset} { $cset pos } + proc ValidPosition {pos} { expr {$pos ne ""} } + + proc ComputeLimits {cset lv bv} { + upvar 1 $lv thelimits $bv border + + # Individual branches may not have revision changesets which + # are their predecessors and/or successors, leaving the limits + # partially or completely undefined. To overcome this + # initialize boundaries for all items with proper defaults (-1 + # for max, {} for min, representing +infinity). + + array set maxpa {} + array set minsa {} + foreach item [$cset items] { + set maxpa($item) -1 + set minsa($item) {} + } + + # Get the limits from the database, for the items which + # actually have such, and merge the information with the + # defaults. + + struct::list assign [$cset limits] maxpdict minsdict + + array set maxpa $maxpdict + array set minsa $minsdict + + # Check that the ordering at the file level is correct. We + # cannot have backward ordering per branch, or something is + # wrong. + + foreach item [array names limits] { + set mins $minsa($item) + set maxp $maxp($item) + # Note that for the min successor position "" represents + # +infinity + integrity assert { + ($mins eq "") || ($maxp < $mins) + } {Item <$item> is backward at file level ($maxp >= $mins)} + } + + # Save the limits for the splitter, and compute the border at + # which to split as the minimum of all minimal successor + # positions. + + # Compute the border at which to split as the minimum of all + # minimal successor positions. By using the database info we + # automatically/implicitly filter out anything without a min + # successor. Further the data going into the comparison with + # the border is put together. + + set border [min [Values $minsdict]] + set thelimits [array get maxpa] + return + } + + proc Values {dict} { + set res {} + foreach {k v} $dict { lappend res $v } + return $res + } + + proc SplitItems {limits border nv bv} { + upvar 1 $nv normalitems $bv backwarditems + + set normalitems {} + set backwarditems {} + + foreach {item maxp} $limits { + if {$maxp >= $border} { + lappend backwarditems $item + } else { + lappend normalitems $item + } + } + + integrity assert {[llength $normalitems]} {Set of normal items is empty} + integrity assert {[llength $backwarditems]} {Set of backward items is empty} + return + } + + # # ## ### ##### ######## ############# + + proc KeepOrder {graph at cset} { + ::variable myatfmt + ::variable mycsfmt + + set cid [$cset id] + + log write 8 breakacycle "Changeset @ [format $myatfmt $at]: [format $mycsfmt [$cset str]] <<[FormatTR $graph $cset]>>" + + # We see here a mixture of symbol and revision changesets. + # The symbol changesets are ignored as irrelevant. + + if {[$cset pos] eq ""} return + + # For the revision changesets we are sure that they are + # consumed in the same order as generated by pass 7 + # (RevTopologicalSort). Per the code in cvs2svn. + + # This works if and only if none of the symbol changesets are + # "backwards", hence our breaking of the backward changesets + # first, in the pre-hook. + + # Note that tag changesets cannot be backward as they don't + # have successors at all. + + # An interesting thing IMHO, is that after breaking the + # backward symbol changesets we should not have any circles + # any longer. Each circle which would still be present has to + # involve a backward symbol, and we split them all, so there + # can't be a circle.. + + # Proof: + # Let us assume we that have a circle + # C: R1 -> ... -> Rx -> S -> Ry -> ... -> Rn -> R1 + # Let us further assume that the symbol changeset S in that + # circle is not backward. That means ORD(Rx) < ORD(Ry). The + # earlier topological sorting without symbols now forces this + # relationship through to be ORD(Rx) < ORD(R1) < ORD(Rx). We + # have reached an impossibility, a paradox. Our initial + # assumption of S not being backward cannot hold. + # + # Alternate, direct, reasoning: Without S the chain of + # dependencies is Ry -> .. -> R1 -> .. -> Rx, therefore + # ORD(Ry) < ORD(Rx) holds, and this means S is backward. + + struct::set exclude myrevisionchangesets $cset + + ::variable mylastpos + set new [$cset pos] + + if {$new != ($mylastpos + 1)} { + if {$mylastpos < 0} { + set old "<NONE>" + } else { + ::variable mycset + set old [$mycset($mylastpos) str]@$mylastpos + } + + #integrity assert 0 {Ordering of revision changesets violated, [$cset str]@$new is not immediately after $old} + log write 2 breakacycle {Ordering of revision changesets violated, [$cset str]@$new is not immediately after $old} + } + + set mylastpos $new + return + } + + proc FormatTR {graph cset} { + return [join [struct::list map [$graph node set $cset timerange] {clock format}] { -- }] + } + + typevariable mylastpos -1 ; # Position of last revision changeset saved. + typevariable myrevisionchangesets {} ; # Set of revision changesets + + typevariable myatfmt ; # Format for log output to gain better alignment of the various columns. + typevariable mycsfmt ; # Ditto for the changesets. + + # # ## ### ##### ######## ############# + + typevariable mycset -array {} ; # Map from commit positions to the + # changeset (object ref) at that + # position. + + # # ## ### ##### ######## ############# + ## Configuration + + pragma -hasinstances no ; # singleton + pragma -hastypeinfo no ; # no introspection + pragma -hastypedestroy no ; # immortal + + # # ## ### ##### ######## ############# +} + +namespace eval ::vc::fossil::import::cvs::pass { + namespace export breakacycle + namespace eval breakacycle { + namespace import ::vc::fossil::import::cvs::cyclebreaker + namespace import ::vc::fossil::import::cvs::repository + namespace import ::vc::fossil::import::cvs::state + namespace import ::vc::fossil::import::cvs::integrity + namespace eval project { + namespace import ::vc::fossil::import::cvs::project::rev + } + namespace import ::vc::tools::misc::* + namespace import ::vc::tools::trouble + namespace import ::vc::tools::log + log register breakacycle + } +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide vc::fossil::import::cvs::pass::breakacycle 1.0 +return diff --git a/tools/cvs2fossil/lib/c2f_pbreakrcycle.tcl b/tools/cvs2fossil/lib/c2f_pbreakrcycle.tcl new file mode 100644 index 0000000..474cd4a --- /dev/null +++ b/tools/cvs2fossil/lib/c2f_pbreakrcycle.tcl @@ -0,0 +1,126 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2007 Andreas Kupries. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## Pass VII. This pass goes over the set of revision based changesets +## and breaks all dependency cycles they may be in. We need a +## dependency tree. Identical to pass IX, except for the selection of +## the changesets. + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.4 ; # Required runtime. +package require snit ; # OO system. +package require struct::list ; # Higher order list operations. +package require vc::tools::log ; # User feedback. +package require vc::fossil::import::cvs::repository ; # Repository management. +package require vc::fossil::import::cvs::cyclebreaker ; # Breaking dependency cycles. +package require vc::fossil::import::cvs::state ; # State storage. +package require vc::fossil::import::cvs::integrity ; # State integrity checks. +package require vc::fossil::import::cvs::project::rev ; # Project level changesets + +# # ## ### ##### ######## ############# ##################### +## Register the pass with the management + +vc::fossil::import::cvs::pass define \ + BreakRevCsetCycles \ + {Break Revision ChangeSet Dependency Cycles} \ + ::vc::fossil::import::cvs::pass::breakrcycle + +# # ## ### ##### ######## ############# ##################### +## + +snit::type ::vc::fossil::import::cvs::pass::breakrcycle { + # # ## ### ##### ######## ############# + ## Public API + + typemethod setup {} { + # Define the names and structure of the persistent state of + # this pass. + + state use revision + state use symbol + state use changeset + state use csitem + state use cstype + state use cssuccessor + + return + } + + typemethod load {} { + # Pass manager interface. Executed to load data computed by + # this pass into memory when this pass is skipped instead of + # executed. + return + } + + typemethod run {} { + # Pass manager interface. Executed to perform the + # functionality of the pass. + + cyclebreaker breakcmd {::vc::fossil::import::cvs::cyclebreaker break} + + state transaction { + cyclebreaker run break-rev [myproc Changesets] + } + + repository printcsetstatistics + integrity changesets + return + } + + typemethod discard {} { + # Pass manager interface. Executed for all passes after the + # run passes, to remove all data of this pass from the state, + # as being out of date. + return + } + + # # ## ### ##### ######## ############# + ## Internal methods + + proc Changesets {} { + log write 2 breakrcycle {Selecting the revision changesets} + return [project::rev rev] + } + + # # ## ### ##### ######## ############# + ## Configuration + + pragma -hasinstances no ; # singleton + pragma -hastypeinfo no ; # no introspection + pragma -hastypedestroy no ; # immortal + + # # ## ### ##### ######## ############# +} + +namespace eval ::vc::fossil::import::cvs::pass { + namespace export breakrcycle + namespace eval breakrcycle { + namespace import ::vc::fossil::import::cvs::cyclebreaker + namespace import ::vc::fossil::import::cvs::repository + namespace import ::vc::fossil::import::cvs::state + namespace import ::vc::fossil::import::cvs::integrity + namespace eval project { + namespace import ::vc::fossil::import::cvs::project::rev + } + namespace import ::vc::tools::log + log register breakrcycle + } +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide vc::fossil::import::cvs::pass::breakrcycle 1.0 +return diff --git a/tools/cvs2fossil/lib/c2f_pbreakscycle.tcl b/tools/cvs2fossil/lib/c2f_pbreakscycle.tcl new file mode 100644 index 0000000..fb5ae5d --- /dev/null +++ b/tools/cvs2fossil/lib/c2f_pbreakscycle.tcl @@ -0,0 +1,126 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2007 Andreas Kupries. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## Pass IX. This pass goes over the set of symbol based changesets and +## breaks all dependency cycles they may be in. We need a dependency +## tree. Identical to pass VII, except for the selection of the +## changesets. + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.4 ; # Required runtime. +package require snit ; # OO system. +package require struct::list ; # Higher order list operations. +package require vc::tools::log ; # User feedback. +package require vc::fossil::import::cvs::cyclebreaker ; # Breaking dependency cycles. +package require vc::fossil::import::cvs::repository ; # Repository management. +package require vc::fossil::import::cvs::state ; # State storage. +package require vc::fossil::import::cvs::integrity ; # State integrity checks. +package require vc::fossil::import::cvs::project::rev ; # Project level changesets + +# # ## ### ##### ######## ############# ##################### +## Register the pass with the management + +vc::fossil::import::cvs::pass define \ + BreakSymCsetCycles \ + {Break Symbol ChangeSet Dependency Cycles} \ + ::vc::fossil::import::cvs::pass::breakscycle + +# # ## ### ##### ######## ############# ##################### +## + +snit::type ::vc::fossil::import::cvs::pass::breakscycle { + # # ## ### ##### ######## ############# + ## Public API + + typemethod setup {} { + # Define the names and structure of the persistent state of + # this pass. + + state use revision + state use tag + state use branch + state use symbol + state use changeset + state use csitem + state use cssuccessor + return + } + + typemethod load {} { + # Pass manager interface. Executed to load data computed by + # this pass into memory when this pass is skipped instead of + # executed. + return + } + + typemethod run {} { + # Pass manager interface. Executed to perform the + # functionality of the pass. + + cyclebreaker breakcmd {::vc::fossil::import::cvs::cyclebreaker break} + + state transaction { + cyclebreaker run break-sym [myproc Changesets] + } + + repository printcsetstatistics + integrity changesets + return + } + + typemethod discard {} { + # Pass manager interface. Executed for all passes after the + # run passes, to remove all data of this pass from the state, + # as being out of date. + return + } + + # # ## ### ##### ######## ############# + ## Internal methods + + proc Changesets {} { + log write 2 breakscycle {Selecting the symbol changesets} + return [project::rev sym] + } + + # # ## ### ##### ######## ############# + ## Configuration + + pragma -hasinstances no ; # singleton + pragma -hastypeinfo no ; # no introspection + pragma -hastypedestroy no ; # immortal + + # # ## ### ##### ######## ############# +} + +namespace eval ::vc::fossil::import::cvs::pass { + namespace export breakscycle + namespace eval breakscycle { + namespace import ::vc::fossil::import::cvs::cyclebreaker + namespace import ::vc::fossil::import::cvs::repository + namespace import ::vc::fossil::import::cvs::state + namespace import ::vc::fossil::import::cvs::integrity + namespace eval project { + namespace import ::vc::fossil::import::cvs::project::rev + } + namespace import ::vc::tools::log + log register breakscycle + } +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide vc::fossil::import::cvs::pass::breakscycle 1.0 +return diff --git a/tools/cvs2fossil/lib/c2f_pcollar.tcl b/tools/cvs2fossil/lib/c2f_pcollar.tcl new file mode 100644 index 0000000..4107444 --- /dev/null +++ b/tools/cvs2fossil/lib/c2f_pcollar.tcl @@ -0,0 +1,337 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2007-2008 Andreas Kupries. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## Pass I. This pass scans the repository to import for RCS archives, +## and sorts and filters them into the declared projects, if any +## Without declared projects the whole repository is treated as a +## single project. + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.4 ; # Required runtime. +package require snit ; # OO system. +package require fileutil::traverse ; # Directory traversal. +package require fileutil ; # File & path utilities. +package require vc::tools::trouble ; # Error reporting. +package require vc::tools::log ; # User feedback. +package require vc::tools::misc ; # Local file utilities. +package require vc::fossil::import::cvs::pass ; # Pass management. +package require vc::fossil::import::cvs::repository ; # Repository management. +package require vc::fossil::import::cvs::state ; # State storage + +# # ## ### ##### ######## ############# ##################### +## Register the pass with the management + +vc::fossil::import::cvs::pass define \ + CollectAr \ + {Collect archives in repository} \ + ::vc::fossil::import::cvs::pass::collar + +# # ## ### ##### ######## ############# ##################### +## + +snit::type ::vc::fossil::import::cvs::pass::collar { + # # ## ### ##### ######## ############# + ## Public API + + typemethod setup {} { + # Define names and structure of the persistent state of this + # pass. + + # We deal with repository projects, and the rcs archive files + # in the projects. + + # For the first, projects, we keep their names, which are + # their paths relative to the base directory of the whole + # repository. These have to be globally unique, i.e. no two + # projects can have the same name. + + # For the files we keep their names, which are their paths + # relative to the base directory of the whole project! These + # have to be unique within a project, however globally this + # does not hold, a name may occur several times, in different + # projects. We further store the user visible file name + # associated with the rcs archive. + + # Both projects and files are identified by globally unique + # integer ids, automatically assigned by the database. + + state extend project { + pid INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT, + name TEXT NOT NULL UNIQUE + } + state extend file { + fid INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT, + pid INTEGER NOT NULL REFERENCES project, -- project the file belongs to + name TEXT NOT NULL, + visible TEXT NOT NULL, + exec INTEGER NOT NULL, -- boolean, 'file executable'. + UNIQUE (pid, name) -- file names are unique within a project + } + return + } + + typemethod load {} { + # Pass manager interface. Executed for all passes before the + # run passes, to load all data of their pass from the state, + # as if it had been computed by the pass itself. + + state use project + state use file + + repository load + return + } + + typemethod run {} { + # Pass manager interface. Executed to perform the + # functionality of the pass. + + set rbase [repository base?] + foreach project [repository projects] { + set base [::file join $rbase [$project base]] + log write 1 collar "Scan $base" + + set traverse [fileutil::traverse %AUTO% $base \ + -prefilter [myproc FilterAtticSubdir $base]] + set n 0 + set r {} + + $traverse foreach path { + set rcs [fileutil::stripPath $base $path] + if {[IsCVSAdmin $rcs]} continue + if {![IsRCSArchive $path]} continue + + set usr [UserPath $rcs isattic] + + if {[CheckForAndReportPathConflicts $base $rcs $usr $isattic]} continue + if {[HandleDotFile $base $rcs usr $isattic]} continue + + log write 4 collar "Found $rcs" + $project addfile $rcs $usr [file executable $rcs] + + incr n + if {[log verbosity?] < 4} { + log progress 0 collar $n {} + } + } + + $traverse destroy + } + + repository printstatistics + repository persist + + log write 1 collar "Scan completed" + return + } + + typemethod discard {} { + # Pass manager interface. Executed for all passes after the + # run passes, to remove all data of this pass from the state, + # as being out of date. + + state discard project + state discard file + return + } + + typemethod ignore_conflicting_attics {} { + set myignore 1 + return + } + + typemethod accept_and_convert_dotfiles {} { + set myconvertdot 1 + return + } + + # # ## ### ##### ######## ############# + ## Internal methods + + typevariable myignore 0 ; # Flag. When set Attic files + # superceded by regular files + # ignored. + typevariable myconvertdot 0 ; # Flag. When set dotfiles do not + # cause rejection, but their names + # are converted to a dotless form + # ('dot-' prefix instead of '.'). + + proc FilterAtticSubdir {base path} { + # This command is used by the traverser to prevent it from + # scanning into subdirectories of an Attic. We get away with + # checking the immediate parent directory of the current path + # as our rejection means that deeper path do not occur. + + if {[file tail [file dirname $path]] eq "Attic"} { + set ad [fileutil::stripPath $base $path] + log write 1 collar "Directory $ad found in Attic, ignoring." + return 0 + } + return 1 + } + + proc IsRCSArchive {path} { + if {![string match *,v $path]} {return 0} + if {[fileutil::test $path fr msg]} {return 1} + trouble warn $msg + return 0 + } + + proc IsCVSAdmin {rcs} { + if { + [string match {CVSROOT/*} $rcs] || + [string match {.cvsignore*} [file tail $rcs]] + } { + log write 4 collar "Ignored $rcs, administrative archive" + return 1 + } + return 0 + } + + proc UserPath {rcs iav} { + upvar 1 $iav isattic + + # Derive the user-visible path from the rcs path. Meaning: + # Chop off the ",v" suffix, and remove a possible "Attic". + + set f [string range $rcs 0 end-2] + + if {"Attic" eq [lindex [file split $rcs] end-1]} { + + # The construction below ensures that Attic/X maps to X + # instead of ./X. Otherwise, Y/Attic/X maps to Y/X. + + set fx [file dirname [file dirname $f]] + set f [file tail $f] + if {$fx ne "."} { set f [file join $fx $f] } + + set isattic 1 + } else { + set isattic 0 + } + + return $f + } + + proc IsSuperceded {base rcs usr isattic} { + ::variable myignore + + if {!$isattic} {return 0} + if {![fileexists_cs $base/$usr,v]} {return 0} + + # We have a regular archive and an Attic archive refering to + # the same user visible file. Ignore the file in the Attic. + # + # By default this is a problem causing an abort after the pass + # has completed. The user can however force us to ignore it. + # In that case the warning is still printed, but will not + # induce an abort any longer. + + if {$myignore} { + log write 2 collar "Ignored $rcs, superceded archive" + } else { + trouble warn "Ignored $rcs, superceded archive" + } + return 1 + } + + # In the future we should move the activity below into the fossil + # backend, as the exact set of paths requiring translation, and + # how to translate them, depends entirely on the limitations + # imposed by the destination repository. + + proc HandleDotFile {base rcs usrvar isattic} { + ::variable myconvertdot + upvar 1 $usrvar usr + + set dedot [DeDot $usr] + if {$dedot eq $usr} { return 0 } + + # Ok, we now have established that the path has to be + # translated. Which as already happened as part of the check + # above. Left is to report the action, and to check if the new + # path collides with existing files and directories. + + if {!$myconvertdot} { + trouble warn "Ignored $rcs, is a dot-file" + return 1 + } + + log write 2 collar "Convert $rcs, is a dot-file" + set usr $dedot + + return [CheckForAndReportPathConflicts $base $rcs $usr $isattic] + } + + proc DeDot {path} { + set res {} + foreach segment [file split $path] { + lappend res [expr { + [string match {.*} $segment] + ? "dot-[string range $segment 1 end]" + : $segment + }] + } + return [eval [linsert $res 0 file join]] + #8.5: return [file join {*}$res] + } + + proc CheckForAndReportPathConflicts {base rcs usr isattic {intro {}}} { + if {[IsSuperceded $base $rcs $usr $isattic]} { return 1 } + + # XXX Checkme: not sure if this will still fail in the case + # where a directory does conflict with a file XXX + if { + [fileexists_cs $base/$usr] && + [fileisdir_cs $base/$usr] + } { + if {$intro ne {}} { + trouble fatal $intro + } + trouble fatal "Directory name conflicts with filename." + trouble fatal "Please remove or rename one of the following:" + trouble fatal " $base/$usr" + trouble fatal " $base/$rcs" + return 1 + } + return 0 + } + + # # ## ### ##### ######## ############# + ## Configuration + + pragma -hasinstances no ; # singleton + pragma -hastypeinfo no ; # no introspection + pragma -hastypedestroy no ; # immortal + + # # ## ### ##### ######## ############# +} + +namespace eval ::vc::fossil::import::cvs::pass { + namespace export collar + namespace eval collar { + namespace import ::vc::fossil::import::cvs::repository + namespace import ::vc::fossil::import::cvs::state + namespace import ::vc::tools::trouble + namespace import ::vc::tools::log + namespace import ::vc::tools::misc::file* + log register collar + } +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide vc::fossil::import::cvs::pass::collar 1.0 +return diff --git a/tools/cvs2fossil/lib/c2f_pcollrev.tcl b/tools/cvs2fossil/lib/c2f_pcollrev.tcl new file mode 100644 index 0000000..a3f6734 --- /dev/null +++ b/tools/cvs2fossil/lib/c2f_pcollrev.tcl @@ -0,0 +1,680 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2007-2008 Andreas Kupries. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## Pass II. This pass parses the collected rcs archives and extracts +## all the information they contain (revisions, and symbols). + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.4 ; # Required runtime. +package require snit ; # OO system. +package require vc::tools::trouble ; # Error reporting. +package require vc::tools::log ; # User feedback. +package require vc::fossil::import::cvs::pass ; # Pass management. +package require vc::fossil::import::cvs::repository ; # Repository management. +package require vc::fossil::import::cvs::state ; # State storage. +package require vc::fossil::import::cvs::integrity ; # State integrity checks. +package require vc::fossil::import::cvs::project::sym ; # Project level symbols. +package require vc::fossil::import::cvs::file::rev ; # File level revisions. +package require vc::rcs::parser ; # Rcs archive data extraction. + +# # ## ### ##### ######## ############# ##################### +## Register the pass with the management + +vc::fossil::import::cvs::pass define \ + CollectRev \ + {Collect revisions and symbols} \ + ::vc::fossil::import::cvs::pass::collrev + +# # ## ### ##### ######## ############# ##################### +## + +snit::type ::vc::fossil::import::cvs::pass::collrev { + # # ## ### ##### ######## ############# + ## Public API + + typemethod setup {} { + # Define names and structure of the persistent state of this + # pass. + + state use project + state use file + + # We deal with per project and per file data, the first + # collated from the second. + + # Per file we have general information, ..., and then + # revisions and symbols. The latter can be further separated + # into tags and branches. At project level the per-file + # symbols information is merged. + + # File level ... + # Revisions, Branches, Tags + # + # Pseudo class hierarchy + # Tag <- Symbol <- Event + # Branch <- Symbol <- Event + # Revision <- Event + + state extend revision { + -- Revisions. Identified by a global numeric id each + -- belongs to a single file, identified by its id. It + -- further has a dotted revision number (DTN). + -- + -- Constraint: The dotted revision number is unique within + -- the file. See end of definition. + + rid INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT, + fid INTEGER NOT NULL REFERENCES file, -- File owning revision. + rev TEXT NOT NULL, -- Dotted Rev Number. + + -- All revisions belong to a line-of-development, + -- identified by a symbol (project level). During data + -- collection it was a file-level branch symbol. + -- + -- Constraint: All the LOD symbols are in the same project + -- as the file itself. This cannot be + -- expressed in CREATE TABLE syntax. + + lod INTEGER NOT NULL REFERENCES symbol, -- Line of development + + -- The revisions in a file are organized in a forest of + -- trees, with the main lines defined through the parent / + -- child references. A revision without a parent is the + -- root of a tree, and a revision without a child is a + -- leaf. + + -- Constraints: All revisions coupled through parent/child + -- refer to the same LOD symbol. The parent + -- of a child of X is X. The child of a + -- parent of X is X. + + parent INTEGER REFERENCES revision, + child INTEGER REFERENCES revision, + + -- The representation of a branch in a tree is the + -- exception to the three constraints above. + + -- The beginning of a branch is represented by a non-NULL + -- bparent of a revision. This revision B is the first on + -- the branch. Its parent P is the revision the branch is + -- rooted in, and it is not the child of P. B and P refer + -- to different LOD symbols. The bparent of B is also its + -- LOD, and the LOD of its children. + + bparent INTEGER REFERENCES symbol, + + -- Lastly we keep information is about non-trunk default + -- branches (NTDB) in the revisions. + + -- All revisions on the NTDB have 'isdefault' TRUE, + -- everyone else FALSE. The last revision X on the NTDB + -- which is still considered to be on the trunk as well + -- has a non-NULL 'dbchild' which refers to the root of + -- the trunk. The root also has a non-NULL dbparent + -- refering to X. + + isdefault INTEGER NOT NULL, + dbparent INTEGER REFERENCES revision, + dbchild INTEGER REFERENCES revision, + + -- The main payload of the revision are the date/time it + -- was entered, its state, operation (= type/class), text + -- content, and meta data (author, log message, branch, + -- project). The last is encoded as single id, see table + -- 'meta'. The date/time is given in seconds since the + -- epoch, for easy comparison. + + op INTEGER NOT NULL REFERENCES optype, + date INTEGER NOT NULL, + state TEXT NOT NULL, + mid INTEGER NOT NULL REFERENCES meta, + + UNIQUE (fid, rev) -- The DTN is unique within the revision's file. + } + + # Blobs contain the information needed to extract revisions + # from rcs archive files. As such each revision has an + # associated blob. However we can have blobs without + # revisions. This happens if a logically irrelevant revision + # is removed. We may however still need its blob to correctly + # expand other revisions, both its contents and for the + # ordering. + + state extend blob { + bid INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT, + rid INTEGER REFERENCES revision, + fid INTEGER NOT NULL REFERENCES file, -- File owning blob. + + -- The text content is an (offset,length) pair into the + -- rcs archive. For deltas we additionally refer to the + -- parent blob the delta is made against. + + coff INTEGER NOT NULL, + clen INTEGER NOT NULL, + pid INTEGER REFERENCES blob, + + UNIQUE (rid) + } { fid } + # Index on owning file to collect all blobs of a file when the + # time for its expansion comes. + + state extend optype { + oid INTEGER NOT NULL PRIMARY KEY, + name TEXT NOT NULL, + UNIQUE(name) + } + state run { + INSERT INTO optype VALUES (-1,'delete'); -- The opcode names are the + INSERT INTO optype VALUES ( 0,'nothing'); -- fixed pieces, see myopstate + INSERT INTO optype VALUES ( 1,'add'); -- in file::rev. myopcode is + INSERT INTO optype VALUES ( 2,'change'); -- loaded from this. + } + + state extend revisionbranchchildren { + -- The non-primary children of a revision, as reachable + -- through a branch symbol, are listed here. This is + -- needed by pass 5 to break internal dependencies in a + -- changeset. + + rid INTEGER NOT NULL REFERENCES revision, + brid INTEGER NOT NULL REFERENCES revision, + UNIQUE(rid,brid) + } + + state extend tag { + tid INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT, + fid INTEGER NOT NULL REFERENCES file, -- File the item belongs to + lod INTEGER REFERENCES symbol, -- Line of development (NULL => Trunk) + sid INTEGER NOT NULL REFERENCES symbol, -- Symbol capturing the tag + + rev INTEGER NOT NULL REFERENCES revision -- The revision being tagged. + } { rev sid } + # Indices on: rev (revision successors) + # sid (tag predecessors, branch successors/predecessors) + + state extend branch { + bid INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT, + fid INTEGER NOT NULL REFERENCES file, -- File the item belongs to + lod INTEGER REFERENCES symbol, -- Line of development (NULL => Trunk) + sid INTEGER NOT NULL REFERENCES symbol, -- Symbol capturing the branch + + root INTEGER REFERENCES revision, -- Revision the branch sprouts from + first INTEGER REFERENCES revision, -- First revision committed to the branch + bra TEXT NOT NULL, -- branch number + pos INTEGER NOT NULL -- creation order in root. + + -- A branch can exist without root. It happens when the + -- only revision on trunk is the unnecessary dead one the + -- branch was sprouted from and it has commits. The branch + -- will exist to be the LOD of its revisions, nothing to + -- sprout from, the dead revision was removed, hence no + -- root. + } { root first sid } + # Indices on: root (revision successors) + # first (revision predecessors) + # sid (tag predecessors, branch successors/predecessors) + + # Project level ... + # pLineOfDevelopment, pSymbol, pBranch, pTag, pTrunk + # + # pTrunk <- pLineOfDevelopment + # pBranch <- pSymbol, pLineOfDevelopment + # pTag <- pSymbol, pLineOfDevelopment + + state extend symbol { + sid INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT, + pid INTEGER NOT NULL REFERENCES project, -- Project the symbol belongs to + name TEXT NOT NULL, + type INTEGER NOT NULL REFERENCES symtype, -- enum { excluded = 0, tag, branch, undefined } + + tag_count INTEGER NOT NULL, -- How often the symbol is used as tag. + branch_count INTEGER NOT NULL, -- How often the symbol is used as branch + commit_count INTEGER NOT NULL, -- How often a file was committed on the symbol + + UNIQUE (pid, name) -- Symbols are unique within the project + } + + state extend blocker { + -- For each symbol we save which other symbols are + -- blocking its removal (if the user asks for it). + + sid INTEGER NOT NULL REFERENCES symbol, -- + bid INTEGER NOT NULL REFERENCES symbol, -- Sprouted from sid, blocks it. + UNIQUE (sid, bid) + } + + state extend parent { + -- For each symbol we save which other symbols can act as + -- a possible parent in some file, and how often. + + sid INTEGER NOT NULL REFERENCES symbol, -- + pid INTEGER NOT NULL REFERENCES symbol, -- Possible parent of sid + n INTEGER NOT NULL, -- How often pid can act as parent. + UNIQUE (sid, pid) + } + + state extend symtype { + tid INTEGER NOT NULL PRIMARY KEY, + name TEXT NOT NULL, + plural TEXT NOT NULL, + UNIQUE (name) + UNIQUE (plural) + } + state run { + INSERT INTO symtype VALUES (0,'excluded', 'excluded'); -- The ids are the fixed + INSERT INTO symtype VALUES (1,'tag', 'tags'); -- pieces, see project::sym, + INSERT INTO symtype VALUES (2,'branch', 'branches'); -- getsymtypes and associated + INSERT INTO symtype VALUES (3,'undefined','undefined'); -- typevariables. + } + + state extend meta { + -- Meta data of revisions. See revision.mid for the + -- reference. Many revisions can share meta data. This is + -- actually one of the criterions used to sort revisions + -- into changesets. + + mid INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT, + + -- Meta data belongs to a specific project, stronger, to a + -- branch in that project. It further has a log message, + -- and its author. This is unique with the project and + -- branch. + + pid INTEGER NOT NULL REFERENCES project, -- + bid INTEGER NOT NULL REFERENCES symbol, -- + aid INTEGER NOT NULL REFERENCES author, -- + cid INTEGER NOT NULL REFERENCES cmessage, -- + + UNIQUE (pid, bid, aid, cid) + + -- Constraints: The project of the meta data of a revision + -- X is the same as the project of X itself. + -- + -- ............ The branch of the meta data of a revision + -- X is the same as the line of development + -- of X itself. + } + + # Authors and commit messages are fully global, i.e. per + # repository. + + state extend author { + aid INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT, -- Pool of the unique + name TEXT NOT NULL UNIQUE -- author names. + } + + state extend cmessage { + cid INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT, -- Pool of the unique + text TEXT NOT NULL UNIQUE -- log messages + } + + project::sym getsymtypes + file::rev getopcodes + return + } + + typemethod load {} { + state use symbol + state use symtype + state use optype + + project::sym getsymtypes + file::rev getopcodes + repository loadsymbols + return + } + + typemethod run {} { + # Pass manager interface. Executed to perform the + # functionality of the pass. + + set rbase [repository base?] + foreach project [repository projects] { + set base [::file join $rbase [$project base]] + log write 1 collrev "Processing $base" + + foreach file [$project files] { + set path [$file path] + log write 2 collrev "Parsing $path" + if {[catch { + parser process [::file join $base $path] $file + } msg]} { + global errorCode + if {$errorCode eq "vc::rcs::parser"} { + trouble fatal "$path is not a valid RCS archive ($msg)" + } else { + global errorInfo + trouble internal $errorInfo + } + } else { + # We persist the core of the data collected about + # each file immediately after it has been parsed + # and wrangled into shape, and then drop it from + # memory. This is done to keep the amount of + # required memory within sensible limits. Without + # doing it this way we would easily gobble up 1G + # of RAM or more with all the objects (revisions + # and file-level symbols). + + $file persist + } + + $file drop + } + + $project purgeghostsymbols + } + + repository persistrev + repository printrevstatistics + integrity strict + + log write 1 collrev "Scan completed" + return + } + + typemethod discard {} { + # Pass manager interface. Executed for all passes after the + # run passes, to remove all data of this pass from the state, + # as being out of date. + + state discard revision + state discard tag + state discard branch + state discard symbol + state discard blocker + state discard parent + state discard symtype + state discard meta + state discard author + state discard cmessage + return + } + + # TODO: Move this code to the integrity module + proc Paranoia {} { + # This code performs a number of paranoid checks of the + # database, searching for inconsistent cross-references. + log write 4 collrev {Check database consistency} + + set n 0 ; # Counter for the checks (we print an id before the + # main label). + + # Find all revisions which disagree with their line of + # development about the project they are owned by. + Check \ + {Revisions and their LODs have to be in the same project} \ + {disagrees with its LOD about owning project} { + SELECT F.name, R.rev + FROM revision R, file F, symbol S + WHERE R.fid = F.fid -- Get file of revision + AND R.lod = S.sid -- Get symbol for revision's LOD + AND F.pid != S.pid -- but symbol is for a different project + ; + } + # Find all revisions which disgree with their meta data about + # the project they are owned by. + Check \ + {Revisions and their meta data have to be in the same project} \ + {disagrees with its meta data about owning project} { + SELECT F.name, R.rev + FROM revision R, file F, meta M + WHERE R.fid = F.fid -- Get file of revision + AND R.mid = M.mid -- Get meta data of revision + AND F.pid != M.pid -- but is for a different project + ; + } + # Find all revisions which disgree with their meta data about + # the branch/line of development they belong to. + Check \ + {Revisions and their meta data have to be in the same LOD} \ + {disagrees with its meta data about owning LOD} { + SELECT F.name, R.rev + FROM revision R, meta M, file F + WHERE R.mid = M.mid -- Get meta data of revision + AND R.lod != M.bid -- but is for a different LOD + AND R.fid = F.fid -- Get file of revision + ; + } + # Find all revisions with a primary child which disagrees + # about the file they belong to. + Check \ + {Revisions and their primary children have to be in the same file} \ + {disagrees with its primary child about the owning file} { + SELECT F.name, R.rev + FROM revision R, revision C, file F + WHERE R.fid = F.fid -- Get file of revision + AND R.child IS NOT NULL -- Restrict to non-leaf revisions + AND R.child = C.rid -- Get child (has to exist) + AND C.fid != R.fid -- Whic wrongly is in a different file + ; + } + + # Find all revisions with a branch parent symbol whose parent + # disagrees about the file they belong to. + Check \ + {Revisions and their branch children have to be in the same file} \ + {at the beginning of its branch and its parent disagree about the owning file} { + SELECT F.name, R.rev + FROM revision R, revision P, file F + WHERE R.fid = F.fid -- Get file of revision + AND R.bparent IS NOT NULL -- Restrict to first on branch + AND R.parent = P.rid -- Get out-of-branch parent + AND R.fid != P.fid -- Which wrongly is in a different file + ; + } + # Find all revisions with a non-NTDB child which disagrees + # about the file they belong to. + Check \ + {Revisions and their non-NTDB children have to be in the same file} \ + {disagrees with its non-NTDB child about the owning file} { + SELECT F.name, R.rev + FROM revision R, revision C, file F + WHERE R.fid = F.fid -- Get file of revision + AND R.dbchild IS NOT NULL -- Restrict to semi-last NTDB revision + AND R.dbchild = C.rid -- Got to associated trunk revision + AND C.fid != R.fid -- Which wrongly is in a different file + ; + } + # Find all revisions which have a primary child, but the child + # does not have them as parent. + Check \ + {Revisions have to be parents of their primary children} \ + {is not the parent of its primary child} { + SELECT F.name, R.rev + FROM revision R, revision C, file F + WHERE R.fid = F.fid -- Get file of revision + AND R.child IS NOT NULL -- Restrict to non-leaves + AND R.child = C.rid -- Get the child (has to exist) + AND C.parent != R.rid -- Which does not have us as its parent. + ; + } + # Find all revisions which have a primrary child, but the + # child has a branch parent symbol making them brach starters. + Check \ + {Primary children of revisions must not start branches} \ + {is parent of a primary child which is the beginning of a branch} { + SELECT F.name, R.rev + FROM revision R, revision C, file F + WHERE R.fid = F.fid -- Get file of revision + AND R.child IS NOT NULL -- Restrict to non-leaves + AND R.child = C.rid -- Get the child (has to exist) + AND C.bparent IS NOT NULL -- wrongly claiming to be first on branch + ; + } + # Find all revisions without branch parent symbol which have a + # parent, but the parent does not have them as primary child. + Check \ + {Revisions have to be primary children of their parents, if any} \ + {is not the child of its parent} { + SELECT F.name, R.rev + FROM revision R, revision P, file F + WHERE R.fid = F.fid + AND R.bparent IS NULL -- Get file of revision + AND R.parent IS NOT NULL -- Restrict to everything not first on a branch + AND R.parent = P.rid -- Get the parent (has to exist) + AND P.child != R.rid -- Which do not have us as their child + ; + } + # Find all revisions with a branch parent symbol which do not + # have a parent. + Check \ + {Branch starting revisions have to have a parent} \ + {at the beginning of its branch has no parent} { + SELECT F.name, R.rev + FROM revision R, file F + WHERE R.fid = F.fid -- Get file of revision + AND R.bparent IS NOT NULL -- Restrict to first on a branch + AND R.parent IS NULL -- But there is no out-of-branch parent + ; + } + # Find all revisions with a branch parent symbol whose parent + # has them as primary child. + Check \ + {Branch starting revisions must not be primary children of their parents} \ + {at the beginning of its branch is the primary child of its parent} { + SELECT F.name, R.rev + FROM revision R, revision P, file F + WHERE R.fid = F.fid -- Get file of revision + AND R.bparent IS NOT NULL -- Restrict to first on a branch + AND R.parent IS NOT NULL -- Which are not detached + AND R.parent = P.rid -- Get their non-branch parent + AND P.child = R.rid -- which improperly has them as primary child + ; + } + # Find all revisions with a non-NTDB child which are not on + # the NTDB. + Check \ + {NTDB to trunk transition has to begin on NTDB} \ + {has a non-NTDB child, yet is not on the NTDB} { + SELECT F.name, R.rev + FROM revision R, file F + WHERE R.fid = F.fid -- Get file of revision + AND R.dbchild IS NOT NULL -- Restrict to semi-last NTDB revision + AND NOT R.isdefault -- Improperly claiming to not be on NTDB + ; + } + # Find all revisions with a NTDB parent which are on the NTDB. + Check \ + {NTDB to trunk transition has to end on non-NTDB} \ + {has a NTDB parent, yet is on the NTDB} { + SELECT F.name, R.rev + FROM revision R, file F + WHERE R.fid = F.fid -- Get file of revision + AND R.dbparent IS NOT NULL -- Restrict to trunk roots with NTDB around + AND R.isdefault -- But root improperly claims to be on NTDB + ; + } + # Find all revisions with a child which disagrees about the + # line of development they belong to. + Check \ + {Revisions and their primary children have to be in the same LOD} \ + {and its primary child disagree about their LOD} { + SELECT F.name, R.rev + FROM revision R, revision C, file F + WHERE R.fid = F.fid -- Get file of revision + AND R.child IS NOT NULL -- Restrict to non-leaves + AND R.child = C.rid -- Get child (has to exist) + AND C.lod != R.lod -- which improperly uses a different LOD + ; + } + # Find all revisions with a non-NTDB child which agrees about + # the line of development they belong to. + Check \ + {NTDB and trunk revisions have to be in different LODs} \ + {on NTDB and its non-NTDB child wrongly agree about their LOD} { + SELECT F.name, R.rev + FROM revision R, revision C, file F + WHERE R.fid = F.fid -- Get file of revision + AND R.dbchild IS NOT NULL -- Restrict to semi-last NTDB revision + AND R.dbchild = C.rid -- Get associated trunk root revision + AND C.lod = R.lod -- Improperly uses the same LOD + ; + } + # Find all revisions with a branch parent symbol which is not + # their LOD. + Check \ + {Branch starting revisions have to have their LOD as branch parent symbol} \ + {at the beginning of its branch does not have the branch symbol as its LOD} { + SELECT F.name, R.rev + FROM revision R, file F + WHERE R.fid = F.fid -- Get file of revision + AND R.bparent IS NOT NULL -- Restrict to revisions first on a branch + AND R.lod != R.bparent -- and their branch is not their LOD + ; + } + # Find all revisions with a branch parent symbol whose parent + # is in the same line of development. + Check \ + {Revisions and their branch children have to be in different LODs} \ + {at the beginning of its branch and its parent wrongly agree about their LOD} { + SELECT F.name, R.rev + FROM revision R, revision P, file F + WHERE R.fid = F.fid -- Get file of revision + AND R.bparent IS NOT NULL -- Restrict to revisions first on a branch + AND R.parent = P.rid -- Get their non-branch parent + AND R.lod = P.lod -- Which improperly uses the same LOD + ; + } + return + } + + proc Check {header label sql} { + upvar 1 n n + set ok 1 + foreach {fname revnr} [state run $sql] { + set ok 0 + trouble fatal "$fname <$revnr> $label" + } + log write 5 collrev "\[[format %02d [incr n]]\] [expr {$ok ? "Ok " : "Failed"}] ... $header" + return + } + + # # ## ### ##### ######## ############# + ## Internal methods + + # # ## ### ##### ######## ############# + ## Configuration + + pragma -hasinstances no ; # singleton + pragma -hastypeinfo no ; # no introspection + pragma -hastypedestroy no ; # immortal + + # # ## ### ##### ######## ############# +} + +namespace eval ::vc::fossil::import::cvs::pass { + namespace export collrev + namespace eval collrev { + namespace import ::vc::rcs::parser + namespace import ::vc::fossil::import::cvs::repository + namespace import ::vc::fossil::import::cvs::state + namespace import ::vc::fossil::import::cvs::integrity + namespace eval project { + namespace import ::vc::fossil::import::cvs::project::sym + } + namespace eval file { + namespace import ::vc::fossil::import::cvs::file::rev + } + namespace import ::vc::tools::trouble + namespace import ::vc::tools::log + log register collrev + } +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide vc::fossil::import::cvs::pass::collrev 1.0 +return diff --git a/tools/cvs2fossil/lib/c2f_pcollsym.tcl b/tools/cvs2fossil/lib/c2f_pcollsym.tcl new file mode 100644 index 0000000..295027a --- /dev/null +++ b/tools/cvs2fossil/lib/c2f_pcollsym.tcl @@ -0,0 +1,318 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2007 Andreas Kupries. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## Pass III. This pass divides the symbols collected by the previous +## pass into branches, tags, and excludes. The latter are also +## partially deleted by this pass, not only marked. It is the next +## pass however, 'FilterSym', which performs the full deletion. + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.4 ; # Required runtime. +package require snit ; # OO system. +package require vc::tools::trouble ; # Error reporting. +package require vc::tools::log ; # User feedback. +package require vc::fossil::import::cvs::repository ; # Repository management. +package require vc::fossil::import::cvs::state ; # State storage. +package require vc::fossil::import::cvs::project::sym ; # Project level symbols + +# # ## ### ##### ######## ############# ##################### +## Register the pass with the management + +vc::fossil::import::cvs::pass define \ + CollateSymbols \ + {Collate symbols} \ + ::vc::fossil::import::cvs::pass::collsym + +# # ## ### ##### ######## ############# ##################### +## + +snit::type ::vc::fossil::import::cvs::pass::collsym { + # # ## ### ##### ######## ############# + ## Public API + + typemethod setup {} { + # Define names and structure of the persistent state of this + # pass. + + state use project + state use symbol + state use symtype + state use blocker + state use parent + + state extend preferedparent { + -- For each symbol the prefered parent. This describes the + -- tree of the found lines of development. Actually a + -- forest in case of multiple projects, with one tree per + -- project. + + sid INTEGER NOT NULL PRIMARY KEY REFERENCES symbol, + pid INTEGER NOT NULL REFERENCES symbol + } { pid } + # Index on: pid (branch successors) + return + } + + typemethod load {} { + # Pass manager interface. Executed to load data computed by + # this pass into memory when this pass is skipped instead of + # executed. + + # The results of this pass are fully in the persistent state, + # there is nothing to load for the next one. + return + } + + typemethod run {} { + # Pass manager interface. Executed to perform the + # functionality of the pass. + + state transaction { + repository determinesymboltypes + + project::sym printrulestatistics + project::sym printtypestatistics + } + + if {![trouble ?]} { + UnconvertedSymbols + BadSymbolTypes + BlockedExcludes + InvalidTags + } + + if {![trouble ?]} { + DropExcludedSymbolsFromReferences + DeterminePreferedParents + } + + log write 1 collsym "Collation completed" + return + } + + typemethod discard {} { + # Pass manager interface. Executed for all passes after the + # run passes, to remove all data of this pass from the state, + # as being out of date. + + state discard preferedparent + return + } + + # # ## ### ##### ######## ############# + ## Internal methods + + ## TODO: Move UnconvertedSymbols, BadSymbolTypes, BlockedIncludes, + ## TODO: InvalidTags to the integrity module? + + proc UnconvertedSymbols {} { + # Paranoia - Have we left symbols without conversion + # information (i.e. with type 'undefined') ? + + set undef [project::sym undef] + + state foreachrow { + SELECT P.name AS pname, S.name AS sname + FROM symbol S, project P + WHERE S.type = $undef -- Restrict to undefined symbols + AND P.pid = S.pid -- Get project for symbol + } { + trouble fatal "$pname : The symbol '$sname' was left undefined" + } + return + } + + proc BadSymbolTypes {} { + # Paranoia - Have we left symbols with bogus conversion + # information (type out of the valid range (excluded, branch, + # tag)) ? + + state foreachrow { + SELECT P.name AS pname, S.name AS sname + FROM symbol S, project P + WHERE S.type NOT IN (0,1,2) -- Restrict to symbols with bogus type codes + AND P.pid = S.pid -- Get project of symbol + } { + trouble fatal "$pname : The symbol '$sname' has no proper conversion type" + } + return + } + + proc BlockedExcludes {} { + # Paranoia - Have we scheduled symbols for exclusion without + # also excluding their dependent symbols ? + + set excl [project::sym excluded] + + state foreachrow { + SELECT P.name AS pname, S.name AS sname, SB.name AS bname + FROM symbol S, blocker B, symbol SB, project P + WHERE S.type = $excl -- Restrict to excluded symbols + AND S.sid = B.sid -- Get symbols blocking them + AND B.bid = SB.sid -- and + AND SB.type != $excl -- which are not excluded themselves + AND P.pid = S.pid -- Get project of symbol + } { + trouble fatal "$pname : The symbol '$sname' cannot be excluded as the unexcluded symbol '$bname' depends on it." + } + return + } + + proc InvalidTags {} { + # Paranoia - Have we scheduled symbols for conversion as tags + # which absolutely cannot be converted as tags due to commits + # made on them ? + + # In other words, this checks finds out if the user has asked + # nonsensical conversions of symbols, which should have been + # left to the heuristics, most specifically + # 'project::sym.HasCommits()'. + + set tag [project::sym tag] + + state foreachrow { + SELECT P.name AS pname, S.name AS sname + FROM project P, symbol S + WHERE S.type = $tag -- Restrict to tag symbols + AND S.commit_count > 0 -- which have revisions committed to them + AND P.pid = S.pid -- Get project of symbol + } { + trouble fatal "$pname : The symbol '$sname' cannot be forced to be converted as tag because it has commits." + } + return + } + + proc DropExcludedSymbolsFromReferences {} { + # The excluded symbols cann be used as blockers nor as + # possible parent for other symbols. We now drop the relevant + # entries to prevent them from causing confusion later on. + + set excl [project::sym excluded] + + state run { + DELETE FROM blocker + WHERE bid IN (SELECT sid + FROM symbol + WhERE type = $excl); -- Get excluded symbols + DELETE FROM parent + WHERE pid IN (SELECT sid + FROM symbol + WhERE type = $excl); -- Get excluded symbols + } + return + } + + proc DeterminePreferedParents {} { + array set prefered {} + + set excl [project::sym excluded] + + # Phase I: Pull the possible parents, using sorting to put the + # prefered parent of each symbol last among all + # candidates, allowing us get the prefered one by + # each candidate overwriting all previous + # selections. Note that we ignore excluded symbols, + # we do not care about their prefered parents and do + # not attempt to compute them. + + state foreachrow { + SELECT S.sid AS xs, + P.pid AS xp, + S.name AS sname, + SB.name AS pname, + PR.name AS prname, + P.n AS votes + FROM symbol S, parent P, symbol SB, project PR + WHERE S.type != $excl -- Restrict to wanted symbols + AND S.sid = P.sid -- Get possible parents of symbol + AND P.pid = SB.sid -- and + AND S.pid = PR.pid -- the project of the symbol + ORDER BY P.n ASC, P.pid DESC -- Sorting, see below + -- + -- Higher votes and smaller ids (= earlier branches) last + -- We simply keep the last possible parent for each + -- symbol. This parent will have the max number of votes + -- for its symbol and will be the earliest created branch + -- possible among all with many votes. + } { + log write 9 pcollsym "Voting $votes for Parent($sname) = $pname" + + set prefered($xs) [list $xp $sname $pname $prname] + } + + # Phase II: Write the found preferences back into the table + # this pass defined for it. + + foreach {s x} [array get prefered] { + struct::list assign $x p sname pname prname + state run { + INSERT INTO preferedparent (sid, pid) + VALUES ($s, $p); + } + + log write 3 pcollsym "$prname : '$sname's prefered parent is '$pname'" + } + + # Phase III: Check the result that all symbols except for + # trunks have a prefered parent. We also ignore + # excluded symbols, as we intentionally did not + # compute a prefered parent for them, see phase I. + + state foreachrow { + SELECT PR.name AS pname, S.name AS sname + FROM symbol S LEFT OUTER JOIN preferedparent P + ON S.sid = P.sid, -- From symbol to prefered parent + project PR + WHERE P.pid IS NULL -- restrict to symbols without a preference + AND S.type != $excl -- which are not excluded + AND S.name != ':trunk:' -- and are not a trunk + AND S.pid = PR.pid -- get project of symbol + } { + trouble fatal "$pname : '$sname' has no prefered parent." + } + + # The reverse, having prefered parents for unknown symbols + # cannot occur. + return + } + + # # ## ### ##### ######## ############# + ## Configuration + + pragma -hasinstances no ; # singleton + pragma -hastypeinfo no ; # no introspection + pragma -hastypedestroy no ; # immortal + + # # ## ### ##### ######## ############# +} + +namespace eval ::vc::fossil::import::cvs::pass { + namespace export collsym + namespace eval collsym { + namespace import ::vc::fossil::import::cvs::repository + namespace import ::vc::fossil::import::cvs::state + namespace eval project { + namespace import ::vc::fossil::import::cvs::project::sym + } + namespace import ::vc::tools::trouble + namespace import ::vc::tools::log + log register collsym + } +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide vc::fossil::import::cvs::pass::collsym 1.0 +return diff --git a/tools/cvs2fossil/lib/c2f_pcsetdeps.tcl b/tools/cvs2fossil/lib/c2f_pcsetdeps.tcl new file mode 100644 index 0000000..cef93d6 --- /dev/null +++ b/tools/cvs2fossil/lib/c2f_pcsetdeps.tcl @@ -0,0 +1,135 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2007 Andreas Kupries. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## Pass VI. This pass computes the dependencies between the changesets +## from the file level dependencies and stores them in the state for +## use by the cycle breaker and topological sorting passes. + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.4 ; # Required runtime. +package require snit ; # OO system. +package require vc::tools::misc ; # Text formatting. +package require vc::tools::log ; # User feedback. +package require vc::fossil::import::cvs::state ; # State storage. +package require vc::fossil::import::cvs::project::rev ; # Project level changesets + +# # ## ### ##### ######## ############# ##################### +## Register the pass with the management + +vc::fossil::import::cvs::pass define \ + CsetDeps \ + {Compute and cache ChangeSet Dependencies} \ + ::vc::fossil::import::cvs::pass::csetdeps + +# # ## ### ##### ######## ############# ##################### +## + +snit::type ::vc::fossil::import::cvs::pass::csetdeps { + # # ## ### ##### ######## ############# + ## Public API + + typemethod setup {} { + # Define the names and structure of the persistent state of + # this pass. + + state use project + state use file + state use revision + state use revisionbranchchildren + state use branch + state use tag + state use symbol + state use preferedparent + state use changeset + state use csitem + + # A table listing for each changeset the set of successor + # changesets. The predecessor information is implied. + + state extend cssuccessor { + cid INTEGER NOT NULL REFERENCES changeset, + nid INTEGER NOT NULL REFERENCES changeset, + UNIQUE (cid,nid) + } {cid nid} + # Index on both columns for fast forward and back retrieval. + return + } + + typemethod load {} { + # Pass manager interface. Executed to load data computed by + # this pass into memory when this pass is skipped instead of + # executed. + + state use cssuccessor + return + } + + typemethod run {} { + # Pass manager interface. Executed to perform the + # functionality of the pass. + + set n 0 + set max [llength [project::rev all]] + + foreach cset [project::rev all] { + log progress 2 csetdeps $n $max + # NOTE: Consider to commit only every N calls. + state transaction { + $cset determinesuccessors + } + incr n + } + return + } + + typemethod discard {} { + # Pass manager interface. Executed for all passes after the + # run passes, to remove all data of this pass from the state, + # as being out of date. + + state discard cssuccessor + return + } + + # # ## ### ##### ######## ############# + ## Internal methods + + # # ## ### ##### ######## ############# + ## Configuration + + pragma -hasinstances no ; # singleton + pragma -hastypeinfo no ; # no introspection + pragma -hastypedestroy no ; # immortal + + # # ## ### ##### ######## ############# +} + +namespace eval ::vc::fossil::import::cvs::pass { + namespace export csetdeps + namespace eval csetdeps { + namespace import ::vc::fossil::import::cvs::state + namespace eval project { + namespace import ::vc::fossil::import::cvs::project::rev + } + namespace import ::vc::tools::misc::* + namespace import ::vc::tools::log + log register csetdeps + } +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide vc::fossil::import::cvs::pass::csetdeps 1.0 +return diff --git a/tools/cvs2fossil/lib/c2f_pfiltersym.tcl b/tools/cvs2fossil/lib/c2f_pfiltersym.tcl new file mode 100644 index 0000000..9a11552 --- /dev/null +++ b/tools/cvs2fossil/lib/c2f_pfiltersym.tcl @@ -0,0 +1,598 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2007-2008 Andreas Kupries. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## Pass IV. Coming after the symbol collation pass this pass now +## removes all revisions and symbols referencing any of the excluded +## symbols from the persistent database. + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.4 ; # Required runtime. +package require snit ; # OO system. +package require vc::tools::misc ; # Text formatting. +package require vc::tools::log ; # User feedback. +package require vc::fossil::import::cvs::repository ; # Repository management. +package require vc::fossil::import::cvs::state ; # State storage. +package require vc::fossil::import::cvs::integrity ; # State storage integrity checks. +package require vc::fossil::import::cvs::project::sym ; # Project level symbols + +# # ## ### ##### ######## ############# ##################### +## Register the pass with the management + +vc::fossil::import::cvs::pass define \ + FilterSymbols \ + {Filter symbols, remove all excluded pieces} \ + ::vc::fossil::import::cvs::pass::filtersym + +# # ## ### ##### ######## ############# ##################### +## + +snit::type ::vc::fossil::import::cvs::pass::filtersym { + # # ## ### ##### ######## ############# + ## Public API + + typemethod setup {} { + # Define names and structure of the persistent state of this + # pass. + + state use project + state use file + state use revision + state use revisionbranchchildren + state use branch + state use tag + state use symbol + state use blocker + state use parent + state use author + state use cmessage + state use preferedparent + + # NOTE: So far no pass coming after this makes us of this information. + state extend noop { + id INTEGER NOT NULL PRIMARY KEY, -- tag/branch reference + noop INTEGER NOT NULL + } + return + } + + typemethod load {} { + # Pass manager interface. Executed to load data computed by + # this pass into memory when this pass is skipped instead of + # executed. + + # The results of this pass are fully in the persistent state, + # there is nothing to load for the next one. + return + } + + typemethod run {} { + # Pass manager interface. Executed to perform the + # functionality of the pass. + + # The removal of excluded symbols and everything referencing + # to them is done completely in the database. + + state transaction { + FilterExcludedSymbols + MutateSymbols + AdjustParents + RefineSymbols + + PrintSymbolTree + repository printrevstatistics + + # Strict integrity enforces that all meta entries are in + # the same LOD as the revision using them. At this point + # this may not be true any longer. If a NTDB was excluded + # then all revisions it shared with the trunk were moved + # to the trunk LOD, however their meta entries will still + # refer to the now gone LOD symbol. This is fine however, + # it will not affect our ability to use the meta entries + # to distinguish and group revisions into changesets. It + # should be noted that we cannot simply switch the meta + # entries over to the trunk either, as that may cause the + # modified entries to violate the unique-ness constraint + # set on that table. + integrity metarelaxed + } + + log write 1 filtersym "Filtering completed" + return + } + + typemethod discard {} { + # Pass manager interface. Executed for all passes after the + # run passes, to remove all data of this pass from the state, + # as being out of date. + return + } + + # # ## ### ##### ######## ############# + ## Internal methods + + proc FilterExcludedSymbols {} { + log write 3 filtersym "Remove the excluded symbols and their users" + + # We pull all the excluded symbols together into a table for + # easy reference by the upcoming DELETE and other statements. + # ('x IN table' clauses). + + set excl [project::sym excluded] + + state run { + CREATE TEMPORARY TABLE excludedsymbols AS + SELECT sid + FROM symbol + WHERE type = $excl + } + + # First we have to handle the possibility of an excluded + # NTDB. This is a special special case there we have to + # regraft the revisions which are shared between the NTDB and + # Trunk onto the trunk, preventing their deletion later. We + # have code for that in 'file', however that operated on the + # in-memory revision objects, which we do not have here. We do + # the same now without object, by directly manipulating the + # links in the database. + + array set ntdb {} + array set link {} + + state foreachrow { + SELECT R.rid AS xid, + R.parent AS xparent, + R.dbchild AS transfer + FROM revision R, symbol S + WHERE R.lod = S.sid -- Get symbol of line-of-development of all revisions + AND S.sid IN excludedsymbols -- Restrict to the excluded symbols + AND R.isdefault -- Restrict to NTDB revisions + } { + set ntdb($xid) $xparent + if {$transfer eq ""} continue + set link($xid) $transfer + } + + foreach joint [array names link] { + # The joints are the highest NTDB revisions which are + # shared with their respective trunk. We disconnect from + # their NTDB children, and make them parents of their + # 'dbchild'. The associated 'dbparent' is squashed + # instead. All parents of the joints are moved to the + # trunk as well. + + set tjoint $link($joint) + set tlod [state one { + SELECT lod FROM revision WHERE rid = $tjoint + }] + + # Covnert db/parent/child into regular parent/child links. + state run { + UPDATE revision SET dbparent = NULL, parent = $joint WHERE rid = $tjoint ; + UPDATE revision SET dbchild = NULL, child = $tjoint WHERE rid = $joint ; + } + while {1} { + # Move the NTDB trunk revisions to trunk. + state run { + UPDATE revision SET lod = $tlod, isdefault = 0 WHERE rid = $joint + } + set last $joint + set joint $ntdb($joint) + if {![info exists ntdb($joint)]} break + } + + # Reached the NTDB basis in the trunk. Finalize the + # parent/child linkage and squash the branch parent symbol + # reference. + + state run { + UPDATE revision SET child = $last WHERE rid = $joint ; + UPDATE revision SET bparent = NULL WHERE rid = $last ; + } + } + + # Now that the special case is done we can simply kill all the + # revisions, tags, and branches referencing any of the + # excluded symbols in some way. This is easy as we do not have + # to select them again and again from the base tables any + # longer. + + state run { + CREATE TEMPORARY TABLE excludedrevisions AS + SELECT rid FROM revision WHERE lod IN excludedsymbols; + + DELETE FROM revision WHERE lod IN excludedsymbols; + DELETE FROM tag WHERE lod IN excludedsymbols; + DELETE FROM tag WHERE sid IN excludedsymbols; + DELETE FROM branch WHERE lod IN excludedsymbols; + DELETE FROM branch WHERE sid IN excludedsymbols; + + DELETE FROM revisionbranchchildren WHERE rid IN excludedrevisions; + DELETE FROM revisionbranchchildren WHERE brid IN excludedrevisions; + DELETE FROM blob WHERE rid IN excludedrevisions; + + DROP TABLE excludedrevisions; + DROP TABLE excludedsymbols; + } + return + } + + proc MutateSymbols {} { + # Next, now that we know which symbols are what we look for + # file level tags which are actually converted as branches + # (project level, and vice versa), and move them to the + # correct tables. + + # # ## ### ##### ######## ############# + + log write 3 filtersym "Mutate symbols, preparation" + + set branch [project::sym branch] + set tag [project::sym tag] + + set tagstomutate [state run { + SELECT T.tid, T.fid, T.lod, T.sid, T.rev + FROM tag T, symbol S + WHERE T.sid = S.sid + AND S.type = $branch + }] + + set branchestomutate [state run { + SELECT B.bid, B.fid, B.lod, B.sid, B.root, B.first, B.bra + FROM branch B, symbol S + WHERE B.sid = S.sid + AND S.type = $tag + }] + + set nt [expr {[llength $tagstomutate]/5}] + set nb [expr {[llength $branchestomutate]/7}] + + log write 4 filtersym "Changing [nsp $nt tag] into [nsp $nt branch branches]" + log write 4 filtersym "Changing [nsp $nb branch branches] into [nsp $nb tag]" + + # # ## ### ##### ######## ############# + + log write 3 filtersym "Mutate tags to branches" + + foreach {id fid lod sid rev} $tagstomutate { + state run { + DELETE FROM tag WHERE tid = $id ; + INSERT INTO branch (bid, fid, lod, sid, root, first, bra, pos) + VALUES ($id, $fid, $lod, $sid, $rev, NULL, '', -1); + } + } + + log write 3 filtersym "Ok." + + # # ## ### ##### ######## ############# + + log write 3 filtersym "Mutate branches to tags" + + foreach {id fid lod sid root first bra} $branchestomutate { + state run { + DELETE FROM branch WHERE bid = $id ; + INSERT INTO tag (tid, fid, lod, sid, rev) + VALUES ($id, $fid, $lod, $sid, $root); + } + } + + log write 3 filtersym "Ok." + + # # ## ### ##### ######## ############# + return + } + + # Adjust the parents of symbols to their preferred parents. + + # If a file level ymbol has a preferred parent that is different + # than its current parent, and if the preferred parent is an + # allowed parent of the symbol in this file, then we graft the + # aSymbol onto its preferred parent. + + proc AdjustParents {} { + log write 3 filtersym "Adjust parents, loading data in preparation" + + # We pull important maps once into memory so that we do quick + # hash lookup later when processing the graft candidates. + + # Tag/Branch names ... + array set sn [state run { SELECT T.tid, S.name FROM tag T, symbol S WHERE T.sid = S.sid }] + array set sn [state run { SELECT B.bid, S.name FROM branch B, symbol S WHERE B.sid = S.sid }] + # Symbol names ... + array set sx [state run { SELECT L.sid, L.name FROM symbol L }] + # Files and projects. + array set fpn {} + state foreachrow { + SELECT F.fid AS id, F.name AS fn, P.name AS pn + FROM file F, project P + WHERE F.pid = P.pid + } { set fpn($id) [list $fn $pn] } + + set tagstoadjust [state run { + SELECT T.tid, T.fid, T.lod, P.pid, S.name, R.rev, R.rid + FROM tag T, preferedparent P, symbol S, revision R + WHERE T.sid = P.sid -- For all tags, get left-hand of prefered parent via symbol + AND T.lod != P.pid -- Restrict to tags whose LOD is not their prefered parent + AND P.pid = S.sid -- Get symbol of prefered parent + AND S.name != ':trunk:' -- Exclude trunk parentage + AND T.rev = R.rid -- Get revision the tag is attached to. + }] + + set branchestoadjust [state run { + SELECT B.bid, B.fid, B.lod, B.pos, P.pid, S.name, NULL, NULL + FROM branch B, preferedparent P, symbol S + WHERE B.sid = P.sid -- For all branches, get left-hand of prefered parent via symbol + AND B.lod != P.pid -- Restrict to branches whose LOD is not their prefered parent + AND P.pid = S.sid -- Get symbol of prefered parent + AND S.name != ':trunk:' -- Exclude trunk parentage + AND B.root IS NULL -- Accept free-floating branch + UNION + SELECT B.bid, B.fid, B.lod, B.pos, P.pid, S.name, R.rev, R.rid + FROM branch B, preferedparent P, symbol S, revision R + WHERE B.sid = P.sid -- For all branches, get left-hand of prefered parent via symbol + AND B.lod != P.pid -- Restrict to branches whose LOD is not their prefered parent + AND P.pid = S.sid -- Get symbol of prefered parent + AND S.name != ':trunk:' -- Exclude trunk parentage + AND B.root = R.rid -- Get root revision of the branch + }] + + set tmax [expr {[llength $tagstoadjust] / 7}] + set bmax [expr {[llength $branchestoadjust] / 8}] + + log write 4 filtersym "Reparenting at most [nsp $tmax tag]" + log write 4 filtersym "Reparenting at most [nsp $bmax branch branches]" + + log write 3 filtersym "Adjust tag parents" + + # Find the tags whose current parent (lod) is not the prefered + # parent, the prefered parent is not the trunk, and the + # prefered parent is a possible parent per the tag's revision. + + set fmt %[string length $tmax]s + set mxs [format $fmt $tmax] + + set n 0 + foreach {id fid lod pid preferedname revnr rid} $tagstoadjust { + # BOTTLE-NECK ... + # + # The check if the candidate (pid) is truly viable is + # based on finding the branch as possible parent, and done + # now instead of as part of the already complex join. + # + # ... AND P.pid IN (SELECT B.sid + # FROM branch B + # WHERE B.root = R.rid) + + if {![state one { + SELECT COUNT(*) -- Count <=> Check existence. + FROM branch B + WHERE B.sid = $pid -- Restrict to branch for that symbol + AND B.root = $rid -- attached to that revision + }]} { + incr tmax -1 + set mxs [format $fmt $tmax] + continue + } + + # + # BOTTLE-NECK ... + + # The names for use in the log output are retrieved + # separately, to keep the join selecting the adjustable + # tags small, not burdened with the dereferencing of links + # to name. + + set tagname $sn($id) + set oldname $sx($lod) + struct::list assign $fpn($fid) fname prname + + # Do the grafting. + + log write 4 filtersym {\[[format $fmt $n]/$mxs\] $prname : Grafting tag '$tagname' on $fname/$revnr from '$oldname' onto '$preferedname'} + state run { UPDATE tag SET lod = $pid WHERE tid = $id } + incr n + } + + log write 3 filtersym "Reparented [nsp $n tag]" + + log write 3 filtersym "Adjust branch parents" + + # Find the branches whose current parent (lod) is not the + # prefered parent, the prefered parent is not the trunk, and + # the prefered parent is a possible parent per the branch's + # revision. + + set fmt %[string length $bmax]s + set mxs [format $fmt $bmax] + + set n 0 + foreach {id fid lod pos pid preferedname revnr rid} $branchestoadjust { + + # BOTTLE-NECK ... + # + # The check if the candidate (pid) is truly viable is + # based on the branch positions in the spawning revision, + # and done now instead of as part of the already complex + # join. + # + # ... AND P.pid IN (SELECT BX.sid + # FROM branch BX + # WHERE BX.root = R.rid + # AND BX.pos > B.pos) + + # Note: rid eq "" hear means that this is a free-floating + # branch, whose original root was removed as a unnecessary + # dead revision (See 'file::RemoveIrrelevantDeletions'). + # Such a branch can be regrafted without trouble and there + # is no need to look for the new parent in its + # non-existent root. + + if {($rid ne "") && ![state one { + SELECT COUNT(*) -- Count <=> Check existence. + FROM branch B + WHERE B.sid = $pid -- Look for branch by symbol + AND B.root = $rid -- Spawned by the given revision + AND B.pos > $pos -- And defined before branch to mutate + }]} { + incr bmax -1 + set mxs [format $fmt $bmax] + continue + } + + # + # BOTTLE-NECK ... + + # The names for use in the log output are retrieved + # separately, to keep the join selecting the adjustable + # tags small, not burdened with the dereferencing of links + # to name. + + set braname $sn($id) + set oldname $sx($lod) + struct::list assign $fpn($fid) fname prname + + # Do the grafting. + + log write 4 filtersym {\[[format $fmt $n]/$mxs\] $prname : Grafting branch '$braname' on $fname/$revnr from '$oldname' onto '$preferedname'} + state run { UPDATE branch SET lod = $pid WHERE bid = $id } + incr n + } + + log write 3 filtersym "Reparented [nsp $n branch branches]" + return + } + + proc RefineSymbols {} { + # Tags and branches are marked as normal/noop based on the op + # of their revision. + + log write 3 filtersym "Refine symbols (no-op or not?)" + + # Note: The noop information is not used anywhere. Consider + # disabling this code, and removing the data from the state. + + log write 4 filtersym " Regular tags" + state run { + INSERT INTO noop + SELECT T.tid, 0 + FROM tag T, revision R + WHERE T.rev = R.rid + AND R.op != 0 -- 0 == nothing + } + + log write 4 filtersym " No-op tags" + state run { + INSERT INTO noop + SELECT T.tid, 1 + FROM tag T, revision R + WHERE T.rev = R.rid + AND R.op = 0 -- nothing + } + + log write 4 filtersym " Regular branches" + state run { + INSERT INTO noop + SELECT B.bid, 0 + FROM branch B, revision R + WHERE B.root = R.rid + AND R.op != 0 -- nothing + } + + log write 4 filtersym " No-op branches" + state run { + INSERT INTO noop + SELECT B.bid, 1 + FROM branch B, revision R + WHERE B.root = R.rid + AND R.op = 0 -- nothing + } + return + } + + proc maxlen {v str} { + upvar 1 $v n + set l [string length $str] + if {$l <= $n} return + set n $l + return + } + + proc PrintSymbolTree {} { + if {![log visible? 9]} return + + array set sym {} + set n 0 + set t 0 + set c 0 + set p 0 + + state foreachrow { + SELECT S.name AS xs, + A.name AS stype, + S.commit_count AS cc, + P.name AS xp, + B.name AS ptype + FROM symbol S, preferedparent SP, symbol P, symtype A, symtype B + WHERE SP.sid = S.sid + AND P.sid = SP.pid + AND A.tid = S.type + AND B.tid = P.type + } { + lappend sym($xs) $xp $stype $ptype $cc + maxlen n $xs + maxlen t $stype + maxlen t $ptype + maxlen c $cc + maxlen p $xp + } + + foreach xs [lsort -dict [array names sym]] { + struct::list assign $sym($xs) xp stype ptype cc + log write 9 filtersym {Tree: [lj $t $stype] ([dj $c $cc]) [lj $n $xs] <-- [lj $t $ptype] $xp} + } + return + } + + proc lj {n s} { ::format %-${n}s $s } + proc dj {n s} { ::format %-${n}d $s } + + # # ## ### ##### ######## ############# + ## Configuration + + pragma -hasinstances no ; # singleton + pragma -hastypeinfo no ; # no introspection + pragma -hastypedestroy no ; # immortal + + # # ## ### ##### ######## ############# +} + +namespace eval ::vc::fossil::import::cvs::pass { + namespace export filtersym + namespace eval filtersym { + namespace import ::vc::fossil::import::cvs::repository + namespace import ::vc::fossil::import::cvs::state + namespace import ::vc::fossil::import::cvs::integrity + namespace eval project { + namespace import ::vc::fossil::import::cvs::project::sym + } + namespace import ::vc::tools::misc::nsp + namespace import ::vc::tools::log + log register filtersym + } +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide vc::fossil::import::cvs::pass::filtersym 1.0 +return diff --git a/tools/cvs2fossil/lib/c2f_pimportcsets.tcl b/tools/cvs2fossil/lib/c2f_pimportcsets.tcl new file mode 100644 index 0000000..d152674 --- /dev/null +++ b/tools/cvs2fossil/lib/c2f_pimportcsets.tcl @@ -0,0 +1,133 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2008 Andreas Kupries. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## Pass XIII. This is the second of the backend passes. It imports the +## changesets constructed by the previous passes into one or more +## fossil repositories, one per project. + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.4 ; # Required runtime. +package require snit ; # OO system. +package require vc::tools::log ; # User feedback. +package require vc::fossil::import::cvs::repository ; # Repository management. +package require vc::fossil::import::cvs::state ; # State storage. +package require vc::fossil::import::cvs::fossil ; # Access to fossil repositories. +package require vc::fossil::import::cvs::ristate ; # Import state (revisions) + +# # ## ### ##### ######## ############# ##################### +## Register the pass with the management + +vc::fossil::import::cvs::pass define \ + ImportCSets \ + {Import the changesets into fossil repositories} \ + ::vc::fossil::import::cvs::pass::importcsets + +# # ## ### ##### ######## ############# ##################### +## + +snit::type ::vc::fossil::import::cvs::pass::importcsets { + # # ## ### ##### ######## ############# + ## Public API + + typemethod setup {} { + # Define the names and structure of the persistent state of + # this pass. + + state use project + state use file + state use revision + state use meta + state use author + state use cmessage + state use symbol + state use space + state use revuuid + return + } + + typemethod load {} { + # Pass manager interface. Executed to load data computed by + # this pass into memory when this pass is skipped instead of + # executed. + return + } + + typemethod run {} { + # Pass manager interface. Executed to perform the + # functionality of the pass. + + foreach project [repository projects] { + log write 1 importcsets {Importing project "[$project base]"} + + set pid [$project id] + set fossil [fossil %AUTO%] + struct::list assign [state run { + SELECT repository, workspace + FROM space + WHERE pid = $pid + }] r w + $fossil load $r $w + + set rstate [ristate %AUTO%] + + state transaction { + # Layer II: Changesets + foreach {cset date} [$project changesetsinorder] { + $cset pushto $fossil $date $rstate + } + } + + $rstate destroy + $fossil destroy + } + return + } + + typemethod discard {} { + # Pass manager interface. Executed for all passes after the + # run passes, to remove all data of this pass from the state, + # as being out of date. + return + } + + # # ## ### ##### ######## ############# + ## Internal methods + + # # ## ### ##### ######## ############# + ## Configuration + + pragma -hasinstances no ; # singleton + pragma -hastypeinfo no ; # no introspection + pragma -hastypedestroy no ; # immortal + + # # ## ### ##### ######## ############# +} + +namespace eval ::vc::fossil::import::cvs::pass { + namespace export importcsets + namespace eval importcsets { + namespace import ::vc::fossil::import::cvs::repository + namespace import ::vc::fossil::import::cvs::state + namespace import ::vc::fossil::import::cvs::fossil + namespace import ::vc::fossil::import::cvs::ristate + namespace import ::vc::tools::log + log register importcsets + } +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide vc::fossil::import::cvs::pass::importcsets 1.0 +return diff --git a/tools/cvs2fossil/lib/c2f_pimportfiles.tcl b/tools/cvs2fossil/lib/c2f_pimportfiles.tcl new file mode 100644 index 0000000..90e8d8a --- /dev/null +++ b/tools/cvs2fossil/lib/c2f_pimportfiles.tcl @@ -0,0 +1,151 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2007-2008 Andreas Kupries. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## Pass XII. This is the first of the backend passes. It imports the +## revisions of all files into one or more fossil repositories, one +## per project. + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.4 ; # Required runtime. +package require snit ; # OO system. +package require vc::tools::log ; # User feedback. +package require vc::fossil::import::cvs::repository ; # Repository management. +package require vc::fossil::import::cvs::state ; # State storage. +package require vc::fossil::import::cvs::fossil ; # Access to fossil repositories. + +# # ## ### ##### ######## ############# ##################### +## Register the pass with the management + +vc::fossil::import::cvs::pass define \ + ImportFiles \ + {Import the file revisions into fossil repositories} \ + ::vc::fossil::import::cvs::pass::importfiles + +# # ## ### ##### ######## ############# ##################### +## + +snit::type ::vc::fossil::import::cvs::pass::importfiles { + # # ## ### ##### ######## ############# + ## Public API + + typemethod setup {} { + # Define the names and structure of the persistent state of + # this pass. + + state use project + state use file + state use revision + state use meta + state use author + state use cmessage + state use symbol + + # Discard on setup. Do not discard on deferal. + state discard revuuid + state extend revuuid { + rid INTEGER NOT NULL REFERENCES revision UNIQUE, + uuid INTEGER NOT NULL -- fossil id of the revision + -- unique within the project + } + + # Remember the locations of the scratch data createdby this + # pass, for use by the next (importing changesets). + state discard space + state extend space { + pid INTEGER NOT NULL REFERENCES project, + repository TEXT NOT NULL, + workspace TEXT NOT NULL + } + return + } + + typemethod load {} { + # Pass manager interface. Executed to load data computed by + # this pass into memory when this pass is skipped instead of + # executed. + return + } + + typemethod run {} { + # Pass manager interface. Executed to perform the + # functionality of the pass. + + foreach project [repository projects] { + log write 1 importfiles {Importing project "[$project base]"} + + set pid [$project id] + set fossil [fossil %AUTO%] + $fossil initialize + + state transaction { + # Layer I: Files and their revisions + foreach file [$project files] { + $file pushto $fossil + } + + # Save the scratch locations, needed by the next pass. + struct::list assign [$fossil space] r w + state run { + DELETE FROM space + WHERE pid = $pid + ; + INSERT INTO space (pid, repository, workspace) + VALUES ($pid, $r, $w); + } + } + + $fossil destroy + } + return + } + + typemethod discard {} { + # Pass manager interface. Executed for all passes after the + # run passes, to remove all data of this pass from the state, + # as being out of date. + + # Not discarding revuuid/space here, allow us to keep the info + # for the next pass even if the revisions are recomputed. + return + } + + # # ## ### ##### ######## ############# + ## Internal methods + + # # ## ### ##### ######## ############# + ## Configuration + + pragma -hasinstances no ; # singleton + pragma -hastypeinfo no ; # no introspection + pragma -hastypedestroy no ; # immortal + + # # ## ### ##### ######## ############# +} + +namespace eval ::vc::fossil::import::cvs::pass { + namespace export importfiles + namespace eval importfiles { + namespace import ::vc::fossil::import::cvs::repository + namespace import ::vc::fossil::import::cvs::state + namespace import ::vc::fossil::import::cvs::fossil + namespace import ::vc::tools::log + log register importfiles + } +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide vc::fossil::import::cvs::pass::importfiles 1.0 +return diff --git a/tools/cvs2fossil/lib/c2f_pimportfinal.tcl b/tools/cvs2fossil/lib/c2f_pimportfinal.tcl new file mode 100644 index 0000000..98511fc --- /dev/null +++ b/tools/cvs2fossil/lib/c2f_pimportfinal.tcl @@ -0,0 +1,122 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2008 Andreas Kupries. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## Pass XIV. This is the third and last of the backend passes. It +## finalizes the fossil repositories we have constructed in the +## previous import passes. + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.4 ; # Required runtime. +package require snit ; # OO system. +package require vc::tools::log ; # User feedback. +package require vc::fossil::import::cvs::repository ; # Repository management. +package require vc::fossil::import::cvs::state ; # State storage. +package require vc::fossil::import::cvs::fossil ; # Access to fossil repositories. + +# # ## ### ##### ######## ############# ##################### +## Register the pass with the management + +vc::fossil::import::cvs::pass define \ + ImportFinal \ + {Finalize the import into fossil repositories} \ + ::vc::fossil::import::cvs::pass::importfinal + +# # ## ### ##### ######## ############# ##################### +## + +snit::type ::vc::fossil::import::cvs::pass::importfinal { + # # ## ### ##### ######## ############# + ## Public API + + typemethod setup {} { + # Define the names and structure of the persistent state of + # this pass. + + state use space + return + } + + typemethod load {} { + # Pass manager interface. Executed to load data computed by + # this pass into memory when this pass is skipped instead of + # executed. + return + } + + typemethod run {} { + # Pass manager interface. Executed to perform the + # functionality of the pass. + + foreach project [repository projects] { + log write 1 importfinal {Finalize project "[$project base]"} + + set pid [$project id] + set fossil [fossil %AUTO%] + struct::list assign [state run { + SELECT repository, workspace + FROM space + WHERE pid = $pid + }] r w + $fossil load $r $w + + # At last copy the temporary repository file to its final + # destination and release the associated memory. + + set destination [$project base] + if {$destination eq ""} { + set destination [file tail [repository base?]] + } + append destination .fsl + + $fossil finalize $destination ; # implies destroy + } + return + } + + typemethod discard {} { + # Pass manager interface. Executed for all passes after the + # run passes, to remove all data of this pass from the state, + # as being out of date. + return + } + + # # ## ### ##### ######## ############# + ## Internal methods + + # # ## ### ##### ######## ############# + ## Configuration + + pragma -hasinstances no ; # singleton + pragma -hastypeinfo no ; # no introspection + pragma -hastypedestroy no ; # immortal + + # # ## ### ##### ######## ############# +} + +namespace eval ::vc::fossil::import::cvs::pass { + namespace export importfinal + namespace eval importfinal { + namespace import ::vc::fossil::import::cvs::repository + namespace import ::vc::fossil::import::cvs::state + namespace import ::vc::fossil::import::cvs::fossil + namespace import ::vc::tools::log + log register importfinal + } +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide vc::fossil::import::cvs::pass::importfinal 1.0 +return diff --git a/tools/cvs2fossil/lib/c2f_pinitcsets.tcl b/tools/cvs2fossil/lib/c2f_pinitcsets.tcl new file mode 100644 index 0000000..cd4cafb --- /dev/null +++ b/tools/cvs2fossil/lib/c2f_pinitcsets.tcl @@ -0,0 +1,379 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2007-2008 Andreas Kupries. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## Pass V. This pass creates the initial set of project level +## revisions, aka changesets. Later passes will refine them, puts them +## into proper order, set their dependencies, etc. + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.4 ; # Required runtime. +package require snit ; # OO system. +package require vc::tools::misc ; # Text formatting. +package require vc::tools::log ; # User feedback. +package require vc::tools::mem ; # Memory tracking. +package require vc::fossil::import::cvs::repository ; # Repository management. +package require vc::fossil::import::cvs::state ; # State storage. +package require vc::fossil::import::cvs::integrity ; # State integrity checks. +package require vc::fossil::import::cvs::project::rev ; # Project level changesets + +# # ## ### ##### ######## ############# ##################### +## Register the pass with the management + +vc::fossil::import::cvs::pass define \ + InitCsets \ + {Initialize ChangeSets} \ + ::vc::fossil::import::cvs::pass::initcsets + +# # ## ### ##### ######## ############# ##################### +## + +snit::type ::vc::fossil::import::cvs::pass::initcsets { + # # ## ### ##### ######## ############# + ## Public API + + typemethod setup {} { + # Define the names and structure of the persistent state of + # this pass. + + state use project + state use file + state use revision + state use revisionbranchchildren + state use branch + state use tag + state use symbol + state use meta + + # Data per changeset, namely the project it belongs to, how it + # was induced (revision or symbol), plus reference to the + # primary entry causing it (meta entry or symbol). An adjunct + # table translates the type id's into human readable labels. + + state extend changeset { + cid INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT, + pid INTEGER NOT NULL REFERENCES project, + type INTEGER NOT NULL REFERENCES cstype, + src INTEGER NOT NULL -- REFERENCES meta|symbol (type dependent) + } + state extend cstype { + tid INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT, + name TEXT NOT NULL, + UNIQUE (name) + } + # Note: Keep the labels used here in sync with the names for + # singleton helper classes for 'project::rev'. They are + # the valid type names for changesets and also hardwired + # in some code. + state run { + INSERT INTO cstype VALUES (0,'rev'); + INSERT INTO cstype VALUES (1,'sym::tag'); + INSERT INTO cstype VALUES (2,'sym::branch'); + } + + # Map from changesets to the (file level) revisions, tags, or + # branches they contain. The pos'ition provides an order of + # the items within a changeset. They are unique within the + # changeset. The items are in principle unique, if we were + # looking only at relevant changesets. However as they come + # from disparate sources the same id may have different + # meaning, be in different changesets and so is formally not + # unique. So we can only say that it is unique within the + # changeset. The integrity module has stronger checks. + + state extend csitem { + cid INTEGER NOT NULL REFERENCES changeset, + pos INTEGER NOT NULL, + iid INTEGER NOT NULL, -- REFERENCES revision|tag|branch + UNIQUE (cid, pos), + UNIQUE (cid, iid) + } { iid } + # Index on: iid (successor/predecessor retrieval) + + project::rev getcstypes + return + } + + typemethod load {} { + # Pass manager interface. Executed to load data computed by + # this pass into memory when this pass is skipped instead of + # executed. + + state use changeset + state use csitem + state use cstype + + # Need the types first, the constructor used inside of the + # 'load' below uses them to assert the correctness of type + # names. + project::rev getcstypes + project::rev load ::vc::fossil::import::cvs::repository + project::rev loadcounter + return + } + + typemethod run {} { + # Pass manager interface. Executed to perform the + # functionality of the pass. + + state transaction { + CreateRevisionChangesets ; # Group file revisions into + # preliminary csets and split + # them based on internal + # conflicts. + CreateSymbolChangesets ; # Create csets for tags and + # branches. + } + + repository printcsetstatistics + integrity changesets + + # Load the changesets for use by the next passes. + project::rev load ::vc::fossil::import::cvs::repository + project::rev loadcounter + return + } + + typemethod discard {} { + # Pass manager interface. Executed for all passes after the + # run passes, to remove all data of this pass from the state, + # as being out of date. + + state discard changeset + state discard cstype + state discard csitem + return + } + + # # ## ### ##### ######## ############# + ## Internal methods + + proc CreateRevisionChangesets {} { + log write 3 initcsets {Create changesets based on revisions} + + # To get the initial of changesets we first group all file + # level revisions using the same meta data entry together. As + # the meta data encodes not only author and log message, but + # also line of development and project we can be sure that + # revisions in different project and lines of development are + # not grouped together. In contrast to cvs2svn we do __not__ + # use distance in time between revisions to break them + # apart. We have seen CVS repositories (from SF) where a + # single commit contained revisions several hours apart, + # likely due to trouble on the server hosting the repository. + + # We order the revisions here by time, this will help the + # later passes (avoids joins later to get at the ordering + # info). + + # The changesets made from these groups are immediately + # inspected for internal conflicts and any such are broken by + # splitting the problematic changeset into multiple + # fragments. The results are changesets which have no internal + # dependencies, only external ones. + + set n 0 + set nx 0 + + set lastmeta {} + set lastproject {} + set revisions {} + + # Note: We could have written this loop to create the csets + # early, extending them with all their revisions. This + # however would mean lots of (slow) method invokations + # on the csets. Doing it like this, late creation, means + # less such calls. None, but the creation itself. + + log write 14 initcsets meta_begin + mem::mark + state foreachrow { + SELECT M.mid AS xmid, + R.rid AS xrid, + M.pid AS xpid + FROM revision R, + meta M -- R ==> M, using PK index of M. + WHERE R.mid = M.mid + ORDER BY M.mid, R.date + } { + log write 14 initcsets meta_next + + if {$lastmeta != $xmid} { + if {[llength $revisions]} { + incr n + set p [repository projectof $lastproject] + log write 14 initcsets meta_cset_begin + mem::mark + set cset [project::rev %AUTO% $p rev $lastmeta $revisions] + log write 14 initcsets meta_cset_done + set spawned [$cset breakinternaldependencies nx] + $cset persist + $cset destroy + foreach cset $spawned { $cset persist ; $cset destroy } + mem::mark + set revisions {} + } + set lastmeta $xmid + set lastproject $xpid + } + lappend revisions $xrid + } + + if {[llength $revisions]} { + incr n + set p [repository projectof $lastproject] + log write 14 initcsets meta_cset_begin + mem::mark + set cset [project::rev %AUTO% $p rev $lastmeta $revisions] + log write 14 initcsets meta_cset_done + set spawned [$cset breakinternaldependencies nx] + $cset persist + $cset destroy + foreach cset $spawned { $cset persist ; $cset destroy } + mem::mark + } + + log write 14 initcsets meta_done + mem::mark + + log write 4 initcsets "Created and saved [nsp $n {revision changeset}]" + log write 4 initcsets "Created and saved [nsp $nx {additional revision changeset}]" + + mem::mark + log write 4 initcsets Ok. + return + } + + proc CreateSymbolChangesets {} { + log write 3 initcsets {Create changesets based on symbols} + mem::mark + + # Tags and branches induce changesets as well, containing the + # revisions they are attached to (tags), or spawned from + # (branches). + + set n 0 + + # First process the tags, then the branches. We know that + # their ids do not overlap with each other. + + set lastsymbol {} + set lastproject {} + set tags {} + + state foreachrow { + SELECT S.sid AS xsid, + T.tid AS xtid, + S.pid AS xpid + FROM tag T, + symbol S -- T ==> R/S, using PK indices of R, S. + WHERE T.sid = S.sid + ORDER BY S.sid, T.tid + } { + if {$lastsymbol != $xsid} { + if {[llength $tags]} { + incr n + set p [repository projectof $lastproject] + set cset [project::rev %AUTO% $p sym::tag $lastsymbol $tags] + set tags {} + $cset persist + $cset destroy + } + set lastsymbol $xsid + set lastproject $xpid + } + lappend tags $xtid + } + + if {[llength $tags]} { + incr n + set p [repository projectof $lastproject] + set cset [project::rev %AUTO% $p sym::tag $lastsymbol $tags] + $cset persist + $cset destroy + } + + set lastsymbol {} + set lasproject {} + set branches {} + + state foreachrow { + SELECT S.sid AS xsid, + B.bid AS xbid, + S.pid AS xpid + FROM branch B, + symbol S -- B ==> R/S, using PK indices of R, S. + WHERE B.sid = S.sid + ORDER BY S.sid, B.bid + } { + if {$lastsymbol != $xsid} { + if {[llength $branches]} { + incr n + set p [repository projectof $lastproject] + set cset [project::rev %AUTO% $p sym::branch $lastsymbol $branches] + set branches {} + $cset persist + $cset destroy + } + set lastsymbol $xsid + set lastproject $xpid + } + lappend branches $xbid + } + + if {[llength $branches]} { + incr n + set p [repository projectof $lastproject] + set cset [project::rev %AUTO% $p sym::branch $lastsymbol $branches] + $cset persist + $cset destroy + } + + log write 4 initcsets "Created and saved [nsp $n {symbol changeset}]" + mem::mark + return + } + + # # ## ### ##### ######## ############# + ## Configuration + + pragma -hasinstances no ; # singleton + pragma -hastypeinfo no ; # no introspection + pragma -hastypedestroy no ; # immortal + + # # ## ### ##### ######## ############# +} + +namespace eval ::vc::fossil::import::cvs::pass { + namespace export initcsets + namespace eval initcsets { + namespace import ::vc::fossil::import::cvs::repository + namespace import ::vc::fossil::import::cvs::state + namespace import ::vc::fossil::import::cvs::integrity + namespace eval project { + namespace import ::vc::fossil::import::cvs::project::rev + } + namespace eval mem { + namespace import ::vc::tools::mem::mark + } + namespace import ::vc::tools::misc::* + namespace import ::vc::tools::log + log register initcsets + } +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide vc::fossil::import::cvs::pass::initcsets 1.0 +return diff --git a/tools/cvs2fossil/lib/c2f_prev.tcl b/tools/cvs2fossil/lib/c2f_prev.tcl new file mode 100644 index 0000000..71d0d1d --- /dev/null +++ b/tools/cvs2fossil/lib/c2f_prev.tcl @@ -0,0 +1,1846 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2007-2008 Andreas Kupries. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## Revisions per project, aka Changesets. These objects are first used +## in pass 5, which creates the initial set covering the repository. + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.4 ; # Required runtime. +package require snit ; # OO system. +package require struct::set ; # Set operations. +package require vc::tools::misc ; # Text formatting +package require vc::tools::trouble ; # Error reporting. +package require vc::tools::log ; # User feedback. +package require vc::fossil::import::cvs::state ; # State storage. +package require vc::fossil::import::cvs::integrity ; # State integrity checks. + +# # ## ### ##### ######## ############# ##################### +## + +snit::type ::vc::fossil::import::cvs::project::rev { + # # ## ### ##### ######## ############# + ## Public API + + constructor {project cstype srcid items {theid {}}} { + if {$theid ne ""} { + set myid $theid + } else { + set myid [incr mycounter] + } + + integrity assert { + [info exists mycstype($cstype)] + } {Bad changeset type '$cstype'.} + + set myproject $project + set mytype $cstype + set mytypeobj ::vc::fossil::import::cvs::project::rev::${cstype} + set mysrcid $srcid + set myitems $items + set mypos {} ; # Commit location is not known yet. + + foreach iid $items { lappend mytitems [list $cstype $iid] } + + # Keep track of the generated changesets and of the inverse + # mapping from items to them. + lappend mychangesets $self + lappend mytchangesets($cstype) $self + set myidmap($myid) $self + + MapItems $cstype $items + return + } + + destructor { + # We may be able to get rid of this entirely, at least for + # (de)construction and pass InitCSets. + + UnmapItems $mytype $myitems + unset myidmap($myid) + + set pos [lsearch -exact $mychangesets $self] + set mychangesets [lreplace $mychangesets $pos $pos] + set pos [lsearch -exact $mytchangesets($mytype) $self] + set mytchangesets($mytype) [lreplace $mytchangesets($mytype) $pos $pos] + return + } + + method str {} { + set str "<" + set detail "" + if {[$mytypeobj bysymbol]} { + set detail " '[state one { + SELECT S.name + FROM symbol S + WHERE S.sid = $mysrcid + }]'" + } + append str "$mytype ${myid}${detail}>" + return $str + } + + method lod {} { + return [$mytypeobj cs_lod $mysrcid $myitems] + } + + method id {} { return $myid } + method items {} { return $mytitems } + method data {} { return [list $myproject $mytype $mysrcid] } + + delegate method bysymbol to mytypeobj + delegate method byrevision to mytypeobj + delegate method isbranch to mytypeobj + delegate method istag to mytypeobj + + method setpos {p} { set mypos $p ; return } + method pos {} { return $mypos } + + method determinesuccessors {} { + # Pass 6 operation. Compute project-level dependencies from + # the file-level data and save it back to the state. This may + # be called during the cycle breaker passes as well, to adjust + # the successor information of changesets which are the + # predecessors of dropped changesets. For them we have to + # remove their existing information first before inserting the + # new data. + state run { + DELETE FROM cssuccessor WHERE cid = $myid; + } + set loop 0 + # TODO: Check other uses of cs_sucessors. + # TODO: Consider merging cs_sucessor's SELECT with the INSERT here. + foreach nid [$mytypeobj cs_successors $myitems] { + state run { + INSERT INTO cssuccessor (cid, nid) + VALUES ($myid,$nid) + } + if {$nid == $myid} { set loop 1 } + } + # Report after the complete structure has been saved. + if {$loop} { $self reportloop } + return + } + + # result = list (changeset) + method successors {} { + # Use the data saved by pass 6. + return [struct::list map [state run { + SELECT S.nid + FROM cssuccessor S + WHERE S.cid = $myid + }] [mytypemethod of]] + } + + # item -> list (item) + method nextmap {} { + $mytypeobj successors tmp $myitems + return [array get tmp] + } + + method breakinternaldependencies {cv} { + upvar 1 $cv counter + log write 14 csets {[$self str] BID} + vc::tools::mem::mark + + # This method inspects the changeset, looking for internal + # dependencies. Nothing is done if there are no such. + + # Otherwise the changeset is split into a set of fragments + # which have no internal dependencies, transforming the + # internal dependencies into external ones. The new changesets + # generated from the fragment information are added to the + # list of all changesets (by the caller). + + # The code checks only successor dependencies, as this auto- + # matically covers the predecessor dependencies as well (Any + # successor dependency a -> b is also a predecessor dependency + # b -> a). + + array set breaks {} + + set fragments [BreakDirectDependencies $myitems breaks] + + if {![llength $fragments]} { return {} } + + return [$self CreateFromFragments $fragments counter breaks] + } + + method persist {} { + set tid $mycstype($mytype) + set pid [$myproject id] + set pos 0 + + state transaction { + state run { + INSERT INTO changeset (cid, pid, type, src) + VALUES ($myid, $pid, $tid, $mysrcid); + } + + foreach iid $myitems { + state run { + INSERT INTO csitem (cid, pos, iid) + VALUES ($myid, $pos, $iid); + } + incr pos + } + } + return + } + + method timerange {} { return [$mytypeobj timerange $myitems] } + + method limits {} { + struct::list assign [$mytypeobj limits $myitems] maxp mins + return [list [TagItemDict $maxp $mytype] [TagItemDict $mins $mytype]] + } + + method drop {} { + log write 8 csets {Dropping $self = [$self str]} + + state transaction { + state run { + DELETE FROM changeset WHERE cid = $myid; + DELETE FROM csitem WHERE cid = $myid; + DELETE FROM cssuccessor WHERE cid = $myid; + } + } + + # Return the list of predecessors so that they can be adjusted. + return [struct::list map [state run { + SELECT cid + FROM cssuccessor + WHERE nid = $myid + }] [mytypemethod of]] + } + + method reportloop {{kill 1}} { + # We print the items which are producing the loop, and how. + + set hdr "Self-referential changeset [$self str] __________________" + set ftr [regsub -all {[^ ]} $hdr {_}] + + log write 0 csets $hdr + foreach {item nextitem} [$mytypeobj loops $myitems] { + # Create tagged items from the id and our type. + set item [list $mytype $item] + set nextitem [list $mytype $nextitem] + # Printable labels. + set i "<[$type itemstr $item]>" + set n "<[$type itemstr $nextitem]>" + set ncs $myitemmap($nextitem) + # Print + log write 0 csets {* $i --> $n --> cs [$ncs str]} + } + log write 0 csets $ftr + + if {!$kill} return + trouble internal "[$self str] depends on itself" + return + } + + method pushto {repository date rstate} { + # Generate and import the manifest for this changeset. + # + # Data needed: + # - Commit message (-- mysrcid -> repository meta) + # - User doing the commit (s.a.) + # + # - Timestamp of when committed (command argument) + # + # - The parent changeset, if any. If there is no parent fossil + # will use the empty base revision as parent. + # + # - List of the file revisions in the changeset. + + # We derive the lod information directly from the revisions of + # the changeset, as the branch part of the meta data (s.a.) is + # outdated since pass FilterSymbols. See the method 'run' in + # file "c2f_pfiltersym.tcl" for more commentary on this. + + set lodname [$self lod] + + log write 2 csets {Importing changeset [$self str] on $lodname} + + if {[$mytypeobj istag]} { + # Handle tags. They appear immediately after the revision + # they are attached to (*). We can assume that the + # workspace for the relevant line of development + # exists. We retrieve it, then the uuid of the last + # revision entered into it, then tag this revision. + + # (*) Immediately in terms of the relevant line of + # development. Revisions on other lines may come in + # between, but they do not matter to that. + + set lws [Getworkspace $rstate $lodname $myproject 0] + set uuid [lindex [$lws getid] 1] + + $repository tag $uuid [state one { + SELECT S.name + FROM symbol S + WHERE S.sid = $mysrcid + }] + + } elseif {[$mytypeobj isbranch]} { + + # Handle branches. They appear immediately after the + # revision they are spawned from (*). We can assume that + # the workspace for the relevant line of development + # exists. + + # We retrieve it, then the uuid of the last revision + # entered into it. That revision is tagged as the root of + # the branch (**). A new workspace for the branch is + # created as well, for the future revisions of the new + # line of development. + + # An exception is made of the non-trunk default branch, + # aka vendor branch. This lod has to have a workspace not + # inherited from anything else. It has no root either, so + # tagging is out as well. + + # (*) Immediately in terms of the relevant line of + # development. Revisions on other lines may come in + # between, but they do not matter to that. + + # (**) Tagging the parent revision of the branch as its + # root is done to let us know about the existence of + # the branch even if it has no revisions committed to + # it, and thus no regular branch tag anywhere else. + # The name of the tag is the name for the lod, with + # the suffix '-root' appended to it. + + # LOD is self symbol of branch, not parent + set lodname [state one { + SELECT S.name + FROM symbol S + WHERE S.sid = $mysrcid + }] + + if {![$rstate has :trunk:]} { + # No trunk implies default branch. Just create the + # proper workspace. + Getworkspace $rstate $lodname $myproject 1 + } else { + # Non-default branch. Need workspace, and tag parent + # revision. + + set lws [Getworkspace $rstate $lodname $myproject 0] + set uuid [lindex [$lws getid] 1] + + $repository tag $uuid ${lodname}-root + } + } else { + # Revision changeset. + + struct::list assign [$myproject getmeta $mysrcid] __ __ user message + + # Perform the import. As part of that we determine the + # parent we need, and convert the list of items in the + # changeset into uuids and printable data. + + struct::list assign [Getisdefault $myitems] \ + isdefault lastdefaultontrunk + + log write 8 csets {LOD '$lodname'} + log write 8 csets { def? $isdefault} + log write 8 csets { last? $lastdefaultontrunk} + + set lws [Getworkspace $rstate $lodname $myproject $isdefault] + $lws add [Getrevisioninfo $myitems] + + struct::list assign \ + [$repository importrevision [$self str] \ + $user $message $date \ + [lindex [$lws getid] 0] [$lws get]] \ + rid uuid + + if {[$lws ticks] == 1} { + # First commit on this line of development. Set our + # own name as a propagating tag. And if the LOD has a + # parent we have to prevent the propagation of that + # tag into this new line. + + set plws [$lws parent] + if {$plws ne ""} { + $repository branchcancel $uuid [$plws name] + } + $repository branchmark $uuid [$lws name] + } + + # Remember the imported changeset in the state, under our + # LOD. And if it is the last trunk changeset on the vendor + # branch then the revision is also the actual root of the + # :trunk:, so we remember it as such in the state. However + # if the trunk already exists then the changeset cannot be + # on it any more. This indicates weirdness in the setup of + # the vendor branch, but one we can work around. + + $lws defid [list $rid $uuid] + if {$lastdefaultontrunk} { + log write 2 csets {This cset is the last on the NTDB, set the trunk workspace up} + + if {[$rstate has :trunk:]} { + log write 2 csets {Multiple changesets declared to be the last trunk changeset on the vendor-branch} + } else { + $rstate new :trunk: [$lws name] + } + } + } + + log write 2 csets { } + log write 2 csets { } + return + } + + proc Getrevisioninfo {revisions} { + set theset ('[join $revisions {','}]') + set revisions {} + state foreachrow [subst -nocommands -nobackslashes { + SELECT U.uuid AS frid, + F.visible AS path, + F.name AS fname, + R.rev AS revnr, + R.op AS rop + FROM revision R, revuuid U, file F + WHERE R.rid IN $theset -- All specified revisions + AND U.rid = R.rid -- get fossil uuid of revision + AND F.fid = R.fid -- get file of revision + }] { + lappend revisions $frid $path $fname/$revnr $rop + } + return $revisions + } + + proc Getworkspace {rstate lodname project isdefault} { + + # The state object holds the workspace state of each known + # line-of-development (LOD), up to the last committed + # changeset belonging to that LOD. + + # (*) Standard handling if in-LOD changesets. If the LOD of + # the current changeset exists in the state (= has been + # committed to) then this it has the workspace we are + # looking for. + + if {[$rstate has $lodname]} { + return [$rstate get $lodname] + } + + # If the LOD is however not yet known, then the current + # changeset can be either of + # (a) root of a vendor branch, + # (b) root of the trunk LOD, or + # (c) the first changeset in a new LOD which was spawned from + # an existing LOD. + + # For both (a) and (b) we have to create a new workspace for + # the lod, and it doesn't inherit from anything. + + # One exception for (a). If we already have a :vendor: branch + # then multiple symbols were used for the vendor branch by + # different files. In that case the 'new' branch is made an + # alias of the :vendor:, effectively merging the symbols + # together. + + # Note that case (b) may never occur. See the variable + # 'lastdefaultontrunk' in the caller (method pushto). This + # flag can the generation of the workspace for the :trunk: LOD + # as well, making it inherit the state of the last + # trunk-changeset on the vendor-branch. + + if {$isdefault} { + if {![$rstate has ":vendor:"]} { + # Create the vendor branch if not present already. We + # use the actual name for the lod, and additional make + # it accessible under an internal name (:vendor:) so + # that we can merge to it later, should it become + # necessary. See the other branch below. + $rstate new $lodname + $rstate dup :vendor: <-- $lodname + } else { + # Merge the new symbol to the vendor branch + $rstate dup $lodname <-- :vendor: + } + return [$rstate get $lodname] + } + + if {$lodname eq ":trunk:"} { + return [$rstate new $lodname] + } + + # Case (c). We find the parent LOD of our LOD and let the new + # workspace inherit from the parent's workspace. + + set plodname [[[$project getsymbol $lodname] parent] name] + + log write 8 csets {pLOD '$plodname'} + + if {[$rstate has $plodname]} { + return [$rstate new $lodname $plodname] + } + + foreach k [lsort [$rstate names]] { + log write 8 csets { $k = [[$rstate get $k] getid]} + } + + trouble internal {Unable to determine changeset parent} + return + } + + proc Getisdefault {revisions} { + set theset ('[join $revisions {','}]') + + struct::list assign [state run [subst -nocommands -nobackslashes { + SELECT R.isdefault, R.dbchild + FROM revision R + WHERE R.rid IN $theset -- All specified revisions + LIMIT 1 + }]] def last + + # TODO/CHECK: look for changesets where isdefault/dbchild is + # ambigous. + + return [list $def [expr {$last ne ""}]] + } + + typemethod split {cset args} { + # As part of the creation of the new changesets specified in + # ARGS as sets of items, all subsets of CSET's item set, CSET + # will be dropped from all databases, in and out of memory, + # and then destroyed. + # + # Note: The item lists found in args are tagged items. They + # have to have the same type as the changeset, being subsets + # of its items. This is checked in Untag1. + + log write 8 csets {OLD: [lsort [$cset items]]} + ValidateFragments $cset $args + + # All checks pass, actually perform the split. + + struct::list assign [$cset data] project cstype cssrc + + set predecessors [$cset drop] + $cset destroy + + set newcsets {} + foreach fragmentitems $args { + log write 8 csets {MAKE: [lsort $fragmentitems]} + + set fragment [$type %AUTO% $project $cstype $cssrc \ + [Untag $fragmentitems $cstype]] + lappend newcsets $fragment + + $fragment persist + $fragment determinesuccessors + } + + # The predecessors have to recompute their successors, i.e. + # remove the dropped changeset and put one of the fragments + # into its place. + foreach p $predecessors { + $p determinesuccessors + } + + return $newcsets + } + + typemethod itemstr {item} { + struct::list assign $item itype iid + return [$itype str $iid] + } + + typemethod strlist {changesets} { + return [join [struct::list map $changesets [myproc ID]]] + } + + proc ID {cset} { $cset str } + + proc Untag {taggeditems cstype} { + return [struct::list map $taggeditems [myproc Untag1 $cstype]] + } + + proc Untag1 {cstype theitem} { + struct::list assign $theitem t i + integrity assert {$cstype eq $t} {Item $i's type is '$t', expected '$cstype'} + return $i + } + + proc TagItemDict {itemdict cstype} { + set res {} + foreach {i v} $itemdict { lappend res [list $cstype $i] $v } + return $res + } + + proc ValidateFragments {cset fragments} { + # Check the various integrity constraints for the fragments + # specifying how to split the changeset: + # + # * We must have two or more fragments, as splitting a + # changeset into one makes no sense. + # * No fragment may be empty. + # * All fragments have to be true subsets of the items in the + # changeset to split. The 'true' is implied because none are + # allowed to be empty, so each has to be smaller than the + # total. + # * The union of the fragments has to be the item set of the + # changeset. + # * The fragment must not overlap, i.e. their pairwise + # intersections have to be empty. + + set cover {} + foreach fragmentitems $fragments { + log write 8 csets {NEW: [lsort $fragmentitems]} + + integrity assert { + ![struct::set empty $fragmentitems] + } {changeset fragment is empty} + + integrity assert { + [struct::set subsetof $fragmentitems [$cset items]] + } {changeset fragment is not a subset} + struct::set add cover $fragmentitems + } + + integrity assert { + [struct::set equal $cover [$cset items]] + } {The fragments do not cover the original changeset} + + set i 1 + foreach fia $fragments { + foreach fib [lrange $fragments $i end] { + integrity assert { + [struct::set empty [struct::set intersect $fia $fib]] + } {The fragments <$fia> and <$fib> overlap} + } + incr i + } + + return + } + + # # ## ### ##### ######## ############# + ## State + + variable myid {} ; # Id of the cset for the persistent + # state. + variable myproject {} ; # Reference of the project object the + # changeset belongs to. + variable mytype {} ; # What the changeset is based on + # (revisions, tags, or branches). + # Values: See mycstype. Note that we + # have to keep the names of the helper + # singletons in sync with the contents + # of state table 'cstype', and various + # other places using them hardwired. + variable mytypeobj {} ; # Reference to the container for the + # type dependent code. Derived from + # mytype. + variable mysrcid {} ; # Id of the metadata or symbol the cset + # is based on. + variable myitems {} ; # List of the file level revisions, + # tags, or branches in the cset, as + # ids. Not tagged. + variable mytitems {} ; # As myitems, the tagged form. + variable mypos {} ; # Commit position of the changeset, if + # known. + + # # ## ### ##### ######## ############# + ## Internal methods + + typevariable mycounter 0 ; # Id counter for csets. Last id + # used. + typevariable mycstype -array {} ; # Map cstypes (names) to persistent + # ids. Note that we have to keep + # the names in the table 'cstype' + # in sync with the names of the + # helper singletons. + + typemethod inorder {projectid} { + # Return all changesets (object references) for the specified + # project, in the order given to them by the sort passes. Both + # the filtering by project and the sorting by time make the + # use of 'project::rev rev' impossible. + + set res {} + state foreachrow { + SELECT C.cid AS xcid, + T.date AS cdate + FROM changeset C, cstimestamp T + WHERE C.pid = $projectid -- limit to changesets in project + AND T.cid = C.cid -- get ordering information + ORDER BY T.date -- sort into commit order + } { + lappend res $myidmap($xcid) $cdate + } + return $res + } + + typemethod getcstypes {} { + state foreachrow { + SELECT tid, name FROM cstype; + } { set mycstype($name) $tid } + return + } + + typemethod load {repository} { + set n 0 + log write 2 csets {Loading the changesets} + state foreachrow { + SELECT C.cid AS id, + C.pid AS xpid, + CS.name AS cstype, + C.src AS srcid + FROM changeset C, cstype CS + WHERE C.type = CS.tid + ORDER BY C.cid + } { + log progress 2 csets $n {} + set r [$type %AUTO% [$repository projectof $xpid] $cstype $srcid [state run { + SELECT C.iid + FROM csitem C + WHERE C.cid = $id + ORDER BY C.pos + }] $id] + incr n + } + return + } + + typemethod loadcounter {} { + # Initialize the counter from the state + log write 2 csets {Loading changeset counter} + set mycounter [state one { SELECT MAX(cid) FROM changeset }] + return + } + + typemethod num {} { return $mycounter } + + # # ## ### ##### ######## ############# + + method CreateFromFragments {fragments cv bv} { + upvar 1 $cv counter $bv breaks + UnmapItems $mytype $myitems + + # Create changesets for the fragments, reusing the current one + # for the first fragment. We sort them in order to allow + # checking for gaps and nice messages. + + set newcsets {} + set fragments [lsort -index 0 -integer $fragments] + + #puts \t.[join [PRs $fragments] .\n\t.]. + + Border [lindex $fragments 0] firsts firste + + integrity assert { + $firsts == 0 + } {Bad fragment start @ $firsts, gap, or before beginning of the range} + + set laste $firste + foreach fragment [lrange $fragments 1 end] { + Border $fragment s e + integrity assert { + $laste == ($s - 1) + } {Bad fragment border <$laste | $s>, gap or overlap} + + set new [$type %AUTO% $myproject $mytype $mysrcid [lrange $myitems $s $e]] + lappend newcsets $new + incr counter + + log write 4 csets {Breaking [$self str ] @ $laste, new [$new str], cutting $breaks($laste)} + + set laste $e + } + + integrity assert { + $laste == ([llength $myitems]-1) + } {Bad fragment end @ $laste, gap, or beyond end of the range} + + # Put the first fragment into the current changeset, and + # update the in-memory index. We can simply (re)add the items + # because we cleared the previously existing information, see + # 'UnmapItems' above. Persistence does not matter here, none + # of the changesets has been saved to the persistent state + # yet. + + set myitems [lrange $myitems 0 $firste] + set mytitems [lrange $mytitems 0 $firste] + MapItems $mytype $myitems + return $newcsets + } + + # # ## ### ##### ######## ############# + + proc BreakDirectDependencies {theitems bv} { + upvar 1 mytypeobj mytypeobj self self $bv breaks + + # Array of dependencies (parent -> child). This is pulled from + # the state, and limited to successors within the changeset. + + array set dependencies {} + + $mytypeobj internalsuccessors dependencies $theitems + if {![array size dependencies]} { + return {} + } ; # Nothing to break. + + log write 5 csets ...[$self str]....................................................... + vc::tools::mem::mark + + return [BreakerCore $theitems dependencies breaks] + } + + proc BreakerCore {theitems dv bv} { + # Break a set of revisions into fragments which have no + # internal dependencies. + + # We perform all necessary splits in one go, instead of only + # one. The previous algorithm, adapted from cvs2svn, computed + # a lot of state which was thrown away and then computed again + # for each of the fragments. It should be easier to update and + # reuse that state. + + upvar 1 $dv dependencies $bv breaks + + # We have internal dependencies to break. We now iterate over + # all positions in the list (which is chronological, at least + # as far as the timestamps are correct and unique) and + # determine the best position for the break, by trying to + # break as many dependencies as possible in one go. When a + # break was found this is redone for the fragments coming and + # after, after upding the crossing information. + + # Data structures: + # Map: POS revision id -> position in list. + # CROSS position in list -> number of dependencies crossing it + # DEPC dependency -> positions it crosses + # List: RANGE Of the positions itself. + # Map: DELTA position in list -> time delta between its revision + # and the next, if any. + # A dependency is a single-element map parent -> child + + # InitializeBreakState initializes their contents after + # upvar'ing them from this scope. It uses the information in + # DEPENDENCIES to do so. + + InitializeBreakState $theitems + + set fragments {} + set new [list $range] + + # Instead of one list holding both processed and pending + # fragments we use two, one for the framents to process, one + # to hold the new fragments, and the latter is copied to the + # former when they run out. This keeps the list of pending + # fragments short without sacrificing speed by shifting stuff + # down. We especially drop the memory of fragments broken + # during processing after a short time, instead of letting it + # consume memory. + + while {[llength $new]} { + + set pending $new + set new {} + set at 0 + + while {$at < [llength $pending]} { + set current [lindex $pending $at] + + log write 6 csets {. . .. ... ..... ........ .............} + log write 6 csets {Scheduled [join [PRs [lrange $pending $at end]] { }]} + log write 6 csets {Considering [PR $current] \[$at/[llength $pending]\]} + + set best [FindBestBreak $current] + + if {$best < 0} { + # The inspected range has no internal + # dependencies. This is a complete fragment. + lappend fragments $current + + log write 6 csets "No breaks, final" + } else { + # Split the range and schedule the resulting + # fragments for further inspection. Remember the + # number of dependencies cut before we remove them + # from consideration, for documentation later. + + set breaks($best) $cross($best) + + log write 6 csets "Best break @ $best, cutting [nsp $cross($best) dependency dependencies]" + + # Note: The value of best is an abolute location + # in myitems. Use the start of current to make it + # an index absolute to current. + + set brel [expr {$best - [lindex $current 0]}] + set bnext $brel ; incr bnext + set fragbefore [lrange $current 0 $brel] + set fragafter [lrange $current $bnext end] + + log write 6 csets "New pieces [PR $fragbefore] [PR $fragafter]" + + integrity assert {[llength $fragbefore]} {Found zero-length fragment at the beginning} + integrity assert {[llength $fragafter]} {Found zero-length fragment at the end} + + lappend new $fragbefore $fragafter + CutAt $best + } + + incr at + } + } + + log write 6 csets ". . .. ... ..... ........ ............." + + return $fragments + } + + proc InitializeBreakState {revisions} { + upvar 1 pos pos cross cross range range depc depc delta delta \ + dependencies dependencies + + # First we create a map of positions to make it easier to + # determine whether a dependency crosses a particular index. + + log write 14 csets {IBS: #rev [llength $revisions]} + log write 14 csets {IBS: pos map, cross counter} + + array set pos {} + array set cross {} + array set depc {} + set range {} + set n 0 + foreach rev $revisions { + lappend range $n + set pos($rev) $n + set cross($n) 0 + incr n + } + + log write 14 csets {IBS: pos/[array size pos], cross/[array size cross]} + + # Secondly we count the crossings per position, by iterating + # over the recorded internal dependencies. + + # Note: If the timestamps are badly out of order it is + # possible to have a backward successor dependency, + # i.e. with start > end. We may have to swap the indices + # to ensure that the following loop runs correctly. + # + # Note 2: start == end is not possible. It indicates a + # self-dependency due to the uniqueness of positions, + # and that is something we have ruled out already, see + # 'rev internalsuccessors'. + + log write 14 csets {IBS: cross counter filling, pos/cross map} + + foreach {rid children} [array get dependencies] { + foreach child $children { + set dkey [list $rid $child] + set start $pos($rid) + set end $pos($child) + + if {$start > $end} { + set crosses [list $end [expr {$start-1}]] + while {$end < $start} { + incr cross($end) + incr end + } + } else { + set crosses [list $start [expr {$end-1}]] + while {$start < $end} { + incr cross($start) + incr start + } + } + set depc($dkey) $crosses + } + } + + log write 14 csets {IBS: pos/[array size pos], cross/[array size cross], depc/[array size depc] (for [llength $revisions])} + log write 14 csets {IBS: timestamps, deltas} + + InitializeDeltas $revisions + + log write 14 csets {IBS: delta [array size delta]} + return + } + + proc InitializeDeltas {revisions} { + upvar 1 delta delta + + # Pull the timestamps for all revisions in the changesets and + # compute their deltas for use by the break finder. + + array set delta {} + array set stamp {} + + set theset ('[join $revisions {','}]') + state foreachrow [subst -nocommands -nobackslashes { + SELECT R.rid AS xrid, R.date AS time + FROM revision R + WHERE R.rid IN $theset + }] { + set stamp($xrid) $time + } + + log write 14 csets {IBS: stamp [array size stamp]} + + set n 0 + foreach rid [lrange $revisions 0 end-1] rnext [lrange $revisions 1 end] { + set delta($n) [expr {$stamp($rnext) - $stamp($rid)}] + incr n + } + return + } + + proc FindBestBreak {range} { + upvar 1 cross cross delta delta + + # Determine the best break location in the given range of + # positions. First we look for the locations with the maximal + # number of crossings. If there are several we look for the + # shortest time interval among them. If we still have multiple + # possibilities after that we select the earliest location + # among these. + + # Note: If the maximal number of crossings is 0 then the range + # has no internal dependencies, and no break location at + # all. This possibility is signaled via result -1. + + # Note: A range of length 1 or less cannot have internal + # dependencies, as that needs at least two revisions in + # the range. + + if {[llength $range] < 2} { return -1 } + + set max -1 + set best {} + + foreach location $range { + set crossings $cross($location) + if {$crossings > $max} { + set max $crossings + set best [list $location] + continue + } elseif {$crossings == $max} { + lappend best $location + } + } + + if {$max == 0} { return -1 } + if {[llength $best] == 1} { return [lindex $best 0] } + + set locations $best + set best {} + set min -1 + + foreach location $locations { + set interval $delta($location) + if {($min < 0) || ($interval < $min)} { + set min $interval + set best [list $location] + } elseif {$interval == $min} { + lappend best $location + } + } + + if {[llength $best] == 1} { return [lindex $best 0] } + + return [lindex [lsort -integer -increasing $best] 0] + } + + proc CutAt {location} { + upvar 1 cross cross depc depc + + # It was decided to split the changeset at the given + # location. This cuts a number of dependencies. Here we update + # the cross information so that the break finder has accurate + # data when we look at the generated fragments. + + set six [log visible? 6] + + # Note: The loop below could be made faster by keeping a map + # from positions to the dependencies crossing. An extension of + # CROSS, i.e. list of dependencies, counter is implied. Takes + # a lot more memory however, and takes time to update here + # (The inner loop is not incr -1, but ldelete). + + foreach dep [array names depc] { + set range $depc($dep) + # Check all dependencies still known, take their range and + # see if the break location falls within. + + Border $range s e + if {$location < $s} continue ; # break before range, ignore + if {$location > $e} continue ; # break after range, ignore. + + # This dependency crosses the break location. We remove it + # from the crossings counters, and then also from the set + # of known dependencies, as we are done with it. + + Border $depc($dep) ds de + for {set loc $ds} {$loc <= $de} {incr loc} { + incr cross($loc) -1 + } + unset depc($dep) + + if {!$six} continue + + struct::list assign $dep parent child + log write 5 csets "Broke dependency [PD $parent] --> [PD $child]" + } + + return + } + + # Print identifying data for a revision (project, file, dotted rev + # number), for high verbosity log output. + # TODO: Replace with call to itemstr (list rev $id) + + proc PD {id} { + foreach {p f r} [state run { + SELECT P.name , F.name, R.rev + FROM revision R, file F, project P + WHERE R.rid = $id -- Find specified file revision + AND F.fid = R.fid -- Get file of the revision + AND P.pid = F.pid -- Get project of the file. + }] break + return "'$p : $f/$r'" + } + + # Printing one or more ranges, formatted, and only their border to + # keep the strings short. + + proc PRs {ranges} { + return [struct::list map $ranges [myproc PR]] + } + + proc PR {range} { + Border $range s e + return <${s}...${e}> + } + + proc Border {range sv ev} { + upvar 1 $sv s $ev e + set s [lindex $range 0] + set e [lindex $range end] + return + } + + # # ## ### ##### ######## ############# + + proc UnmapItems {thetype theitems} { + # (*) We clear out the associated part of the myitemmap + # in-memory index in preparation for new data, or as part of + # object destruction. A simple unset is enough, we have no + # symbol changesets at this time, and thus never more than one + # reference in the list. + + upvar 1 myitemmap myitemmap self self + foreach iid $theitems { + set key [list $thetype $iid] + unset myitemmap($key) + log write 8 csets {MAP- item <$key> $self = [$self str]} + } + return + } + + proc MapItems {thetype theitems} { + upvar 1 myitemmap myitemmap self self + + foreach iid $theitems { + set key [list $thetype $iid] + set myitemmap($key) $self + log write 8 csets {MAP+ item <$key> $self = [$self str]} + } + return + } + + # # ## ### ##### ######## ############# + + typevariable mychangesets {} ; # List of all known + # changesets. + + # List of all known changesets of a type. + typevariable mytchangesets -array { + sym::branch {} + sym::tag {} + rev {} + } + + typevariable myitemmap -array {} ; # Map from items (tagged) + # to the list of changesets + # containing it. Each item + # can be used by only one + # changeset. + typevariable myidmap -array {} ; # Map from changeset id to + # changeset. + + typemethod all {} { return $mychangesets } + typemethod of {cid} { return $myidmap($cid) } + typemethod ofitem {iid} { return $myitemmap($iid) } + + typemethod rev {} { return $mytchangesets(rev) } + typemethod sym {} { return [concat \ + ${mytchangesets(sym::branch)} \ + ${mytchangesets(sym::tag)}] } + + # # ## ### ##### ######## ############# + ## Configuration + + pragma -hastypeinfo no ; # no type introspection + pragma -hasinfo no ; # no object introspection + + # # ## ### ##### ######## ############# +} + +## +## NOTE: The successor and predecessor methods defined by the classes +## below are -- bottle necks --. Look for ways to make the SQL +## faster. +## + +# # ## ### ##### ######## ############# ##################### +## Helper singleton. Commands for revision changesets. + +snit::type ::vc::fossil::import::cvs::project::rev::rev { + typemethod byrevision {} { return 1 } + typemethod bysymbol {} { return 0 } + typemethod istag {} { return 0 } + typemethod isbranch {} { return 0 } + + typemethod str {revision} { + struct::list assign [state run { + SELECT R.rev, F.name, P.name + FROM revision R, file F, project P + WHERE R.rid = $revision -- Find specified file revision + AND F.fid = R.fid -- Get file of the revision + AND P.pid = F.pid -- Get project of the file. + }] revnr fname pname + return "$pname/${revnr}::$fname" + } + + # result = list (mintime, maxtime) + typemethod timerange {items} { + set theset ('[join $items {','}]') + return [state run [subst -nocommands -nobackslashes { + SELECT MIN(R.date), MAX(R.date) + FROM revision R + WHERE R.rid IN $theset -- Restrict to revisions of interest + }]] + } + + # var(dv) = dict (revision -> list (revision)) + typemethod internalsuccessors {dv revisions} { + upvar 1 $dv dependencies + set theset ('[join $revisions {','}]') + + log write 14 csets internalsuccessors + + # See 'successors' below for the main explanation of + # the various cases. This piece is special in that it + # restricts the successors we look for to the same set of + # revisions we start from. Sensible as we are looking for + # changeset internal dependencies. + + array set dep {} + + state foreachrow [subst -nocommands -nobackslashes { + -- (1) Primary child + SELECT R.rid AS xrid, R.child AS xchild + FROM revision R + WHERE R.rid IN $theset -- Restrict to revisions of interest + AND R.child IS NOT NULL -- Has primary child + AND R.child IN $theset -- Which is also of interest + UNION + -- (2) Secondary (branch) children + SELECT R.rid AS xrid, B.brid AS xchild + FROM revision R, revisionbranchchildren B + WHERE R.rid IN $theset -- Restrict to revisions of interest + AND R.rid = B.rid -- Select subset of branch children + AND B.brid IN $theset -- Which is also of interest + UNION + -- (4) Child of trunk root successor of last NTDB on trunk. + SELECT R.rid AS xrid, RA.child AS xchild + FROM revision R, revision RA + WHERE R.rid IN $theset -- Restrict to revisions of interest + AND R.isdefault -- Restrict to NTDB + AND R.dbchild IS NOT NULL -- and last NTDB belonging to trunk + AND RA.rid = R.dbchild -- Go directly to trunk root + AND RA.child IS NOT NULL -- Has primary child. + AND RA.child IN $theset -- Which is also of interest + }] { + # Consider moving this to the integrity module. + integrity assert {$xrid != $xchild} {Revision $xrid depends on itself.} + lappend dependencies($xrid) $xchild + set dep($xrid,$xchild) . + } + + # The sql statements above looks only for direct dependencies + # between revision in the changeset. However due to the + # vagaries of meta data it is possible for two revisions of + # the same file to end up in the same changeset, without a + # direct dependency between them. However we know that there + # has to be a an indirect dependency, be it through primary + # children, branch children, or a combination thereof. + + # We now fill in these pseudo-dependencies, if no such + # dependency exists already. The direction of the dependency + # is actually irrelevant for this. + + # NOTE: This is different from cvs2svn. Our spiritual ancestor + # does not use such pseudo-dependencies, however it uses a + # COMMIT_THRESHOLD, a time interval commits should fall. This + # will greatly reduces the risk of getting far separated + # revisions of the same file into one changeset. + + # We allow revisions to be far apart in time in the same + # changeset, but in turn need the pseudo-dependencies to + # handle this. + + log write 14 csets {internal [array size dep]} + log write 14 csets {collected [array size dependencies]} + log write 14 csets pseudo-internalsuccessors + + array set fids {} + state foreachrow [subst -nocommands -nobackslashes { + SELECT R.rid AS xrid, R.fid AS xfid + FROM revision R + WHERE R.rid IN $theset + }] { lappend fids($xfid) $xrid } + + set groups {} + foreach {fid rids} [array get fids] { + if {[llength $rids] < 2} continue + foreach a $rids { + foreach b $rids { + if {$a == $b} continue + if {[info exists dep($a,$b)]} continue + if {[info exists dep($b,$a)]} continue + lappend dependencies($a) $b + set dep($a,$b) . + set dep($b,$a) . + } + } + set n [llength $rids] + lappend groups [list $n [expr {($n*$n-$n)/2}]] + } + + log write 14 csets {pseudo [array size fids] ([lsort -index 0 -decreasing -integer $groups])} + log write 14 csets {internal [array size dep]} + log write 14 csets {collected [array size dependencies]} + log write 14 csets complete + return + } + + # result = 4-list (itemtype itemid nextitemtype nextitemid ...) + typemethod loops {revisions} { + # Note: Tags and branches cannot cause the loop. Their id's, + # being of a fundamentally different type than the revisions + # coming in cannot be in the set. + + set theset ('[join $revisions {','}]') + return [state run [subst -nocommands -nobackslashes { + -- (1) Primary child + SELECT R.rid, R.child + FROM revision R + WHERE R.rid IN $theset -- Restrict to revisions of interest + AND R.child IS NOT NULL -- Has primary child + AND R.child IN $theset -- Loop + -- + UNION + -- (2) Secondary (branch) children + SELECT R.rid, B.brid + FROM revision R, revisionbranchchildren B + WHERE R.rid IN $theset -- Restrict to revisions of interest + AND R.rid = B.rid -- Select subset of branch children + AND B.rid IN $theset -- Loop + -- + UNION + -- (4) Child of trunk root successor of last NTDB on trunk. + SELECT R.rid, RA.child + FROM revision R, revision RA + WHERE R.rid IN $theset -- Restrict to revisions of interest + AND R.isdefault -- Restrict to NTDB + AND R.dbchild IS NOT NULL -- and last NTDB belonging to trunk + AND RA.rid = R.dbchild -- Go directly to trunk root + AND RA.child IS NOT NULL -- Has primary child. + AND RA.child IN $theset -- Loop + }]] + } + + # var(dv) = dict (item -> list (item)), item = list (type id) + typemethod successors {dv revisions} { + upvar 1 $dv dependencies + set theset ('[join $revisions {','}]') + + # The following cases specify when a revision S is a successor + # of a revision R. Each of the cases translates into one of + # the branches of the SQL UNION coming below. + # + # (1) S can be a primary child of R, i.e. in the same LOD. R + # references S directly. R.child = S(.rid), if it exists. + # + # (2) S can be a secondary, i.e. branch, child of R. Here the + # link is made through the helper table + # REVISIONBRANCHCHILDREN. R.rid -> RBC.rid, RBC.brid = + # S(.rid) + # + # (3) Originally this use case defined the root of a detached + # NTDB as the successor of the trunk root. This leads to a + # bad tangle later on. With a detached NTDB the original + # trunk root revision was removed as irrelevant, allowing + # the nominal root to be later in time than the NTDB + # root. Now setting this dependency will be backward in + # time. REMOVED. + # + # (4) If R is the last of the NTDB revisions which belong to + # the trunk, then the primary child of the trunk root (the + # '1.2' revision) is a successor, if it exists. + + # Note that the branches spawned from the revisions, and the + # tags associated with them are successors as well. + + state foreachrow [subst -nocommands -nobackslashes { + -- (1) Primary child + SELECT R.rid AS xrid, R.child AS xchild + FROM revision R + WHERE R.rid IN $theset -- Restrict to revisions of interest + AND R.child IS NOT NULL -- Has primary child + UNION + -- (2) Secondary (branch) children + SELECT R.rid AS xrid, B.brid AS xchild + FROM revision R, revisionbranchchildren B + WHERE R.rid IN $theset -- Restrict to revisions of interest + AND R.rid = B.rid -- Select subset of branch children + UNION + -- (4) Child of trunk root successor of last NTDB on trunk. + SELECT R.rid AS xrid, RA.child AS xchild + FROM revision R, revision RA + WHERE R.rid IN $theset -- Restrict to revisions of interest + AND R.isdefault -- Restrict to NTDB + AND R.dbchild IS NOT NULL -- and last NTDB belonging to trunk + AND RA.rid = R.dbchild -- Go directly to trunk root + AND RA.child IS NOT NULL -- Has primary child. + }] { + # Consider moving this to the integrity module. + integrity assert {$xrid != $xchild} {Revision $xrid depends on itself.} + lappend dependencies([list rev $xrid]) [list rev $xchild] + } + state foreachrow [subst -nocommands -nobackslashes { + SELECT R.rid AS xrid, T.tid AS xchild + FROM revision R, tag T + WHERE R.rid IN $theset -- Restrict to revisions of interest + AND T.rev = R.rid -- Select tags attached to them + }] { + lappend dependencies([list rev $xrid]) [list sym::tag $xchild] + } + state foreachrow [subst -nocommands -nobackslashes { + SELECT R.rid AS xrid, B.bid AS xchild + FROM revision R, branch B + WHERE R.rid IN $theset -- Restrict to revisions of interest + AND B.root = R.rid -- Select branches attached to them + }] { + lappend dependencies([list rev $xrid]) [list sym::branch $xchild] + } + return + } + + # result = list (changeset-id) + typemethod cs_successors {revisions} { + # This is a variant of 'successors' which maps the low-level + # data directly to the associated changesets. I.e. instead + # millions of dependency pairs (in extreme cases (Example: Tcl + # CVS)) we return a very short and much more manageable list + # of changesets. + + set theset ('[join $revisions {','}]') + return [state run [subst -nocommands -nobackslashes { + -- (1) Primary child + SELECT C.cid + FROM revision R, csitem CI, changeset C + WHERE R.rid IN $theset -- Restrict to revisions of interest + AND R.child IS NOT NULL -- Has primary child + AND CI.iid = R.child -- Select all changesets + AND C.cid = CI.cid -- containing the primary child + AND C.type = 0 -- which are revision changesets + UNION + -- (2) Secondary (branch) children + SELECT C.cid + FROM revision R, revisionbranchchildren B, csitem CI, changeset C + WHERE R.rid IN $theset -- Restrict to revisions of interest + AND R.rid = B.rid -- Select subset of branch children + AND CI.iid = B.brid -- Select all changesets + AND C.cid = CI.cid -- containing the branch + AND C.type = 0 -- which are revision changesets + UNION + -- (4) Child of trunk root successor of last NTDB on trunk. + SELECT C.cid + FROM revision R, revision RA, csitem CI, changeset C + WHERE R.rid IN $theset -- Restrict to revisions of interest + AND R.isdefault -- Restrict to NTDB + AND R.dbchild IS NOT NULL -- and last NTDB belonging to trunk + AND RA.rid = R.dbchild -- Go directly to trunk root + AND RA.child IS NOT NULL -- Has primary child. + AND CI.iid = RA.child -- Select all changesets + AND C.cid = CI.cid -- containing the primary child + AND C.type = 0 -- which are revision changesets + UNION + SELECT C.cid + FROM revision R, tag T, csitem CI, changeset C + WHERE R.rid in $theset -- Restrict to revisions of interest + AND T.rev = R.rid -- Select tags attached to them + AND CI.iid = T.tid -- Select all changesets + AND C.cid = CI.cid -- containing the tags + AND C.type = 1 -- which are tag changesets + UNION + SELECT C.cid + FROM revision R, branch B, csitem CI, changeset C + WHERE R.rid in $theset -- Restrict to revisions of interest + AND B.root = R.rid -- Select branches attached to them + AND CI.iid = B.bid -- Select all changesets + AND C.cid = CI.cid -- containing the branches + AND C.type = 2 -- which are branch changesets + }]] + + # Regarding rev -> branch|tag, we could consider looking at + # the symbol of the branch|tag, its lod-symbol, and the + # revisions on that lod, but don't. Because it is not exact + # enough, the branch|tag would depend on revisions coming + # after its creation on the parental lod. + } + + # result = symbol name + typemethod cs_lod {metaid revisions} { + # Determines the name of the symbol which is the line of + # development for the revisions in a changeset. The + # information in the meta data referenced by the source metaid + # is out of date by the time we come here (since pass + # FilterSymbols), so it cannot be used. See the method 'run' + # in file "c2f_pfiltersym.tcl" for more commentary on this. + + set theset ('[join $revisions {','}]') + return [state run [subst -nocommands -nobackslashes { + SELECT + DISTINCT L.name + FROM revision R, symbol L + WHERE R.rid in $theset -- Restrict to revisions of interest + AND L.sid = R.lod -- Get lod symbol of revision + }]] + } +} + +# # ## ### ##### ######## ############# ##################### +## Helper singleton. Commands for tag symbol changesets. + +snit::type ::vc::fossil::import::cvs::project::rev::sym::tag { + typemethod byrevision {} { return 0 } + typemethod bysymbol {} { return 1 } + typemethod istag {} { return 1 } + typemethod isbranch {} { return 0 } + + typemethod str {tag} { + struct::list assign [state run { + SELECT S.name, F.name, P.name + FROM tag T, symbol S, file F, project P + WHERE T.tid = $tag -- Find specified tag + AND F.fid = T.fid -- Get file of tag + AND P.pid = F.pid -- Get project of file + AND S.sid = T.sid -- Get symbol of tag + }] sname fname pname + return "$pname/T'${sname}'::$fname" + } + + # result = list (mintime, maxtime) + typemethod timerange {tags} { + # The range is defined as the range of the revisions the tags + # are attached to. + + set theset ('[join $tags {','}]') + return [state run [subst -nocommands -nobackslashes { + SELECT MIN(R.date), MAX(R.date) + FROM tag T, revision R + WHERE T.tid IN $theset -- Restrict to tags of interest + AND R.rid = T.rev -- Select tag parent revisions + }]] + } + + # var(dv) = dict (item -> list (item)), item = list (type id) + typemethod successors {dv tags} { + # Tags have no successors. + return + } + + # result = 4-list (itemtype itemid nextitemtype nextitemid ...) + typemethod loops {tags} { + # Tags have no successors, therefore cannot cause loops + return {} + } + + # result = list (changeset-id) + typemethod cs_successors {tags} { + # Tags have no successors. + return + } + + # result = symbol name + typemethod cs_lod {sid tags} { + # Determines the name of the symbol which is the line of + # development for the tags in a changeset. Comes directly from + # the symbol which is the changeset's source and its prefered + # parent. + + return [state run { + SELECT P.name + FROM preferedparent SP, symbol P + WHERE SP.sid = $sid + AND P.sid = SP.pid + }] + } +} + +# # ## ### ##### ######## ############# ##################### +## Helper singleton. Commands for branch symbol changesets. + +snit::type ::vc::fossil::import::cvs::project::rev::sym::branch { + typemethod byrevision {} { return 0 } + typemethod bysymbol {} { return 1 } + typemethod istag {} { return 0 } + typemethod isbranch {} { return 1 } + + typemethod str {branch} { + struct::list assign [state run { + SELECT S.name, F.name, P.name + FROM branch B, symbol S, file F, project P + WHERE B.bid = $branch -- Find specified branch + AND F.fid = B.fid -- Get file of branch + AND P.pid = F.pid -- Get project of file + AND S.sid = B.sid -- Get symbol of branch + }] sname fname pname + return "$pname/B'${sname}'::$fname" + } + + # result = list (mintime, maxtime) + typemethod timerange {branches} { + # The range of a branch is defined as the range of the + # revisions the branches are spawned by. NOTE however that the + # branches associated with a detached NTDB will have no root + # spawning them, hence they have no real timerange any + # longer. By using 0 we put them in front of everything else, + # as they logically are. + + set theset ('[join $branches {','}]') + return [state run [subst -nocommands -nobackslashes { + SELECT IFNULL(MIN(R.date),0), IFNULL(MAX(R.date),0) + FROM branch B, revision R + WHERE B.bid IN $theset -- Restrict to branches of interest + AND R.rid = B.root -- Select branch parent revisions + }]] + } + + # result = 4-list (itemtype itemid nextitemtype nextitemid ...) + typemethod loops {branches} { + # Note: Revisions and tags cannot cause the loop. Being of a + # fundamentally different type they cannot be in the incoming + # set of ids. + + set theset ('[join $branches {','}]') + return [state run [subst -nocommands -nobackslashes { + SELECT B.bid, BX.bid + FROM branch B, preferedparent P, branch BX + WHERE B.bid IN $theset -- Restrict to branches of interest + AND B.sid = P.pid -- Get the prefered branches via + AND BX.sid = P.sid -- the branch symbols + AND BX.bid IN $theset -- Loop + }]] + } + + # var(dv) = dict (item -> list (item)), item = list (type id) + typemethod successors {dv branches} { + upvar 1 $dv dependencies + # The first revision committed on a branch, and all branches + # and tags which have it as their prefered parent are the + # successors of a branch. + + set theset ('[join $branches {','}]') + state foreachrow [subst -nocommands -nobackslashes { + SELECT B.bid AS xbid, R.rid AS xchild + FROM branch B, revision R + WHERE B.bid IN $theset -- Restrict to branches of interest + AND B.first = R.rid -- Get first revision on the branch + }] { + lappend dependencies([list sym::branch $xbid]) [list rev $xchild] + } + state foreachrow [subst -nocommands -nobackslashes { + SELECT B.bid AS xbid, BX.bid AS xchild + FROM branch B, preferedparent P, branch BX + WHERE B.bid IN $theset -- Restrict to branches of interest + AND B.sid = P.pid -- Get subordinate branches via the + AND BX.sid = P.sid -- prefered parents of their symbols + }] { + lappend dependencies([list sym::branch $xbid]) [list sym::branch $xchild] + } + state foreachrow [subst -nocommands -nobackslashes { + SELECT B.bid AS xbid, T.tid AS xchild + FROM branch B, preferedparent P, tag T + WHERE B.bid IN $theset -- Restrict to branches of interest + AND B.sid = P.pid -- Get subordinate tags via the + AND T.sid = P.sid -- prefered parents of their symbols + }] { + lappend dependencies([list sym::branch $xbid]) [list sym::tag $xchild] + } + return + } + + # result = list (changeset-id) + typemethod cs_successors {branches} { + # This is a variant of 'successors' which maps the low-level + # data directly to the associated changesets. I.e. instead + # millions of dependency pairs (in extreme cases (Example: Tcl + # CVS)) we return a very short and much more manageable list + # of changesets. + + set theset ('[join $branches {','}]') + return [state run [subst -nocommands -nobackslashes { + SELECT C.cid + FROM branch B, revision R, csitem CI, changeset C + WHERE B.bid IN $theset -- Restrict to branches of interest + AND B.first = R.rid -- Get first revision on the branch + AND CI.iid = R.rid -- Select all changesets + AND C.cid = CI.cid -- containing this revision + AND C.type = 0 -- which are revision changesets + UNION + SELECT C.cid + FROM branch B, preferedparent P, branch BX, csitem CI, changeset C + WHERE B.bid IN $theset -- Restrict to branches of interest + AND B.sid = P.pid -- Get subordinate branches via the + AND BX.sid = P.sid -- prefered parents of their symbols + AND CI.iid = BX.bid -- Select all changesets + AND C.cid = CI.cid -- containing the subordinate branches + AND C.type = 2 -- which are branch changesets + UNION + SELECT C.cid + FROM branch B, preferedparent P, tag T, csitem CI, changeset C + WHERE B.bid IN $theset -- Restrict to branches of interest + AND B.sid = P.pid -- Get subordinate tags via the + AND T.sid = P.sid -- prefered parents of their symbols + AND CI.iid = T.tid -- Select all changesets + AND C.cid = CI.cid -- containing the subordinate tags + AND C.type = 1 -- which are tag changesets + }]] + return + } + + # result = symbol name + typemethod cs_lod {sid branches} { + # Determines the name of the symbol which is the line of + # development for the branches in a changeset. Comes directly + # from the symbol which is the changeset's source and its + # prefered parent. + + return [state run { + SELECT P.name + FROM preferedparent SP, symbol P + WHERE SP.sid = $sid + AND P.sid = SP.pid + }] + } + + typemethod limits {branches} { + # Notes. This method exists only for branches. It is needed to + # get detailed information about a backward branch. It does + # not apply to tags, nor revisions. The queries can also + # restrict themselves to the revision sucessors/predecessors + # of branches, as only they have ordering data and thus can + # cause the backwardness. + + set theset ('[join $branches {','}]') + + set maxp [state run [subst -nocommands -nobackslashes { + -- maximal predecessor position per branch + SELECT B.bid, MAX (CO.pos) + FROM branch B, revision R, csitem CI, changeset C, csorder CO + WHERE B.bid IN $theset -- Restrict to branches of interest + AND B.root = R.rid -- Get branch root revisions + AND CI.iid = R.rid -- Get changesets containing the + AND C.cid = CI.cid -- root revisions, which are + AND C.type = 0 -- revision changesets + AND CO.cid = C.cid -- Get their topological ordering + GROUP BY B.bid + }]] + + set mins [state run [subst -nocommands -nobackslashes { + -- minimal successor position per branch + SELECT B.bid, MIN (CO.pos) + FROM branch B, revision R, csitem CI, changeset C, csorder CO + WHERE B.bid IN $theset -- Restrict to branches of interest + AND B.first = R.rid -- Get the first revisions on the branches + AND CI.iid = R.rid -- Get changesets containing the + AND C.cid = CI.cid -- first revisions, which are + AND C.type = 0 -- revision changesets + AND CO.cid = C.cid -- Get their topological ordering + GROUP BY B.bid + }]] + + return [list $maxp $mins] + } + + # # ## ### ##### ######## ############# + ## Configuration + + pragma -hasinstances no ; # singleton + pragma -hastypeinfo no ; # no introspection + pragma -hastypedestroy no ; # immortal +} + +# # ## ### ##### ######## ############# ##################### +## + +namespace eval ::vc::fossil::import::cvs::project { + namespace export rev + namespace eval rev { + namespace import ::vc::fossil::import::cvs::state + namespace import ::vc::fossil::import::cvs::integrity + namespace import ::vc::tools::misc::* + namespace import ::vc::tools::trouble + namespace import ::vc::tools::log + log register csets + + # Set up the helper singletons + namespace eval rev { + namespace import ::vc::fossil::import::cvs::state + namespace import ::vc::fossil::import::cvs::integrity + namespace import ::vc::tools::log + } + namespace eval sym::tag { + namespace import ::vc::fossil::import::cvs::state + namespace import ::vc::fossil::import::cvs::integrity + namespace import ::vc::tools::log + } + namespace eval sym::branch { + namespace import ::vc::fossil::import::cvs::state + namespace import ::vc::fossil::import::cvs::integrity + namespace import ::vc::tools::log + } + } +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide vc::fossil::import::cvs::project::rev 1.0 +return diff --git a/tools/cvs2fossil/lib/c2f_prevlink.tcl b/tools/cvs2fossil/lib/c2f_prevlink.tcl new file mode 100644 index 0000000..53be78c --- /dev/null +++ b/tools/cvs2fossil/lib/c2f_prevlink.tcl @@ -0,0 +1,240 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2007 Andreas Kupries. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## Helper class for the pass 6 cycle breaker. Each instance refers to +## three changesets A, B, and C, with A a predecessor of B, and B +## predecessor of C, and the whole part of a dependency cycle. + +## Instances analyse the file level dependencies which gave rise to +## the changeset dependencies of A, B, and C, with the results used by +## the cycle breaker algorithm to find a good location where to at +## least weaken and at best fully break the cycle. + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.4 ; # Required runtime. +package require snit ; # OO system. +package require vc::tools::misc ; # Text formatting +package require vc::tools::trouble ; # Error reporting. +package require vc::tools::log ; # User feedback. +package require vc::fossil::import::cvs::state ; # State storage. +package require vc::fossil::import::cvs::integrity ; # State integrity checks. +package require vc::fossil::import::cvs::project::rev ; # Project level changesets + +# # ## ### ##### ######## ############# ##################### +## + +snit::type ::vc::fossil::import::cvs::project::revlink { + # # ## ### ##### ######## ############# + ## Public API + + constructor {prev cset next} { + set myprev $prev + set mycset $cset + set mynext $next + + # We perform the bulk of the analysis during construction. The + # file revisions held by the changeset CSET can be sorted into + # four categories. + + # 1. Revisions whose predecessors are not in PREV, nor are + # their successors found in NEXT. These revisions do not + # count, as they did not induce any of the two dependencies + # under consideration. They can be ignored. + + # 2. Revisions which have predecessors in PREV and successors + # in NEXT. They are called 'passthrough' in cvs2svn. They + # induce both dependencies under consideration and are thus + # critical in the creation of the cycle. As such they are + # also unbreakable :( + + # 3. Revisions which have predecessor in PREVE, but no + # successors in NEXT. As such they induced the incoming + # dependency, but not the outgoing one. + + # 4. Revisions which have no predecessors in PREVE, but their + # successors are in NEXT. As such they induced the outgoing + # dependency, but not the incoming one. + + # If we have no passthrough revisions then splitting the + # changeset between categories 3 and 4, with category 1 going + # wherever, will break the cycle. If category 2 revisions are + # present we can still perform the split, this will however + # not break the cycle, only weaken it. + + # NOTE: This is the only remaining user of 'nextmap'. Look + # into the possibility of performing the relevant counting + # within the database. + + array set csetprevmap [Invert [$myprev nextmap]] + array set csetnextmap [$mycset nextmap] + + set prevrev [$myprev items] + set nextrev [$mynext items] + + foreach item [$mycset items] { + set rt [RT $item] + incr mycount($rt) + lappend mycategory($rt) $item + } + return + } + + # Result is TRUE if and only breaking myset will do some good. + method breakable {} { expr {$mycount(prev) || $mycount(next)} } + method passcount {} { return $mycount(pass) } + + method linkstomove {} { + # Return the number of revisions that would be moved should we + # split the changeset. + + set n [min2 $mycount(prev) $mycount(next)] + if {$n > 0 } { return $n } + return [max2 $mycount(prev) $mycount(next)] + } + + method betterthan {other} { + set sbreak [$self breakable] + set obreak [$other breakable] + + if {$sbreak && !$obreak} { return 1 } ; # self is better. + if {!$sbreak && $obreak} { return 0 } ; # self is worse. + + # Equality. Look at the counters. + # - Whichever has the lesser number of passthrough revisions + # is better, as more can be split off, weakening the cycle + # more. + # - Whichever has less links to move is better. + + set opass [$other passcount] + if {$mycount(pass) < $opass} { return 1 } ; # self is better. + if {$mycount(pass) > $opass} { return 0 } ; # self is worse. + + set smove [$self linkstomove] + set omove [$other linkstomove] + + if {$smove < $omove} { return 1 } ; # self is better. + + return 0 ; # Self is worse or equal, i.e. not better. + } + + method break {} { + integrity assert {[$self breakable]} {Changeset [$mycset str] is not breakable.} + + # One thing to choose when splitting CSET is where the + # revision in categories 1 and 2 (none and passthrough + # respectively) are moved to. This is done using the counters. + + if {!$mycount(prev)} { + # Nothing in category 3 => 1,2 go there, 4 the other. + set mycategory(prev) [concat $mycategory(none) $mycategory(pass)] + } elseif {!$mycount(next)} { + # Nothing in category 4 => 1,2 go there, 3 the other. + set mycategory(next) [concat $mycategory(none) $mycategory(pass)] + } elseif {$mycount(prev) < $mycount(next)} { + # Less predecessors than successors => 1,2 go to the + # sucessors. + set mycategory(next) [concat $mycategory(next) $mycategory(none) \ + $mycategory(pass)] + } else { + # Less successors than predecessors => 1,2 go to the + # predecessors. + set mycategory(next) [concat $mycategory(next) $mycategory(none) \ + $mycategory(pass)] + } + + # We now have the revisions for the two fragments to be in the + # (prev|next) elements of mycategory. + + return [project::rev split $mycset $mycategory(prev) $mycategory(next)] + } + + # # ## ### ##### ######## ############# + ## State + + variable myprev {} ; # Reference to predecessor changeset in the link. + variable mycset {} ; # Reference to the main changeset of the link. + variable mynext {} ; # Reference to the successor changeset in the link. + + # Counters for the revision categories. + variable mycount -array { + none 0 + prev 0 + next 0 + pass 0 + } + # Lists of revisions for the various categories + variable mycategory -array { + none {} + prev {} + next {} + pass {} + } + + # # ## ### ##### ######## ############# + ## Internal methods + + proc RT {r} { + upvar 1 csetprevmap csetprevmap csetnextmap csetnextmap prevrev prevrev nextrev nextrev + + set inc [expr {[info exists csetprevmap($r)] + ? [struct::set size [struct::set intersect $csetprevmap($r) $prevrev]] + : 0}] + set out [expr {[info exists csetnextmap($r)] + ? [struct::set size [struct::set intersect $csetnextmap($r) $nextrev]] + : 0}] + + if {$inc && $out} { return pass } + if {$inc} { return prev } + if {$out} { return next } + return none + } + + proc Invert {dict} { + array set tmp {} + foreach {k values} $dict { + foreach v $values { lappend tmp($v) $k } + } + return [array get tmp] + } + + # # ## ### ##### ######## ############# + ## Configuration + + pragma -hastypeinfo no ; # no type introspection + pragma -hasinfo no ; # no object introspection + pragma -simpledispatch yes ; # simple fast dispatch + + # # ## ### ##### ######## ############# +} + +namespace eval ::vc::fossil::import::cvs::project { + namespace export revlink + namespace eval revlink { + namespace import ::vc::fossil::import::cvs::state + namespace import ::vc::fossil::import::cvs::integrity + namespace import ::vc::tools::misc::* + namespace import ::vc::tools::trouble + namespace eval project { + namespace import ::vc::fossil::import::cvs::project::rev + } + namespace import ::vc::tools::log + log register csets + } +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide vc::fossil::import::cvs::project::revlink 1.0 +return diff --git a/tools/cvs2fossil/lib/c2f_project.tcl b/tools/cvs2fossil/lib/c2f_project.tcl new file mode 100644 index 0000000..88f515f --- /dev/null +++ b/tools/cvs2fossil/lib/c2f_project.tcl @@ -0,0 +1,233 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2007-2008 Andreas Kupries. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## Project, part of a CVS repository. Multiple instances are possible. + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.4 ; # Required runtime. +package require snit ; # OO system. +package require vc::fossil::import::cvs::file ; # CVS archive file. +package require vc::fossil::import::cvs::state ; # State storage. +package require vc::fossil::import::cvs::project::rev ; # Changesets. +package require vc::fossil::import::cvs::project::sym ; # Per project symbols. +package require vc::fossil::import::cvs::project::trunk ; # Per project trunk, main lod +package require vc::tools::log ; # User feedback +package require struct::list ; # Advanced list operations.. + +# # ## ### ##### ######## ############# ##################### +## + +snit::type ::vc::fossil::import::cvs::project { + # # ## ### ##### ######## ############# + ## Public API + + constructor {path r} { + set mybase $path + set myrepository $r + set mytrunk [trunk %AUTO% $self] + set mysymbol([$mytrunk name]) $mytrunk + return + } + + method base {} { return $mybase } + method trunk {} { return $mytrunk } + + method fullpath {} { return [$myrepository base?]/$mybase } + + method printbase {} { + if {$mybase eq ""} {return <Repository>} + return $mybase + } + + method id {} { return $myid } + method setid {id} { set myid $id ; return } + + method addfile {rcs usr executable {fid {}}} { + set myfiles($rcs) [list $usr $executable $fid] + return + } + + method filenames {} { + return [lsort -dict [array names myfiles]] + } + + method files {} { + return [TheFiles] + } + + delegate method defauthor to myrepository + delegate method defcmessage to myrepository + delegate method trunkonly to myrepository + delegate method commitmessageof to myrepository + + method defmeta {bid aid cid} { + return [$myrepository defmeta $myid $bid $aid $cid] + } + + method getsymbol {name} { + if {![info exists mysymbol($name)]} { + set mysymbol($name) \ + [sym %AUTO% $name [$myrepository defsymbol $myid $name] $self] + } + return $mysymbol($name) + } + + method hassymbol {name} { + return [info exists mysymbol($name)] + } + + method purgeghostsymbols {} { + set changes 1 + while {$changes} { + set changes 0 + foreach {name symbol} [array get mysymbol] { + if {![$symbol isghost]} continue + log write 3 project "$mybase: Deleting ghost symbol '$name'" + $symbol destroy + unset mysymbol($name) + set changes 1 + } + } + return + } + + method determinesymboltypes {} { + foreach {name symbol} [array get mysymbol] { + $symbol determinetype + } + return + } + + # pass I persistence + method persist {} { + TheFiles ; # Force id assignment. + + state transaction { + # Project data first. Required so that we have its id + # ready for the files. + + state run { + INSERT INTO project (pid, name) + VALUES (NULL, $mybase); + } + set myid [state id] + + # Then all files, with proper backreference to their + # project. + + foreach rcs [lsort -dict [array names myfiles]] { + struct::list assign $myfiles($rcs) usr executable _fid_ + state run { + INSERT INTO file (fid, pid, name, visible, exec) + VALUES (NULL, $myid, $rcs, $usr, $executable); + } + $myfmap($rcs) setid [state id] + } + } + return + } + + # pass II persistence + method persistrev {} { + # Note: The per file information (incl. revisions and symbols) + # has already been saved and dropped. This was done + # immediately after processing it, i.e. as part of the main + # segment of the pass, to keep out use of memory under + # control. + # + # The repository level information has been saved as well too, + # just before saving the projects started. So now we just have + # to save the remaining project level parts to fix the + # left-over dangling references, which are the symbols. + + state transaction { + foreach {name symbol} [array get mysymbol] { + $symbol persistrev + } + } + return + } + + method changesetsinorder {} { + return [rev inorder $myid] + } + + delegate method getmeta to myrepository + + # # ## ### ##### ######## ############# + ## State + + variable mybase {} ; # Project directory. + variable myid {} ; # Project id in the persistent state. + variable mytrunk {} ; # Reference to the main line of + # development for the project. + variable myfiles -array {} ; # Maps the rcs archive paths to + # their user-visible files. + variable myfobj {} ; # File objects for the rcs archives + variable myfmap -array {} ; # Map rcs archive to their object. + variable myrepository {} ; # Repository the project belongs to. + variable mysymbol -array {} ; # Map symbol names to project-level + # symbol objects. + + # # ## ### ##### ######## ############# + ## Internal methods + + proc TheFiles {} { + upvar 1 myfiles myfiles myfobj myfobj self self myfmap myfmap + if {![llength $myfobj]} { + set myfobj [EmptyFiles myfiles] + } + return $myfobj + } + + proc EmptyFiles {fv} { + upvar 1 $fv myfiles self self myfmap myfmap + set res {} + foreach rcs [lsort -dict [array names myfiles]] { + struct::list assign $myfiles($rcs) f executable fid + set file [file %AUTO% $fid $rcs $f $executable $self] + lappend res $file + set myfmap($rcs) $file + } + return $res + } + + # # ## ### ##### ######## ############# + ## Configuration + + pragma -hastypeinfo no ; # no type introspection + pragma -hasinfo no ; # no object introspection + pragma -hastypemethods no ; # type is not relevant. + + # # ## ### ##### ######## ############# +} + +namespace eval ::vc::fossil::import::cvs { + namespace export project + namespace eval project { + namespace import ::vc::tools::log + namespace import ::vc::fossil::import::cvs::file + namespace import ::vc::fossil::import::cvs::state + # Import not required, already a child namespace. + # namespace import ::vc::fossil::import::cvs::project::sym + # Import not required, already a child namespace. + # namespace import ::vc::fossil::import::cvs::project::rev + } +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide vc::fossil::import::cvs::project 1.0 +return diff --git a/tools/cvs2fossil/lib/c2f_prtopsort.tcl b/tools/cvs2fossil/lib/c2f_prtopsort.tcl new file mode 100644 index 0000000..d001216 --- /dev/null +++ b/tools/cvs2fossil/lib/c2f_prtopsort.tcl @@ -0,0 +1,159 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2007 Andreas Kupries. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## Pass VIII. This pass goes over the set of revision based changesets +## and sorts them topologically. It assumes that there are no cycles +## which could impede it, any having been broken by the previous pass, +## and aborts if that condition doesn't hold. + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.4 ; # Required runtime. +package require snit ; # OO system. +package require struct::list ; # Higher order list operations. +package require vc::tools::log ; # User feedback. +package require vc::fossil::import::cvs::cyclebreaker ; # Breaking dependency cycles. +package require vc::fossil::import::cvs::state ; # State storage. +package require vc::fossil::import::cvs::project::rev ; # Project level changesets + +# # ## ### ##### ######## ############# ##################### +## Register the pass with the management + +vc::fossil::import::cvs::pass define \ + RevTopologicalSort \ + {Topologically Sort Revision ChangeSets} \ + ::vc::fossil::import::cvs::pass::rtopsort + +# # ## ### ##### ######## ############# ##################### +## + +snit::type ::vc::fossil::import::cvs::pass::rtopsort { + # # ## ### ##### ######## ############# + ## Public API + + typemethod setup {} { + # Define the names and structure of the persistent state of + # this pass. + + state use revision + state use symbol + state use changeset + state use csitem + state use cstype + state use cssuccessor + + state extend csorder { + -- Commit order of the revision changesets based on their + -- dependencies + + cid INTEGER NOT NULL REFERENCES changeset, + pos INTEGER NOT NULL, + UNIQUE (cid), + UNIQUE (pos) + } + return + } + + typemethod load {} { + # Pass manager interface. Executed to load data computed by + # this pass into memory when this pass is skipped instead of + # executed. + + state use changeset + project::rev loadcounter + return + } + + typemethod run {} { + # Pass manager interface. Executed to perform the + # functionality of the pass. + + set len [string length [project::rev num]] + set myatfmt %${len}s + incr len 12 + set mycsfmt %${len}s + + cyclebreaker savecmd [myproc SaveOrder] + + state transaction { + cyclebreaker run tsort-rev [myproc Changesets] + } + return + } + + typemethod discard {} { + # Pass manager interface. Executed for all passes after the + # run passes, to remove all data of this pass from the state, + # as being out of date. + + state discard csorder + return + } + + # # ## ### ##### ######## ############# + ## Internal methods + + proc Changesets {} { + log write 2 breakscycle {Selecting the revision changesets} + return [project::rev rev] + } + + proc SaveOrder {graph at cset} { + ::variable myatfmt + ::variable mycsfmt + + set cid [$cset id] + + log write 4 rtopsort "Changeset @ [format $myatfmt $at]: [format $mycsfmt [$cset str]] '[$cset lod]' <<[FormatTR $graph $cset]>>" + state run { + INSERT INTO csorder (cid, pos) + VALUES ($cid, $at) + } + return + } + + proc FormatTR {graph cset} { + return [join [struct::list map [$graph node set $cset timerange] {clock format}] { -- }] + } + + typevariable myatfmt ; # Format for log output to gain better alignment of the various columns. + typevariable mycsfmt ; # Ditto for the changesets. + + # # ## ### ##### ######## ############# + ## Configuration + + pragma -hasinstances no ; # singleton + pragma -hastypeinfo no ; # no introspection + pragma -hastypedestroy no ; # immortal + + # # ## ### ##### ######## ############# +} + +namespace eval ::vc::fossil::import::cvs::pass { + namespace export rtopsort + namespace eval rtopsort { + namespace import ::vc::fossil::import::cvs::cyclebreaker + namespace import ::vc::fossil::import::cvs::state + namespace eval project { + namespace import ::vc::fossil::import::cvs::project::rev + } + namespace import ::vc::tools::log + log register rtopsort + } +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide vc::fossil::import::cvs::pass::rtopsort 1.0 +return diff --git a/tools/cvs2fossil/lib/c2f_psym.tcl b/tools/cvs2fossil/lib/c2f_psym.tcl new file mode 100644 index 0000000..1f8397f --- /dev/null +++ b/tools/cvs2fossil/lib/c2f_psym.tcl @@ -0,0 +1,422 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2007-2008 Andreas Kupries. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## Symbols (Tags, Branches) per project. + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.4 ; # Required runtime. +package require snit ; # OO system. +package require vc::tools::trouble ; # Error reporting. +package require vc::tools::log ; # User feedback. +package require vc::tools::misc ; # Text formatting. +package require vc::fossil::import::cvs::state ; # State storage. +package require struct::set ; # Set handling. + +# # ## ### ##### ######## ############# ##################### +## + +snit::type ::vc::fossil::import::cvs::project::sym { + # # ## ### ##### ######## ############# + ## Public API + + constructor {name id project} { + set myname $name + set myid $id + set myproject $project + + # Count total number of symbols. + incr mynum + return + } + + method name {} { return $myname } + method id {} { return $myid } + + method istrunk {} { return 0 } + + method parent {} { + return [$myproject getsymbol [state run { + SELECT S.name + FROM preferedparent P, symbol S + WHERE P.sid = $myid + AND S.sid = P.pid + }]] + } + + # # ## ### ##### ######## ############# + ## Symbol type + + method determinetype {} { + # This is done by a fixed heuristics, with guidance by the + # user in edge-cases. Contrary to cvs2svn which uses a big + # honking streagy class and rule objects. Keep it simple, we + # can expand later when we actually need all the complexity + # for configurability. + + # The following guidelines are applied: + # - Is usage unambigous ? + # - Was there ever a commit on the symbol ? + # - More used as tag, or more used as branch ? + # - At last, what has the user told us about it ? + # - Fail + + foreach rule { + UserConfig + Unambigous + HasCommits + VoteCounts + } { + set chosen [$self $rule] + if {$chosen eq $myundef} continue + $self MarkAs $rule $chosen + return + } + + # None of the above was able to decide which type to assign to + # the symbol. This is a fatal error preventing the execution + # of the passes after 'CollateSymbols'. + + incr myrulecount(Undecided_) + trouble fatal "Unable to decide how to convert symbol '$myname'" + return + } + + method markthetrunk {} { $self MarkAs IsTheTrunk $mybranch ; return } + + # # ## ### ##### ######## ############# + ## Symbol statistics + + method defcounts {tc bc cc} { + set mybranchcount $tc + set mytagcount $bc + set mycommitcount $cc + return + } + + method countasbranch {} { incr mybranchcount ; return } + method countastag {} { incr mytagcount ; return } + method countacommit {} { incr mycommitcount ; return } + + method blockedby {symbol} { + # Remember the symbol as preventing the removal of this + # symbol. Ot is a tag or branch that spawned from a revision + # on this symbol. + + struct::set include myblockers $symbol + return + } + + method possibleparent {symbol} { + log write 9 symbol "Possible parent ($myname) = [$symbol name]" + + if {[info exists mypparent($symbol)]} { + incr mypparent($symbol) + } else { + set mypparent($symbol) 1 + } + return + } + + method isghost {} { + # Checks if this symbol (as line of development) never + # existed. + + if {$mycommitcount > 0} { return 0 } + if {[llength $myblockers]} { return 0 } + if {[array size mypparent] > 0} { return 0 } + + return 1 + } + + # # ## ### ##### ######## ############# + + method persistrev {} { + set pid [$myproject id] + + state transaction { + state run { + INSERT INTO symbol ( sid, pid, name, type, tag_count, branch_count, commit_count) + VALUES ($myid, $pid, $myname, $myundef, $mytagcount, $mybranchcount, $mycommitcount); + } + foreach symbol $myblockers { + set bid [$symbol id] + state run { + INSERT INTO blocker (sid, bid) + VALUES ($myid, $bid); + } + } + foreach {symbol count} [array get mypparent] { + set pid [$symbol id] + state run { + INSERT INTO parent (sid, pid, n) + VALUES ($myid, $pid, $count); + } + } + } + return + } + + # # ## ### ##### ######## ############# + ## State + + variable myproject {} ; # Reference to the project object + # containing the symbol. + variable myname {} ; # The symbol's name + variable myid {} ; # Repository wide numeric id of the + # symbol. This implicitly encodes the + # project as well. + + variable mybranchcount 0 ; # Count how many uses as branch. + variable mytagcount 0 ; # Count how many uses as tag. + variable mycommitcount 0 ; # Count how many files did a commit on the symbol. + + variable myblockers {} ; # List (Set) of the symbols which block + # the exclusion of this symbol. + + variable mypparent -array {} ; # Maps from symbols to the number + # of files in which it could have + # been a parent of this symbol. + + variable mytype {} ; # The type chosen for the symbol to use in + # the conversion. + + # # ## ### ##### ######## ############# + + typemethod exclude {pattern} { + # Store the pattern in memory for use by the code doing type + # determination. + + lappend myexcludepattern [ProcessPattern $pattern exclusion] + return + } + + typemethod forcetag {pattern} { + # Store the pattern in memory for use by the code doing type + # determination. + + lappend myforcepattern [ProcessPattern $pattern force-tag] $mytag + return + } + + typemethod forcebranch {pattern} { + # Store the pattern in memory for use by the code doing type + # determination. + + lappend myforcepattern [ProcessPattern $pattern force-branch] $mybranch + return + } + + proc ProcessPattern {pattern label} { + if {[string match *:*:* $pattern]} { + # Bad syntax for the pattern, using multiple colons. + + trouble fatal "Bad $label pattern '$pattern'" + } elseif {![string match *:* $pattern]} { + # When only a symbol pattern is specified it applies to + # all projects. + + return [list * $pattern] + } else { + # Both project and symbol patterns are present, we split + # them apart now for storage and easier extraction later. + + return [split $pattern :] + } + } + + typevariable myexcludepattern {} ; # List of patterns specifying + # the symbols to exclude from + # conversion. Tags and/or + # branches. + + typevariable myforcepattern {} ; # List of patterns and types + # specifying which symbols to + # force to specific types. + + typemethod getsymtypes {} { + state foreachrow { + SELECT tid, name FROM symtype; + } { set mysymtype($tid) $name } + return + } + + # Keep the codes below in sync with 'pass::collrev/setup('symtype'). + typevariable myexcluded 0 ; # Code for symbols which are excluded. + typevariable mytag 1 ; # Code for symbols which are tags. + typevariable mybranch 2 ; # Code for symbols which are branches. + typevariable myundef 3 ; # Code for symbols of unknown type. + typevariable mysymtype -array {} ; # Map from type code to label for the log. + + typemethod undef {} { return $myundef } + typemethod excluded {} { return $myexcluded } + typemethod tag {} { return $mytag } + typemethod branch {} { return $mybranch } + + typemethod printrulestatistics {} { + log write 2 symbol "Rule usage statistics:" + + set fmt %[string length $mynum]s + set all 0 + + foreach key [lsort [array names myrulecount]] { + log write 2 symbol "* [format $fmt $myrulecount($key)] $key" + incr all $myrulecount($key) + } + + log write 2 symbol "= [format $fmt $all] total" + return + } + + # Statistics on how often each 'rule' was used to decide on the + # type of a symbol. + typevariable myrulecount -array { + HasCommits 0 + IsTheTrunk 0 + Unambigous 0 + Undecided_ 0 + UserConfig 0 + VoteCounts 0 + } + + typemethod printtypestatistics {} { + log write 2 symbol "Symbol type statistics:" + + set fmt %[string length $mynum]s + set all 0 + + state foreachrow { + SELECT T.name AS stype, + T.plural AS splural, + COUNT (s.sid) AS n + FROM symbol S, symtype T + WHERE S.type = T.tid + GROUP BY T.name + ORDER BY T.name + } { + log write 2 symbol "* [format $fmt $n] [sp $n $stype $splural]" + incr all $n + } + + log write 2 symbol "= [format $fmt $all] total" + return + } + + typevariable mynum 0 + + # # ## ### ##### ######## ############# + ## Internal methods + + method UserConfig {} { + set project [$myproject base] + + # First check if the user requested the exclusion of the + # symbol from conversion. + + foreach ex $myexcludepattern { + struct::list assign $ex pp sp + if {![string match $pp $project]} continue + if {![string match $sp $myname]} continue + return $myexcluded + } + + # If the symbol is not excluded further check if the user + # forces its conversion as a specific type. + + foreach {ex stype} $myforcepattern { + struct::list assign $ex pp sp + if {![string match $pp $project]} continue + if {![string match $sp $myname]} continue + return $stype + } + + # Nothing is forced, have the main system hand the symbol over + # to the regular heuristics. + + return $myundef + } + + method Unambigous {} { + # If a symbol is used unambiguously as a tag/branch, convert + # it as such. + + set istag [expr {$mytagcount > 0}] + set isbranch [expr {$mybranchcount > 0 || $mycommitcount > 0}] + + if {$istag && $isbranch} { return $myundef } + if {$istag} { return $mytag } + if {$isbranch} { return $mybranch } + + # Symbol was not used at all. + return $myundef + } + + method HasCommits {} { + # If there was ever a commit on the symbol, convert it as a + # branch. + + if {$mycommitcount > 0} { return $mybranch } + return $myundef + } + + method VoteCounts {} { + # Convert the symbol based on how often it was used as a + # branch/tag. Whichever happened more often determines how the + # symbol is converted. + + if {$mytagcount > $mybranchcount} { return $mytag } + if {$mytagcount < $mybranchcount} { return $mybranch } + return $myundef + } + + method MarkAs {label chosen} { + log write 3 symbol {\[$label\] Converting symbol '$myname' as $mysymtype($chosen)} + + set mytype $chosen + incr myrulecount($label) + + # This is stored directly into the database. + state run { + UPDATE symbol + SET type = $chosen + WHERE sid = $myid + } + return + } + + # # ## ### ##### ######## ############# + ## Configuration + + pragma -hastypeinfo no ; # no type introspection + pragma -hasinfo no ; # no object introspection + pragma -simpledispatch yes ; # simple fast dispatch + + # # ## ### ##### ######## ############# +} + +namespace eval ::vc::fossil::import::cvs::project { + namespace export sym + namespace eval sym { + namespace import ::vc::fossil::import::cvs::state + namespace import ::vc::tools::misc::* + namespace import ::vc::tools::trouble + namespace import ::vc::tools::log + log register symbol + } +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide vc::fossil::import::cvs::project::sym 1.0 +return diff --git a/tools/cvs2fossil/lib/c2f_ptrunk.tcl b/tools/cvs2fossil/lib/c2f_ptrunk.tcl new file mode 100644 index 0000000..eb9e837 --- /dev/null +++ b/tools/cvs2fossil/lib/c2f_ptrunk.tcl @@ -0,0 +1,89 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2007-2008 Andreas Kupries. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## Trunk, the special main line of development in a project. + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.4 ; # Required runtime. +package require snit ; # OO system. + +# # ## ### ##### ######## ############# ##################### +## + +snit::type ::vc::fossil::import::cvs::project::trunk { + # # ## ### ##### ######## ############# + ## Public API + + constructor {project} { + set mysymbol [$project getsymbol $myname] + set myid [$mysymbol id] + return + } + + destructor { + $mysymbol destroy + } + + method name {} { return $myname } + method id {} { return $myid } + method istrunk {} { return 1 } + method symbol {} { return $self } + method parent {} { return $self } + + method forceid {id} { set myid $id ; return } + + method defcounts {tc bc cc} {} + + method countasbranch {} {} + method countastag {} {} + method countacommit {} {} + + method blockedby {symbol} {} + method possibleparent {symbol} {} + + method isghost {} { return 0 } + + delegate method persistrev to mysymbol + + method determinetype {} { $mysymbol markthetrunk } + + # # ## ### ##### ######## ############# + ## State + + typevariable myname :trunk: ; # Name shared by all trunk symbols. + variable myid {} ; # The trunk's symbol id. + variable mysymbol {} ; # The symbol underneath the trunk. + + # # ## ### ##### ######## ############# + ## Internal methods + + # # ## ### ##### ######## ############# + ## Configuration + + pragma -hastypeinfo no ; # no type introspection + pragma -hasinfo no ; # no object introspection + pragma -hastypemethods no ; # type is not relevant. + + # # ## ### ##### ######## ############# +} + +namespace eval ::vc::fossil::import::cvs::project { + namespace export trunk +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide vc::fossil::import::cvs::project::trunk 1.0 +return diff --git a/tools/cvs2fossil/lib/c2f_repository.tcl b/tools/cvs2fossil/lib/c2f_repository.tcl new file mode 100644 index 0000000..ada5926 --- /dev/null +++ b/tools/cvs2fossil/lib/c2f_repository.tcl @@ -0,0 +1,502 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2007-2008 Andreas Kupries. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## Repository manager. Keeps projects and their files around. + +package provide vc::fossil::import::cvs::repository 1.0 + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.4 ; # Required runtime. +package require snit ; # OO system. +package require vc::tools::trouble ; # Error reporting. +package require vc::tools::log ; # User feedback. +package require vc::tools::misc ; # Text formatting. +package require vc::tools::id ; # Indexing and id generation. +package require vc::fossil::import::cvs::project ; # CVS projects. +package require vc::fossil::import::cvs::state ; # State storage. +package require struct::list ; # List operations. +package require fileutil ; # File operations. + +# # ## ### ##### ######## ############# ##################### +## + +snit::type ::vc::fossil::import::cvs::repository { + # # ## ### ##### ######## ############# + ## Public API + + typemethod base {path} { + # Could be checked, easier to defer to the overall validation. + set mybase $path + return + } + + typemethod add {path} { + # Most things cannot be checked immediately, as the base is + # not known while projects are added. We can and do check for + # uniqueness. We accept multiple occurences of a name, and + # treat them as a single project. + + if {[lsearch -exact $myprojpaths $path] >= 0} return + lappend myprojpaths $path + return + } + + typemethod trunkonly! {} { set mytrunkonly 1 ; return } + typemethod trunkonly {} { return $mytrunkonly } + + typemethod projects {} { + return [TheProjects] + } + + typemethod base? {} { return $mybase } + + typemethod validate {} { + if {![IsRepositoryBase $mybase msg]} { + trouble fatal $msg + # Without a good base directory checking any projects is + # wasted time, so we leave now. + return + } + foreach pp $myprojpaths { + if {![IsProjectBase $mybase/$pp $mybase/CVSROOT msg]} { + trouble fatal $msg + } + } + return + } + + typemethod defauthor {a} { $myauthor put $a } + typemethod defcmessage {cm} { $mycmsg put $cm } + typemethod defsymbol {pid name} { $mysymbol put [list $pid $name] } + typemethod defmeta {pid bid aid cid} { $mymeta put [list $pid $bid $aid $cid] } + + typemethod commitmessageof {mid} { + struct::list assign [$mymeta keyof $mid] pid bid aid cid + return [$mycmsg keyof $cid] + } + + typemethod getmeta {mid} { + struct::list assign [$mymeta keyof $mid] pid bid aid cid + return [list \ + $myprojmap($pid) \ + [$mysymbol keyof $bid] \ + [$myauthor keyof $aid] \ + [$mycmsg keyof $cid]] + } + + # pass I results + typemethod printstatistics {} { + set prlist [TheProjects] + set npr [llength $prlist] + + log write 2 repository "Statistics: Scanned [nsp $npr project]" + + if {$npr > 1} { + set bmax [max [struct::list map $prlist [myproc .BaseLength]]] + incr bmax 2 + set bfmt %-${bmax}s + + set nmax [max [struct::list map $prlist [myproc .NFileLength]]] + set nfmt %${nmax}s + } else { + set bfmt %s + set nfmt %s + } + + set keep {} + foreach p $prlist { + set nfiles [llength [$p filenames]] + set line "Statistics: Project [format $bfmt \"[$p printbase]\"] : [format $nfmt $nfiles] [sp $nfiles file]" + if {$nfiles < 1} { + append line ", dropped" + } else { + lappend keep $p + } + log write 2 repository $line + } + + if {![llength $keep]} { + trouble warn "Dropped all projects" + } elseif {$npr == [llength $keep]} { + log write 2 repository "Keeping all projects" + } else { + log write 2 repository "Keeping [nsp [llength $keep] project]" + trouble warn "Dropped [nsp [expr {$npr - [llength $keep]}] {empty project}]" + } + + # Keep reduced set of projects. + set projects $keep + return + } + + # pass I persistence + typemethod persist {} { + ::variable myprojmap + state transaction { + foreach p [TheProjects] { + $p persist + set myprojmap([$p id]) $p + } + } + return + } + + typemethod load {} { + state transaction { + state foreachrow { + SELECT pid, name FROM project ; + } { + set project [project %AUTO% $name $type] + + lappend myprojpaths $name + lappend myprojects $project + set myprojmap($pid) $project + $project setid $pid + } + state foreachrow { + SELECT fid, pid, name, visible, exec FROM file ; + } { + $myprojmap($pid) addfile $name $visible $exec $fid + } + } + return + } + + # pass II results + typemethod printrevstatistics {} { + log write 2 repository "Revision statistics" + # number of revisions, symbols, repository wide, and per project ... + + set rcount [state one { SELECT COUNT (*) FROM revision }] + set tcount [state one { SELECT COUNT (*) FROM tag }] + set bcount [state one { SELECT COUNT (*) FROM branch }] + set scount [state one { SELECT COUNT (*) FROM symbol }] + set acount [state one { SELECT COUNT (*) FROM author }] + set ccount [state one { SELECT COUNT (*) FROM cmessage }] + set fmt %[string length [max [list $rcount $tcount $bcount $scount $acount $ccount]]]s + + log write 2 repository "Statistics: [format $fmt $rcount] [sp $rcount revision]" + log write 2 repository "Statistics: [format $fmt $tcount] [sp $tcount tag]" + log write 2 repository "Statistics: [format $fmt $bcount] [sp $bcount branch branches]" + log write 2 repository "Statistics: [format $fmt $scount] [sp $scount symbol]" + log write 2 repository "Statistics: [format $fmt $acount] [sp $acount author]" + log write 2 repository "Statistics: [format $fmt $ccount] [sp $ccount {log message}]" + + set prlist [TheProjects] + set npr [llength $prlist] + + if {$npr > 1} { + set bmax [max [struct::list map $prlist [myproc .BaseLength]]] + incr bmax 2 + set bfmt %-${bmax}s + } else { + set bfmt %s + } + + foreach p $prlist { + set pid [$p id] + set prefix "Project [format $bfmt \"[$p printbase]\"]" + regsub -all {[^ ]} $prefix { } blanks + set sep " : " + + set rcount [state one { SELECT COUNT (*) FROM revision R, file F WHERE R.fid = F.fid AND F.pid = $pid }] + set tcount [state one { SELECT COUNT (*) FROM tag T, file F WHERE T.fid = F.fid AND F.pid = $pid }] + set bcount [state one { SELECT COUNT (*) FROM branch B, file F WHERE B.fid = F.fid AND F.pid = $pid }] + set scount [state one { SELECT COUNT (*) FROM symbol WHERE pid = $pid }] + set acount [state one { SELECT COUNT (*) FROM author WHERE aid IN (SELECT DISTINCT aid FROM meta WHERE pid = $pid) }] + set ccount [state one { SELECT COUNT (*) FROM cmessage WHERE cid IN (SELECT DISTINCT cid FROM meta WHERE pid = $pid) }] + + log write 2 repository "Statistics: $prefix$sep[format $fmt $rcount] [sp $rcount revision]" + log write 2 repository "Statistics: $blanks$sep[format $fmt $tcount] [sp $tcount tag]" + log write 2 repository "Statistics: $blanks$sep[format $fmt $bcount] [sp $bcount branch branches]" + log write 2 repository "Statistics: $blanks$sep[format $fmt $scount] [sp $scount symbol]" + log write 2 repository "Statistics: $blanks$sep[format $fmt $acount] [sp $acount author]" + log write 2 repository "Statistics: $blanks$sep[format $fmt $ccount] [sp $ccount {log message}]" + } + return + } + + # pass II persistence + typemethod persistrev {} { + state transaction { + SaveAuthors + SaveCommitMessages + # TODO: Save symbols of all projects (before the revisions + # in the projects, as they are referenced by the meta + # tuples) + SaveMeta + foreach p [TheProjects] { $p persistrev } + } + return + } + + typemethod loadsymbols {} { + state transaction { + # We load the symbol ids at large to have the mapping + # right from the beginning. + + state foreachrow { + SELECT sid, pid, name, tag_count AS tc, branch_count AS bc, commit_count AS cc + FROM symbol + } { + $mysymbol map $sid [list $pid $name] + set project $myprojmap($pid) + + set force [$project hassymbol $name] + set symbol [$project getsymbol $name] + + # Forcing happens only for the trunks. + if {$force} { $symbol forceid $sid } + + # Set the loaded counts. + $symbol defcounts $tc $bc $cc + + # Note: The type is neither retrieved nor set, for + # this is used to load the pass II data, which means + # that everything is 'undefined' at this point anyway. + + # future: $symbol load (blockers, and parents) + } + + # Beyond the symbols we also load the author, commit log, + # and meta information. + + state foreachrow { + SELECT aid, name AS aname FROM author + } { + $myauthor map $aid $aname + } + state foreachrow { + SELECT cid, text FROM cmessage + } { + $mycmsg map $cid $text + } + state foreachrow { + SELECT mid, pid, bid, aid, cid FROM meta + } { + $mymeta map $mid [list $pid $bid $aid $cid] + } + } + return + } + + typemethod determinesymboltypes {} { + foreach project [TheProjects] { + $project determinesymboltypes + } + return + } + + typemethod projectof {pid} { + return $myprojmap($pid) + } + + + # pass IV+ results + typemethod printcsetstatistics {} { + log write 2 repository "Changeset statistics" + # number of revisions, symbols, repository wide, and per project ... + + set ccount [state one { SELECT COUNT (*) FROM changeset }] + set rcount [state one { SELECT COUNT (*) FROM changeset WHERE type = 0 }] + set tcount [state one { SELECT COUNT (*) FROM changeset WHERE type = 1 }] + set bcount [state one { SELECT COUNT (*) FROM changeset WHERE type = 2 }] + set fmt %[string length [max [list $ccount $rcount $tcount $bcount]]]s + + log write 2 repository "Statistics: [format $fmt $ccount] [sp $ccount changeset]" + log write 2 repository "Statistics: [format $fmt $rcount] [sp $rcount {revision changeset}]" + log write 2 repository "Statistics: [format $fmt $tcount] [sp $tcount {tag symbol changeset}]" + log write 2 repository "Statistics: [format $fmt $bcount] [sp $bcount {branch symbol changeset}]" + + set prlist [TheProjects] + set npr [llength $prlist] + + if {$npr > 1} { + set bmax [max [struct::list map $prlist [myproc .BaseLength]]] + incr bmax 2 + set bfmt %-${bmax}s + } else { + set bfmt %s + } + + foreach p $prlist { + set pid [$p id] + set prefix "Project [format $bfmt \"[$p printbase]\"]" + regsub -all {[^ ]} $prefix { } blanks + set sep " : " + + set ccount [state one { SELECT COUNT (*) FROM changeset WHERE pid = $pid }] + set rcount [state one { SELECT COUNT (*) FROM changeset WHERE pid = $pid AND type = 0 }] + set tcount [state one { SELECT COUNT (*) FROM changeset WHERE pid = $pid AND type = 1 }] + set bcount [state one { SELECT COUNT (*) FROM changeset WHERE pid = $pid AND type = 2 }] + + log write 2 repository "Statistics: $prefix$sep[format $fmt $ccount] [sp $ccount changeset]" + log write 2 repository "Statistics: $blanks$sep[format $fmt $rcount] [sp $rcount {revision changeset}]" + log write 2 repository "Statistics: $blanks$sep[format $fmt $tcount] [sp $tcount {tag symbol changeset}]" + log write 2 repository "Statistics: $blanks$sep[format $fmt $bcount] [sp $bcount {branch symbol changeset}]" + } + return + } + + # # ## ### ##### ######## ############# + ## State + + typevariable mybase {} ; # Base path to CVS repository. + typevariable myprojpaths {} ; # List of paths to all declared + # projects, relative to mybase. + typevariable myprojects {} ; # List of objects for all + # declared projects. + typevariable myprojmap -array {} ; # Map from project ids to their + # objects. + typevariable myauthor {} ; # Names of all authors found, + # maps to their ids. + typevariable mycmsg {} ; # All commit messages found, + # maps to their ids. + typevariable mymeta {} ; # Maps all meta data tuples + # (project, branch, author, + # cmessage) to their ids. + typevariable mysymbol {} ; # Map symbols identified by + # project and name to their + # id. This information is not + # saved directly. + typevariable mytrunkonly 0 ; # Boolean flag. Set by option + # processing when the user + # requested a trunk-only import + + # # ## ### ##### ######## ############# + ## Internal methods + + typeconstructor { + set myauthor [vc::tools::id %AUTO%] + set mycmsg [vc::tools::id %AUTO%] + set mymeta [vc::tools::id %AUTO%] + set mysymbol [vc::tools::id %AUTO%] + return + } + + proc .BaseLength {p} { + return [string length [$p printbase]] + } + + proc .NFileLength {p} { + return [string length [llength [$p filenames]]] + } + + proc IsRepositoryBase {path mv} { + ::variable mybase + upvar 1 $mv msg + if {![fileutil::test $mybase edr msg {CVS Repository}]} {return 0} + if {![fileutil::test $mybase/CVSROOT edr msg {CVS Admin Directory}]} {return 0} + return 1 + } + + proc IsProjectBase {path admin mv} { + upvar 1 $mv msg + if {![fileutil::test $path edr msg Project]} {return 0} + if { + ($path eq $admin) || + [string match $admin/* $path] + } { + set msg "Administrative subdirectory $path cannot be a project" + return 0 + } + return 1 + } + + proc TheProjects {} { + upvar 1 type type + ::variable myprojects + ::variable myprojpaths + + if {![llength $myprojects]} { + set myprojects [EmptyProjects $myprojpaths] + } + return $myprojects + } + + proc EmptyProjects {projpaths} { + ::variable mybase + upvar 1 type type + set res {} + if {[llength $projpaths]} { + foreach pp $projpaths { + lappend res [project %AUTO% $pp $type] + } + } else { + # Base is the single project. + lappend res [project %AUTO% "" $type] + } + return $res + } + + proc SaveAuthors {} { + ::variable myauthor + foreach {name aid} [$myauthor get] { + state run { + INSERT INTO author ( aid, name) + VALUES ($aid, $name); + } + } + return + } + + proc SaveCommitMessages {} { + ::variable mycmsg + foreach {text cid} [$mycmsg get] { + state run { + INSERT INTO cmessage ( cid, text) + VALUES ($cid, $text); + } + } + return + } + + proc SaveMeta {} { + ::variable mymeta + foreach {key mid} [$mymeta get] { + struct::list assign $key pid bid aid cid + state run { + INSERT INTO meta ( mid, pid, bid, aid, cid) + VALUES ($mid, $pid, $bid, $aid, $cid); + } + } + return + } + + # # ## ### ##### ######## ############# + ## Configuration + + pragma -hasinstances no ; # singleton + pragma -hastypeinfo no ; # no introspection + pragma -hastypedestroy no ; # immortal + + # # ## ### ##### ######## ############# +} + +namespace eval ::vc::fossil::import::cvs { + namespace export repository + namespace eval repository { + namespace import ::vc::fossil::import::cvs::project + namespace import ::vc::fossil::import::cvs::state + namespace import ::vc::tools::misc::* + namespace import ::vc::tools::id + namespace import ::vc::tools::trouble + namespace import ::vc::tools::log + log register repository + } +} + +# # ## ### ##### ######## ############# ##################### +## Ready +return diff --git a/tools/cvs2fossil/lib/c2f_ristate.tcl b/tools/cvs2fossil/lib/c2f_ristate.tcl new file mode 100644 index 0000000..39defd8 --- /dev/null +++ b/tools/cvs2fossil/lib/c2f_ristate.tcl @@ -0,0 +1,113 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2008 Andreas Kupries. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## Track the state of revision import. Essentially maps lines of +## developments to their workspace state. + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.4 ; # Required runtime. +package require snit ; # OO system. +package require struct::list ; # List assignment +package require vc::fossil::import::cvs::wsstate ; # Workspace state +package require vc::fossil::import::cvs::integrity ; # State integrity checks. +package require vc::tools::log ; # User feedback. +package require vc::tools::trouble ; # Error reporting. + +# # ## ### ##### ######## ############# ##################### +## + +snit::type ::vc::fossil::import::cvs::ristate { + # # ## ### ##### ######## ############# + ## Public API + + constructor {} { + # Start with an empty state + return + } + + method new {lod {parentlod {}}} { + # Create a workspace for a line of development (LOD). If a + # parent LOD is specified let the new workspace inherit the + # current state of the parent. + + log write 8 ristate {Open workspace for LOD "$lod"} + + integrity assert { + ![info exists mystate($lod)] + } {Trying to override existing state for lod "$lod"} + + set wss [wsstate ${selfns}::%AUTO% $lod] + set mystate($lod) $wss + + if {$parentlod ne ""} { + log write 8 ristate {Inheriting from workspace for LOD "$parentlod"} + + integrity assert { + [info exists mystate($parentlod)] + } {Trying to inherit from undefined lod "$parentlod"} + + set pwss $mystate($parentlod) + + $wss defstate [$pwss getstate] + $wss defid [$pwss getid] + $wss defparent $pwss + } + + return $wss + } + + method get {lod} { return $mystate($lod) } + method has {lod} { return [info exists mystate($lod)] } + + method names {} { return [array names mystate] } + + method dup {dst _from_ src} { + log write 8 ristate {Duplicate workspace for LOD "$dst" from "$src"} + set mystate($dst) $mystate($src) + return + } + + # # ## ### ##### ######## ############# + ## State + + variable mystate -array {} ; # Map from lines of development + # (identified by name) to their + # workspace. + + # # ## ### ##### ######## ############# + ## Configuration + + pragma -hastypeinfo no ; # no type introspection + pragma -hasinfo no ; # no object introspection + pragma -hastypemethods no ; # type is not relevant. + + # # ## ### ##### ######## ############# +} + +namespace eval ::vc::fossil::import::cvs { + namespace export ristate + namespace eval ristate { + namespace import ::vc::fossil::import::cvs::wsstate + namespace import ::vc::fossil::import::cvs::integrity + namespace import ::vc::tools::trouble + namespace import ::vc::tools::log + log register ristate + } +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide vc::fossil::import::cvs::ristate 1.0 +return diff --git a/tools/cvs2fossil/lib/c2f_state.tcl b/tools/cvs2fossil/lib/c2f_state.tcl new file mode 100644 index 0000000..6be8d97 --- /dev/null +++ b/tools/cvs2fossil/lib/c2f_state.tcl @@ -0,0 +1,231 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2007 Andreas Kupries. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## State manager. Maintains the sqlite database used by all the other +## parts of the system, especially the passes and their support code, +## to persist and restore their state across invokations. + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.4 ; # Required runtime. +package require snit ; # OO system. +package require fileutil ; # File operations. +package require sqlite3 ; # Database access. +package require vc::tools::trouble ; # Error reporting. +package require vc::tools::log ; # User feedback. + +# # ## ### ##### ######## ############# ##################### +## + +snit::type ::vc::fossil::import::cvs::state { + # # ## ### ##### ######## ############# + ## Public API + + typemethod usedb {path} { + # Immediate validation. There are are two possibilities to + # consider. The path exists or it doesn't. + + # In the first case it has to be a readable and writable file, + # and it has to be a proper sqlite database. Further checks + # regarding the required tables will be done later, by the + # passes, during their setup. + + # In the second case we have to be able to create the file, + # and check that. This is done by opening it, sqlite will then + # try to create it, and may fail. + + if {[::file exists $path]} { + if {![fileutil::test $path frw msg {cvs2fossil state}]} { + trouble fatal $msg + return + } + } + + if {[catch { + sqlite3 ${type}::TEMP $path + ${type}::TEMP eval {PRAGMA synchronous=OFF;} + } res]} { + trouble fatal $res + return + } + + # A previously defined state database is closed before + # committing to the new definition. We do not store the path + # itself, this ensures that the file is _not_ cleaned up after + # a run. + + set mystate ${type}::STATE + set mypath {} + + catch { $mystate close } + rename ${type}::TEMP $mystate + + log write 2 state "is $path" + return + } + + typemethod setup {} { + # If, and only if no state database was defined by the user + # then it is now the time to create our own using a tempfile. + + if {$mystate ne ""} return + + set mypath [fileutil::tempfile cvs2fossil_state_] + set mystate ${type}::STATE + sqlite3 $mystate $mypath + $mystate eval {PRAGMA synchronous=OFF;} + + log write 2 state "using $mypath" + return + } + + typemethod release {} { + log write 2 state release + ${type}::STATE close + if {$mypath eq ""} return + ::file delete $mypath + return + } + + # Declare a table needed for the storing of persistent state, and + # its structure. A possibly previously existing definition is + # dropped. To be used when a table is needed and not assumed to + # exist from previous passes. + + typemethod extend {name definition {indices {}}} { + log write 5 state "extend $name" + Save "extend $name ================================" + + $mystate transaction { + catch { $mystate eval "DROP TABLE $name" } + $mystate eval "CREATE TABLE $name ( $definition )" + + set id 0 + foreach columns $indices { + log write 5 state "index $name$id" + + $mystate eval "CREATE INDEX ${name}$id ON ${name} ( [join $columns ,] )" + incr id + } + } + return + } + + # Declare that a table is needed for reading from and/or storing + # to persistent state, and is assumed to already exist. A missing + # table is an internal error causing an immediate exit. + + typemethod use {name} { + log write 5 state "use $name" + Save "use $name ===================================" + + set found [llength [$mystate eval { + SELECT name + FROM sqlite_master + WHERE type = 'table' + AND name = $name + ; + }]] + + # No assert, would cause cycle in package dependencies + if {$found} return + trouble internal "The required table \"$name\" is not defined." + # Not reached + return + } + + typemethod discard {name} { + # Method for a user to remove outdated information from the + # persistent state, table by table. + + log write 5 state "discard $name" + + $mystate transaction { + catch { $mystate eval "DROP TABLE $name" } + } + return + } + + typemethod run {args} { + Save $args + return [uplevel 1 [linsert $args 0 $mystate eval]] + } + + typemethod foreachrow {sql script} { + Save $sql + uplevel 1 [list $mystate eval $sql $script] + return + } + + typemethod one {args} { + Save $args + return [uplevel 1 [linsert $args 0 $mystate onecolumn]] + } + + typemethod transaction {script} { + return [uplevel 1 [list $mystate transaction $script]] + } + + typemethod id {} { + return [$mystate last_insert_rowid] + } + + typemethod savequeriesto {path} { + set mysavepath $path + return + } + + # # ## ### ##### ######## ############# + + proc Save {text} { + ::variable mysavepath + if {$mysavepath eq ""} return + fileutil::appendToFile $mysavepath $text\n\n + return + } + + # # ## ### ##### ######## ############# + ## State + + typevariable mystate {} ; # Sqlite database (command) holding the converter state. + typevariable mypath {} ; # Path to the database, for cleanup of a temp database. + typevariable mysavepath {} ; # Path where to save queries for introspection. + + # # ## ### ##### ######## ############# + ## Internal methods + + + # # ## ### ##### ######## ############# + ## Configuration + + pragma -hasinstances no ; # singleton + pragma -hastypeinfo no ; # no introspection + pragma -hastypedestroy no ; # immortal + + # # ## ### ##### ######## ############# +} + +namespace eval ::vc::fossil::import::cvs { + namespace export state + namespace eval state { + namespace import ::vc::tools::trouble + namespace import ::vc::tools::log + log register state + } +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide vc::fossil::import::cvs::state 1.0 +return diff --git a/tools/cvs2fossil/lib/c2f_wsstate.tcl b/tools/cvs2fossil/lib/c2f_wsstate.tcl new file mode 100644 index 0000000..502d479 --- /dev/null +++ b/tools/cvs2fossil/lib/c2f_wsstate.tcl @@ -0,0 +1,136 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2008 Andreas Kupries. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## Track the state of a cvs workspace as changesets are committed to +## it. Nothing actually happens in the filesystem, this is completely +## virtual. + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.4 ; # Required runtime. +package require snit ; # OO system. +package require struct::list ; # List assignment +package require vc::tools::log ; # User feedback. + +# # ## ### ##### ######## ############# ##################### +## + +snit::type ::vc::fossil::import::cvs::wsstate { + # # ## ### ##### ######## ############# + ## Public API + + constructor {lod} { + # Start with an empty state + set myname $lod + set myticks 0 + set myparent {} + return + } + + method name {} { return $myname } + method ticks {} { return $myticks } + + method add {oprevisioninfo} { + # oprevisioninfo = list (rid path label op ...) /quadruples + + # Overwrite all changed files (identified by path) with the + # new revisions. This keeps all unchanged files. Files marked + # as dead are removed. + + foreach {rid path label rop} $oprevisioninfo { + log write 5 wss {$myop($rop) $label} + + if {$rop < 0} { + if {[catch { + unset mystate($path) + }]} { + log write 0 wss "Removed path \"$path\" is not known to the workspace" + } + } else { + set mystate($path) [list $rid $label] + } + } + + incr myticks + return + } + + method get {} { + set res {} + foreach path [lsort -dict [array names mystate]] { + struct::list assign $mystate($path) rid label + lappend res $rid $path $label + } + return $res + } + + method defid {id} { + set myid $id + return + } + + method getid {} { return $myid } + + method defstate {s} { array set mystate $s ; return } + method getstate {} { return [array get mystate] } + + method parent {} { return $myparent } + method defparent {parent} { + set myparent $parent + return + } + + # # ## ### ##### ######## ############# + ## State + + variable myname {} ; # Name of the LOD the workspace is + # for. + variable myid {} ; # Record id of the fossil manifest + # associated with the current state. + variable mystate -array {} ; # Map from paths to the recordid of + # the file revision behind it, and + # the associated label for logging. + variable myticks 0 ; # Number of 'add' operations + # performed on the state. + variable myparent {} ; # Reference to the parent workspace. + + typevariable myop -array { + -1 REM + 0 --- + 1 ADD + 2 CHG + } + + # # ## ### ##### ######## ############# + ## Configuration + + pragma -hastypeinfo no ; # no type introspection + pragma -hasinfo no ; # no object introspection + pragma -hastypemethods no ; # type is not relevant. + + # # ## ### ##### ######## ############# +} + +namespace eval ::vc::fossil::import::cvs { + namespace export wsstate + namespace eval wsstate { + namespace import ::vc::tools::log + log register wss + } +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide vc::fossil::import::cvs::wsstate 1.0 +return diff --git a/tools/cvs2fossil/lib/cvs2fossil.tcl b/tools/cvs2fossil/lib/cvs2fossil.tcl new file mode 100644 index 0000000..7bca492 --- /dev/null +++ b/tools/cvs2fossil/lib/cvs2fossil.tcl @@ -0,0 +1,89 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2007 Andreas Kupries. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## Main package of the cvs conversion/import facility. Loads the +## required pieces and controls their interaction. + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.4 ; # Required runtime. +package require snit ; # OO system + +# # ## ### ##### ######## ############# ##################### +## Passes. The order in which the various passes are loaded is +## important. It is the same order in which they will +## register, and then be run in. + +package require vc::fossil::import::cvs::pass::collar ; # Coll'ect Ar'chives. +package require vc::fossil::import::cvs::pass::collrev ; # Coll'ect Rev'isions. +package require vc::fossil::import::cvs::pass::collsym ; # Coll'ate Sym'bols +package require vc::fossil::import::cvs::pass::filtersym ; # Filter' Sym'bols + +# Note: cvs2svn's SortRevisionSummaryPass and SortSymbolSummaryPass +# are not implemented by us. They are irrelevant due to our use +# of a relational database proper for the persistent state, +# allowing us to sort the data on the fly as we need it. + +package require vc::fossil::import::cvs::pass::initcsets ; # Init'ialize C'hange'Sets +package require vc::fossil::import::cvs::pass::csetdeps ; # C'hange'Set Dep'endencies +package require vc::fossil::import::cvs::pass::breakrcycle ; # Break' R'evision Cycle's +package require vc::fossil::import::cvs::pass::rtopsort ; # R'evision Top'ological Sort' +package require vc::fossil::import::cvs::pass::breakscycle ; # Break' S'ymbol Cycle's +package require vc::fossil::import::cvs::pass::breakacycle ; # Break' A'll Cycle's +package require vc::fossil::import::cvs::pass::atopsort ; # A'll Top'ological Sort' +package require vc::fossil::import::cvs::pass::importfiles ; # Import' Files +package require vc::fossil::import::cvs::pass::importcsets ; # Import' Changesets +package require vc::fossil::import::cvs::pass::importfinal ; # Import' Finalization + +# # ## ### ##### ######## ############# ##################### +## Support for passes etc. + +package require vc::fossil::import::cvs::option ; # Cmd line parsing & database +package require vc::fossil::import::cvs::pass ; # Pass management +package require vc::tools::log ; # User feedback + +# # ## ### ##### ######## ############# ##################### +## + +snit::type ::vc::fossil::import::cvs { + # # ## ### ##### ######## ############# + ## Public API, Methods + + typemethod run {arguments} { + # Run a series of passes over the cvs repository to extract, + # filter, and order its historical information. Which passes + # are actually run is determined through the specified options + # and their defaults. + + option process $arguments + pass run + + vc::tools::log write 0 cvs2fossil Done + return + } + + # # ## ### ##### ######## ############# + ## Configuration + + pragma -hasinstances no ; # singleton + pragma -hastypeinfo no ; # no introspection + pragma -hastypedestroy no ; # immortal + + # # ## ### ##### ######## ############# +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide vc::fossil::import::cvs 1.0 +return diff --git a/tools/cvs2fossil/lib/dot.tcl b/tools/cvs2fossil/lib/dot.tcl new file mode 100644 index 0000000..0081c08 --- /dev/null +++ b/tools/cvs2fossil/lib/dot.tcl @@ -0,0 +1,108 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2007 Andreas Kupries. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## Utility package, export graph data to dot format for formatting +## with neato et. all + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.4 ; # Required runtime +package require snit ; # OO system. +package require fileutil ; # Helper commands. + +# # ## ### ##### ######## ############# ##################### +## + +snit::type ::vc::tools::dot { + # # ## ### ##### ######## ############# + ## Public API, Methods + + typemethod format {g name {subgraph {}}} { + lappend lines "digraph \"$name\" \{" + + if {![llength $subgraph]} { + set nodes [$g nodes] + set arcs [$g arcs] + } else { + set nodes $subgraph + set arcs [eval [linsert $subgraph 0 $g arcs -inner]] + } + + foreach n $nodes { + set style [Style $g node $n {label label shape shape fontcolor fontcolor}] + lappend lines "\"$n\" ${style};" + } + foreach a $arcs { + set style [Style $g arc $a {color color}] + lappend lines "\"[$g arc source $a]\" -> \"[$g arc target $a]\" ${style};" + } + + lappend lines "\}" + return [join $lines \n] + } + + typemethod write {g name file {subgraph {}}} { + fileutil::writeFile $file [$type format $g $name $subgraph] + return + } + + typemethod layout {format g name file} { + set f [fileutil::tempfile c2fdot_] + $type write $g $name $f + exec dot -T $format -o $file $f + ::file delete $f + return + } + + # # ## ### ##### ######## ############# + ## Internal, state + + proc Style {graph x y dict} { + set sep " " + set head " \[" + set tail "" + set style "" + foreach {gattr key} $dict { + if {![$graph $x keyexists $y $key]} continue + append style "$head$sep${gattr}=\"[$graph $x get $y $key]\"" + set sep ", " + set head "" + set tail " \]" + } + + append style ${tail} + return $style + } + + # # ## ### ##### ######## ############# + ## Internal, helper methods (formatting, dispatch) + + # # ## ### ##### ######## ############# + ## Configuration + + pragma -hasinstances no ; # singleton + pragma -hastypeinfo no ; # no introspection + pragma -hastypedestroy no ; # immortal + + # # ## ### ##### ######## ############# +} + +namespace eval ::vc::tools { + namespace export dot +} + +# ----------------------------------------------------------------------------- +# Ready + +package provide vc::tools::dot 1.0 +return diff --git a/tools/cvs2fossil/lib/id.tcl b/tools/cvs2fossil/lib/id.tcl new file mode 100644 index 0000000..331f9a6 --- /dev/null +++ b/tools/cvs2fossil/lib/id.tcl @@ -0,0 +1,64 @@ +# # ## ### ##### ######## ############# + +## A simple class for handling an in-memory index mapping from +## arbitrary strings to a small numeric id. Can be queried in reverse +## too, returning the string for the id. + +## Id's are starting from 1. + +# # ## ### ##### ######## ############# +## Requirements. + +package require Tcl ; # Runtime. +package require snit ; # OO runtime. + +# # ## ### ##### ######## ############# +## Implementation. + +snit::type ::vc::tools::id { + # # ## ### ##### ######## ############# + + constructor {} {} + + # # ## ### ##### ######## ############# + ## Public API. + ## - Put data into the index, incl. query for id of key. + ## - Lookup data for id. + + method put {key} { + if {[info exists mydata($key)]} { return $mydata($key) } + incr mycounter + + set mydata($key) $mycounter + set myinvert($mycounter) $key + + return $mycounter + } + + # Explicitly load the database with a mapping. + method map {id key} { + set mydata($key) $id + set myinvert($id) $key + } + + method keyof {id} { return $myinvert($id) } + method get {} { return [array get mydata] } + + # # ## ### ##### ######## ############# + ## Internal. State. + + variable mydata -array {} ; # Map data -> id + variable myinvert -array {} ; # Map id -> data + variable mycounter 0 ; # Counter for id generation. + + # # ## ### ##### ######## ############# +} + +namespace eval ::vc::tools { + namespace export id +} + +# # ## ### ##### ######## ############# +## Ready. + +package provide vc::tools::id 1.0 diff --git a/tools/cvs2fossil/lib/log.tcl b/tools/cvs2fossil/lib/log.tcl new file mode 100644 index 0000000..4eef620 --- /dev/null +++ b/tools/cvs2fossil/lib/log.tcl @@ -0,0 +1,184 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2007-2008 Andreas Kupries. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## Utility package, basic user feedback + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.4 ; # Required runtime +package require snit ; # OO system. +package require vc::tools::mem ; # Memory tracking. + +# # ## ### ##### ######## ############# ##################### +## + +snit::type ::vc::tools::log { + # # ## ### ##### ######## ############# + ## Public API, Methods + + # Write the message 'text' to log, for the named 'system'. The + # message is written if and only if the message verbosity is less + # or equal the chosen verbosity. A message of verbosity 0 cannot + # be blocked. + + typemethod write {verbosity system text} { + if {$verbosity > $myloglevel} return + uplevel #0 [linsert $mylogcmd end write [System $system] \ + [uplevel 1 [list ::subst $text]]] + return + } + + # Similar to write, especially in the handling of the verbosity, + # to drive progress displays. It signals that for some long + # running operation we are at tick 'n' of at most 'max' ticks. An + # empty 'max' indicates an infinite progress display. + + typemethod progress {verbosity system n max} { + if {!$myprogress} return + if {$verbosity > $myloglevel} return + uplevel #0 [linsert $mylogcmd end progress [System $system] $n $max] + return + } + + typemethod visible? {verbosity} { + return [expr {$verbosity <= $myloglevel}] + } + + # # ## ### ##### ######## ############# + # Public API, Administrative methods + + # Set verbosity to the chosen 'level'. Only messages with a level + # less or equal to this one will be shown. + + typemethod verbosity {level} { + if {$level < 1} {set level 0} + set myloglevel $level + return + } + + typemethod verbose {} { + incr myloglevel + return + } + + typemethod noprogress {} { + set myprogress 0 + return + } + + typemethod quiet {} { + if {$myloglevel < 1} return + incr myloglevel -1 + return + } + + # Query the currently set verbosity. + + typemethod verbosity? {} { + return $myloglevel + } + + # Set the log callback handling the actual output of messages going + # through the package. + + typemethod command {cmdprefix} { + variable mylogcmd $cmdprefix + return + } + + # Register a system name, to enable tabular formatting. This is + # done by setting up a format specifier with a proper width. This + # is handled in the generation command, before the output callback + # is invoked. + + typemethod register {name} { + set nlen [string length $name] + if {$nlen < $mysyslen} return + set mysyslen $nlen + set mysysfmt %-${mysyslen}s + return + } + + # # ## ### ##### ######## ############# + ## Internal, state + + typevariable myloglevel 2 ; # Some verbosity, not too much + typevariable mylogcmd ::vc::tools::log::OUT ; # Standard output to stdout. + typevariable mysysfmt %s ; # Non-tabular formatting. + typevariable mysyslen 0 ; # Ditto. + typevariable myprogress 1 ; # Progress output is standard. + + # # ## ### ##### ######## ############# + ## Internal, helper methods (formatting, dispatch) + + proc System {s} { + ::variable mysysfmt + return [format $mysysfmt $s] + } + + # # ## ### ##### ######## ############# + ## Standard output callback, module internal + + # Dispatch to the handlers of the possible operations. + + proc OUT {op args} { + eval [linsert $args 0 ::vc::tools::log::OUT/$op] + return + } + + # Write handler. Each message is a line. + + proc OUT/write {system text} { + set m [mlog] + regsub -all {[^ ]} $m { } b + puts "$m$system [join [split $text \n] "\n$b$system "]" + mlimit + return + } + + # Progress handler. Uses \r to return to the beginning of the + # current line without advancing. + + proc OUT/progress {system n max} { + if {$max eq {}} { + puts -nonewline "$system $n\r" + } else { + puts -nonewline "$system [format %[string length $max]s $n]/$max\r" + } + flush stdout + return + } + + # # ## ### ##### ######## ############# + ## Configuration + + pragma -hasinstances no ; # singleton + pragma -hastypeinfo no ; # no introspection + pragma -hastypedestroy no ; # immortal + + # # ## ### ##### ######## ############# +} + +namespace eval ::vc::tools { + namespace export log + namespace eval log { + namespace import ::vc::tools::mem::mlog + namespace import ::vc::tools::mem::mlimit + } +} + +# ----------------------------------------------------------------------------- +# Ready + +package provide vc::tools::log 1.0 +return diff --git a/tools/cvs2fossil/lib/mem.tcl b/tools/cvs2fossil/lib/mem.tcl new file mode 100644 index 0000000..dae4d18 --- /dev/null +++ b/tools/cvs2fossil/lib/mem.tcl @@ -0,0 +1,139 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2008 Andreas Kupries. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## Utilities for memory tracking + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.4 ; # Required runtime +package require struct::list ; # List assignment + +# # ## ### ##### ######## ############# ##################### +## + +namespace eval ::vc::tools::mem { + # # ## ### ##### ######## ############# + ## Public API, Methods + + if {[llength [info commands memory]]} { + proc minfo {} { + # memory info reduced to the set of relevant numbers in the output + struct::list assign [split [memory info] \n] tm tf cpa cba mpa mba + struct::list assign $tm _ _ tm + struct::list assign $tf _ _ tf + struct::list assign $cpa _ _ _ cpa + struct::list assign $cba _ _ _ cba + struct::list assign $mpa _ _ _ mpa + struct::list assign $mba _ _ _ mba + return [list $tm $tf $cpa $cba $mpa $mba] + } + } else { + proc minfo {} {return {0 0 0 0 0 0}} + } + + proc mlog {} { + variable track ; if {!$track} { return {} } + + variable lcba + variable lmba + variable mid + + struct::list assign [minfo] _ _ _ cba _ mba + + set dc [expr $cba - $lcba] ; set lcba $cba + set dm [expr $mba - $lmba] ; set lmba $mba + + # projection: 1 2 3 4 5 6 7 6 8 10 + return "[F [incr mid]] | [F $cba] | [F $dc] | [F $mba] | [F $dm] |=| " + } + + proc mark {} { + variable track ; if {!$track} return + variable mid + variable lcba + variable lmark + set dm [expr {$lcba - $lmark}] + puts "[F $mid] | [F $lcba] | [F $dm] | [X %] | [X %] |@| [X %]" + set lmark $lcba + return + } + + proc F {n} { format %10d $n } + proc X {c} { string repeat $c 10 } + + proc mlimit {} { + variable track ; if {!$track} return ; # No checks if there is no memory tracking + variable limit ; if {!$limit} return ; # No checks if there is no memory limit set + + struct::list assign [minfo] _ _ _ cba _ _ + + # Nothing to do if we are still under the limit + if {$cba <= $limit} return + + # Notify user and kill the importer + puts "" + puts "\tMemory limit breached: $cba > $limit" + puts "" + exit 1 + } + + proc setlimit {thelimit} { + # Activate memory tracking, and set the limit. The specified + # limit is taken relative to the amount of memory allocated at + # the time of the call. + + variable limit + struct::list assign [minfo] _ _ _ cba _ _ + set limit [expr $cba + $thelimit] + + track + return + } + + proc notrack {} { + variable track 0 + return + } + + proc track {} { + variable track 1 + return + } + + # # ## ### ##### ######## ############# + + variable track 0 ; # Boolean flag. If set this module will track + # memory, inserting the relevant information + # whenever the application logs something. + variable limit 0 ; # The maximum amount of memory allowed to the + # application. This module will abort when + # 'current bytes allocated' goes over this + # value. + + variable lcba 0 ; # Last 'current bytes allocated' (cba) + variable lmba 0 ; # Last 'maximum bytes allocated' (mba) + variable mid 0 ; # Memory id, abstract time + variable lmark 0 ; # + + # # ## ### ##### ######## ############# +} + +namespace eval ::vc::tools::mem { + namespace export minfo mlog track notrack mlimit setlimit mark +} + +# ----------------------------------------------------------------------------- +# Ready + +package provide vc::tools::mem 1.0 +return diff --git a/tools/cvs2fossil/lib/misc.tcl b/tools/cvs2fossil/lib/misc.tcl new file mode 100644 index 0000000..aa75ab3 --- /dev/null +++ b/tools/cvs2fossil/lib/misc.tcl @@ -0,0 +1,144 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2007-2008 Andreas Kupries. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## Utilities for various things: text formatting, max, ... + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.4 ; # Required runtime + +# # ## ### ##### ######## ############# ##################### +## + +namespace eval ::vc::tools::misc { + # # ## ### ##### ######## ############# + ## Public API, Methods + + # Choose singular vs plural forms of a word based on a number. + + proc sp {n singular {plural {}}} { + if {$n == 1} {return $singular} + if {$plural eq ""} {set plural ${singular}s} + return $plural + } + + # As above, with the number automatically put in front of the + # string. + + proc nsp {n singular {plural {}}} { + return "$n [sp $n $singular $plural]" + } + + # Find maximum/minimum in a list. + + proc max {list} { + set max -1 + foreach e $list { + if {$e < $max} continue + set max $e + } + return $max + } + + proc min {list} { + set min {} + foreach e $list { + if {$min == {}} { + set min $e + } elseif {$e > $min} continue + set min $e + } + return $min + } + + proc max2 {a b} { + if {$a > $b} { return $a } + return $b + } + + proc min2 {a b} { + if {$a < $b} { return $a } + return $b + } + + proc ldelete {lv item} { + upvar 1 $lv list + set pos [lsearch -exact $list $item] + if {$pos < 0} return + set list [lreplace $list $pos $pos] + return + } + + # Delete item from list by name + + proc striptrailingslash {path} { + # split and rejoin gets rid of a traling / character. + return [eval [linsert [file split $path] 0 ::file join]] + } + + # The windows filesystem is storing file-names case-sensitive, but + # matching is case-insensitive. That is a problem as without + # precaution the two files Attic/X,v and x,v may be mistakenly + # identified as the same file. A similar thing can happen for + # files and directories. To prevent such mistakes we need commands + # which do case-sensitive file matching even on systems which do + # not perform this natively. These are below. + + if {$tcl_platform(platform) eq "windows"} { + # We use glob to get the list of files (with proper case in + # the names) to perform our own, case-sensitive matching. WE + # use 8.5 features where possible, for clarity. + + if {[package vsatisfies [package present Tcl] 8.5]} { + proc fileexists_cs {path} { + set dir [::file dirname $path] + set file [::file tail $path] + return [expr {$file in [glob -nocomplain -tail -directory $dir *]}] + } + + proc fileisdir_cs {path} { + set dir [::file dirname $path] + set file [::file tail $path] + return [expr {$file in [glob -nocomplain -types d -tail -directory $dir *]}] + } + } else { + proc fileexists_cs {path} { + set dir [::file dirname $path] + set file [::file tail $path] + return [expr {[lsearch [glob -nocomplain -tail -directory $dir *] $file] >= 0}] + } + + proc fileisdir_cs {path} { + set dir [::file dirname $path] + set file [::file tail $path] + return [expr {[lsearch [glob -nocomplain -types d -tail -directory $dir *] $file] >= 0}] + } + } + } else { + proc fileexists_cs {path} { return [file exists $path] } + proc fileisdir_cs {path} { return [file isdirectory $path] } + } + + # # ## ### ##### ######## ############# +} + +namespace eval ::vc::tools::misc { + namespace export sp nsp max min max2 min2 ldelete + namespace export striptrailingslash fileexists_cs fileisdir_cs +} + +# ----------------------------------------------------------------------------- +# Ready + +package provide vc::tools::misc 1.0 +return diff --git a/tools/cvs2fossil/lib/pkgIndex.tcl b/tools/cvs2fossil/lib/pkgIndex.tcl new file mode 100644 index 0000000..11ebc4b --- /dev/null +++ b/tools/cvs2fossil/lib/pkgIndex.tcl @@ -0,0 +1,47 @@ +# # ## ### ##### ######## ############# ##################### +## Package management. +## Index of the local packages required by cvs2fossil +# # ## ### ##### ######## ############# ##################### +if {![package vsatisfies [package require Tcl] 8.4]} return +package ifneeded vc::fossil::import::cvs 1.0 [list source [file join $dir cvs2fossil.tcl]] +package ifneeded vc::fossil::import::cvs::blobstore 1.0 [list source [file join $dir c2f_blobstore.tcl]] +package ifneeded vc::fossil::import::cvs::file 1.0 [list source [file join $dir c2f_file.tcl]] +package ifneeded vc::fossil::import::cvs::file::rev 1.0 [list source [file join $dir c2f_frev.tcl]] +package ifneeded vc::fossil::import::cvs::file::sym 1.0 [list source [file join $dir c2f_fsym.tcl]] +package ifneeded vc::fossil::import::cvs::file::trunk 1.0 [list source [file join $dir c2f_ftrunk.tcl]] +package ifneeded vc::fossil::import::cvs::fossil 1.0 [list source [file join $dir c2f_fossil.tcl]] +package ifneeded vc::fossil::import::cvs::option 1.0 [list source [file join $dir c2f_option.tcl]] +package ifneeded vc::fossil::import::cvs::integrity 1.0 [list source [file join $dir c2f_integrity.tcl]] +package ifneeded vc::fossil::import::cvs::pass 1.0 [list source [file join $dir c2f_pass.tcl]] +package ifneeded vc::fossil::import::cvs::pass::collar 1.0 [list source [file join $dir c2f_pcollar.tcl]] +package ifneeded vc::fossil::import::cvs::pass::collrev 1.0 [list source [file join $dir c2f_pcollrev.tcl]] +package ifneeded vc::fossil::import::cvs::pass::collsym 1.0 [list source [file join $dir c2f_pcollsym.tcl]] +package ifneeded vc::fossil::import::cvs::pass::filtersym 1.0 [list source [file join $dir c2f_pfiltersym.tcl]] +package ifneeded vc::fossil::import::cvs::pass::initcsets 1.0 [list source [file join $dir c2f_pinitcsets.tcl]] +package ifneeded vc::fossil::import::cvs::pass::csetdeps 1.0 [list source [file join $dir c2f_pcsetdeps.tcl]] +package ifneeded vc::fossil::import::cvs::pass::breakrcycle 1.0 [list source [file join $dir c2f_pbreakrcycle.tcl]] +package ifneeded vc::fossil::import::cvs::pass::rtopsort 1.0 [list source [file join $dir c2f_prtopsort.tcl]] +package ifneeded vc::fossil::import::cvs::pass::breakscycle 1.0 [list source [file join $dir c2f_pbreakscycle.tcl]] +package ifneeded vc::fossil::import::cvs::pass::breakacycle 1.0 [list source [file join $dir c2f_pbreakacycle.tcl]] +package ifneeded vc::fossil::import::cvs::pass::atopsort 1.0 [list source [file join $dir c2f_patopsort.tcl]] +package ifneeded vc::fossil::import::cvs::pass::importfiles 1.0 [list source [file join $dir c2f_pimportfiles.tcl]] +package ifneeded vc::fossil::import::cvs::pass::importcsets 1.0 [list source [file join $dir c2f_pimportcsets.tcl]] +package ifneeded vc::fossil::import::cvs::pass::importfinal 1.0 [list source [file join $dir c2f_pimportfinal.tcl]] +package ifneeded vc::fossil::import::cvs::gtcore 1.0 [list source [file join $dir c2f_gtcore.tcl]] +package ifneeded vc::fossil::import::cvs::cyclebreaker 1.0 [list source [file join $dir c2f_cyclebreaker.tcl]] +package ifneeded vc::fossil::import::cvs::project 1.0 [list source [file join $dir c2f_project.tcl]] +package ifneeded vc::fossil::import::cvs::project::rev 1.0 [list source [file join $dir c2f_prev.tcl]] +package ifneeded vc::fossil::import::cvs::project::revlink 1.0 [list source [file join $dir c2f_prevlink.tcl]] +package ifneeded vc::fossil::import::cvs::project::sym 1.0 [list source [file join $dir c2f_psym.tcl]] +package ifneeded vc::fossil::import::cvs::project::trunk 1.0 [list source [file join $dir c2f_ptrunk.tcl]] +package ifneeded vc::fossil::import::cvs::repository 1.0 [list source [file join $dir c2f_repository.tcl]] +package ifneeded vc::fossil::import::cvs::ristate 1.0 [list source [file join $dir c2f_ristate.tcl]] +package ifneeded vc::fossil::import::cvs::state 1.0 [list source [file join $dir c2f_state.tcl]] +package ifneeded vc::fossil::import::cvs::wsstate 1.0 [list source [file join $dir c2f_wsstate.tcl]] +package ifneeded vc::rcs::parser 1.0 [list source [file join $dir rcsparser.tcl]] +package ifneeded vc::tools::dot 1.0 [list source [file join $dir dot.tcl]] +package ifneeded vc::tools::id 1.0 [list source [file join $dir id.tcl]] +package ifneeded vc::tools::log 1.0 [list source [file join $dir log.tcl]] +package ifneeded vc::tools::misc 1.0 [list source [file join $dir misc.tcl]] +package ifneeded vc::tools::mem 1.0 [list source [file join $dir mem.tcl]] +package ifneeded vc::tools::trouble 1.0 [list source [file join $dir trouble.tcl]] diff --git a/tools/cvs2fossil/lib/rcsparser.tcl b/tools/cvs2fossil/lib/rcsparser.tcl new file mode 100644 index 0000000..d530b36 --- /dev/null +++ b/tools/cvs2fossil/lib/rcsparser.tcl @@ -0,0 +1,485 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2007 Andreas Kupries. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +# A tool package, provides a parser for RCS archive files. This parser +# is implemented via recursive descent. It is not only given a file to +# process, but also a 'sink', an object it calls out to at important +# places of the parsing process to either signal an event and/or +# convey gathered information to it. The sink is responsible for the +# actual processing of the data in whatever way it desires. + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.4 ; # Required runtime. +package require snit ; # OO system. +package require fileutil ; # File utilities. +package require vc::tools::log ; # User feedback. +package require struct::list ; # Advanced list ops. + +# # ## ### ##### ######## ############# ##################### +## + +snit::type ::vc::rcs::parser { + # # ## ### ##### ######## ############# + ## Public API + + typemethod process {path sink} { + Initialize $path $sink + Call begin + Admin ; Deltas ; Description ; DeltaTexts + Call done + return + } + + # # ## ### ##### ######## ############# + ## Internal methods, recursive descent, syntactical processing + + proc Admin {} { + Head ; PrincipalBranch ; Access ; Symbols + Locks ; Strictness ; FileComment ; Expand + Call admindone + return + } + + # # ## ### ##### ######## ############# + + proc Head {} { + RequiredLiteral head + RequiredNumber -> head + Semicolon + Call sethead $head + return + } + + proc PrincipalBranch {} { + if {![OptionalLiteral branch]} return + RequiredNumber -> branch + Semicolon + Call setprincipalbranch $branch + return + } + + proc Access {} { + RequiredLiteral access ; + Semicolon + return + } + + proc Symbols {} { + RequiredLiteral symbols + while {[Ident -> symbol]} { + if { + *$} $symbol] || + [string match */ $symbol] + } { + Rewind + Bad {symbol name} + } + RequiredNumber -> rev + Call deftag $symbol $rev + } + Semicolon + return + } + + proc Locks {} { + # Not saving locks. + RequiredLiteral locks + while {[Ident -> symbol]} { + RequiredNumber -> l + } + Semicolon + return + } + + proc Strictness {} { + # Not saving strictness + if {![OptionalLiteral strict]} return + Semicolon + return + } + + proc FileComment {} { + if {![OptionalLiteral comment]} return + if {![OptionalString -> c]} return + Semicolon + Call setcomment $c + return + } + + proc Expand {} { + # Not saving expanded keywords + if {![OptionalLiteral expand]} return + if {![OptionalString -> dummy]} return + Semicolon + return + } + + # # ## ### ##### ######## ############# + + proc Deltas {} { + set ok [OptionalNumber -> rev] + while {$ok} { + Date -> d + Author -> a + State -> s + Branches -> b + NextRev -> n + Call def $rev $d $a $s $n $b + + # Check if this is followed by a revision number or the + # literal 'desc'. If neither we consume whatever is there + # until the next semicolon, as it has to be a 'new + # phrase'. Otherwise, for a revision number we loop back + # and consume that revision, and lastly for 'desc' we stop + # completely as this signals the end of the revision tree + # and the beginning of the deltas. + + while {1} { + set ok [OptionalNumber -> rev] + if {$ok} break + + if {[LiteralPeek desc]} { + set ok 0 + break + } + + Anything -> dummy + Semicolon + } + } + Call defdone + return + } + + # # ## ### ##### ######## ############# + + proc Date {_ dv} { + upvar 1 $dv d + RequiredLiteral date + RequiredNumber -> d + Semicolon + + struct::list assign [split $d .] year month day hour min sec + if {$year < 100} {incr year 1900} + set d [clock scan "${year}-${month}-${day} ${hour}:${min}:${sec}"] + return + } + + proc Author {_ av} { + upvar 1 $av a + RequiredLiteral author + Anything -> a + Semicolon + return + } + + proc State {_ sv} { + upvar 1 $sv s + RequiredLiteral state + Anything -> s + Semicolon + return + } + + proc Branches {_ bv} { + upvar 1 $bv b + RequiredLiteral branches + Anything -> b + Semicolon + return + } + + proc NextRev {_ nv} { + upvar 1 $nv n + RequiredLiteral next + Anything -> n + Semicolon + return + } + + # # ## ### ##### ######## ############# + + proc Description {} { + upvar 1 data data res res + RequiredLiteral desc + RequiredString -> d + Call setdesc $d + return + } + + # # ## ### ##### ######## ############# + + proc DeltaTexts {} { + while {[OptionalNumber -> rev]} { + RequiredLiteral log + RequiredString -> cmsg + if {[regexp {[\000-\010\013\014\016-\037]} $cmsg]} { + #Rewind + #Bad "log message for $rev contains at least one control character" + } + + RequiredLiteral text + RequiredStringRange -> delta + Call extend $rev $cmsg $delta + } + return + } + + # # ## ### ##### ######## ############# + ## Internal methods, lexiographical processing + + proc Semicolon {} { + ::variable mydata + ::variable mypos + + set ok [regexp -start $mypos -indices -- {\A\s*;\s*} $mydata match] + if {!$ok} { Expected ';' } + + SkipOver match + return + } + + proc RequiredLiteral {name} { + ::variable mydata + ::variable mypos + + set pattern "\\A\\s*$name\\s*" + set ok [regexp -start $mypos -indices -- $pattern $mydata match] + if {!$ok} { Expected '$name' } + + SkipOver match + return + } + + proc OptionalLiteral {name} { + ::variable mydata + ::variable mypos + + set pattern "\\A\\s*$name\\s*" + set ok [regexp -start $mypos -indices -- $pattern $mydata match] + if {!$ok} { return 0 } + + SkipOver match + return 1 + } + + proc LiteralPeek {name} { + ::variable mydata + ::variable mypos + + set pattern "\\A\\s*$name\\s*" + set ok [regexp -start $mypos -indices -- $pattern $mydata match] + if {!$ok} { return 0 } + + # NO - SkipOver match - Only looking ahead here. + return 1 + } + + proc RequiredNumber {_ v} { + upvar 1 $v value + ::variable mydata + ::variable mypos + + set pattern {\A\s*((\d|\.)+)\s*} + set ok [regexp -start $mypos -indices -- $pattern $mydata match v] + if {!$ok} { Expected id } + + Extract $v -> value + SkipOver match + return + } + + proc OptionalNumber {_ v} { + upvar 1 $v value + ::variable mydata + ::variable mypos + + set pattern {\A\s*((\d|\.)+)\s*} + set ok [regexp -start $mypos -indices -- $pattern $mydata match v] + if {!$ok} { return 0 } + + Extract $v -> value + SkipOver match + return 1 + } + + proc RequiredString {_ v} { + upvar 1 $v value + ::variable mydata + ::variable mypos + + set ok [regexp -start $mypos -indices -- {\A\s*@(([^@]*(@@)*)*)@\s*} $mydata match v] + if {!$ok} { Expected string } + + Extract $v -> value + set value [string map {@@ @} $value] + SkipOver match + return + } + + proc RequiredStringRange {_ v} { + upvar 1 $v value + ::variable mydata + ::variable mypos + + set ok [regexp -start $mypos -indices -- {\A\s*@(([^@]*(@@)*)*)@\s*} $mydata match value] + if {!$ok} { Expected string } + + SkipOver match + return + } + + proc OptionalString {_ v} { + upvar 1 $v value + ::variable mydata + ::variable mypos + + set ok [regexp -start $mypos -indices -- {\A\s*@(([^@]*(@@)*)*)@\s*} $mydata match v] + if {!$ok} { return 0 } + + Extract $v -> value + set value [string map {@@ @} $value] + SkipOver match + return 1 + } + + proc Ident {_ v} { + upvar 1 $v value + ::variable mydata + ::variable mypos + + set ok [regexp -start $mypos -indices -- {\A\s*;\s*} $mydata] + if {$ok} { return 0 } + + set ok [regexp -start $mypos -indices -- {\A\s*([^:]*)\s*:\s*} $mydata match v] + if {!$ok} { return 0 } + + Extract $v -> value + SkipOver match + return 1 + } + + proc Anything {_ v} { + upvar 1 $v value + ::variable mydata + ::variable mypos + + regexp -start $mypos -indices -- {\A\s*([^;]*)\s*} $mydata match v + + Extract $v -> value + SkipOver match + return + } + + # # ## ### ##### ######## ############# + ## Internal methods, input handling + + proc Extract {range _ v} { + upvar 1 $v value + ::variable mydata + struct::list assign $range s e + set value [string range $mydata $s $e] + return + } + + proc SkipOver {mv} { + # Note: The indices are absolute!, not relative to the start + # location. + upvar 1 $mv match + ::variable mypos + ::variable mysize + ::variable mylastpos + + struct::list assign $match s e + #puts "<$s $e> [info level -1]" + + set mylastpos $mypos + set mypos $e + incr mypos + + log progress 2 rcs $mypos $mysize + #puts $mypos/$mysize + return + } + + proc Rewind {} { + ::variable mypos + ::variable mylastpos + + set mypos $mylastpos + return + } + + proc Expected {x} { + ::variable mydata + ::variable mypos + set e $mypos ; incr e 30 + return -code error -errorcode vc::rcs::parser \ + "Expected $x @ '[string range $mydata $mypos $e]...'" + } + + proc Bad {x} { + ::variable mydata + ::variable mypos + set e $mypos ; incr e 30 + return -code error -errorcode vc::rcs::parser \ + "Bad $x @ '[string range $mydata $mypos $e]...'" + } + + # # ## ### ##### ######## ############# + ## Setup, callbacks. + + proc Initialize {path sink} { + ::variable mypos 0 + ::variable mydata [fileutil::cat -translation binary $path] + ::variable mysize [file size $path] + ::variable mysink $sink + return + } + + proc Call {args} { + ::variable mysink + set cmd $mysink + foreach a $args { lappend cmd $a } + eval $cmd + return + } + + # # ## ### ##### ######## ############# + ## Configuration + + typevariable mydata {} ; # Rcs archive contents to process + typevariable mysize 0 ; # Length of contents + typevariable mysink {} ; # Sink to report to + + pragma -hasinstances no ; # singleton + pragma -hastypeinfo no ; # no introspection + pragma -hastypedestroy no ; # immortal + + # # ## ### ##### ######## ############# +} + +namespace eval ::vc::rcs { + namespace export parser + namespace eval parser { + namespace import ::vc::tools::log + log register rcs + } +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide vc::rcs::parser 1.0 +return diff --git a/tools/cvs2fossil/lib/trouble.tcl b/tools/cvs2fossil/lib/trouble.tcl new file mode 100644 index 0000000..dcc2af9 --- /dev/null +++ b/tools/cvs2fossil/lib/trouble.tcl @@ -0,0 +1,124 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Copyright (c) 2007 Andreas Kupries. +# +# This software is licensed as described in the file LICENSE, which +# you should have received as part of this distribution. +# +# This software consists of voluntary contributions made by many +# individuals. For exact contribution history, see the revision +# history and logs, available at http://fossil-scm.hwaci.com/fossil +# # ## ### ##### ######## ############# ##################### + +## Utility package, error reporting on top of the log package. + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.4 ; # Required runtime. +package require vc::tools::log ; # Basic log generation. +package require snit ; # OO system. + +# # ## ### ##### ######## ############# ##################### +## + +snit::type ::vc::tools::trouble { + # # ## ### ##### ######## ############# + ## Public API, Methods + + typemethod internal {text} { + foreach line [split $text \n] { $type fatal "INTERNAL ERROR! $line" } + exit 1 + } + + typemethod fatal {text} { + lappend myfatal $text + return + } + + typemethod warn {text} { + lappend mywarn $text + log write 0 trouble $text + return + } + + typemethod info {text} { + lappend myinfo $text + return + } + + typemethod show {} { + foreach m $myinfo { log write 0 "" $m } + foreach m $mywarn { log write 0 warning $m } + foreach m $myfatal { log write 0 fatal $m } + return + } + + typemethod ? {} { + return [expr { + [llength $myinfo] || + [llength $mywarn] || + [llength $myfatal] + }] + } + + typemethod abort? {} { + if { + ![llength $myinfo] && + ![llength $mywarn] && + ![llength $myfatal] + } return + + # Frame the pending messages to make them more clear as the + # cause of the abort. + + set myinfo [linsert $myinfo 0 "" "Encountered problems." ""] + lappend myfatal "Stopped due to problems." + + # We have error messages to print, so stop now. + exit 1 + } + + # # ## ### ##### ######## ############# + ## Internal, state + + typevariable myinfo {} + typevariable mywarn {} + typevariable myfatal {} + + # # ## ### ##### ######## ############# + ## Configuration + + pragma -hasinstances no ; # singleton + pragma -hastypeinfo no ; # no introspection + pragma -hastypedestroy no ; # immortal + + # # ## ### ##### ######## ############# +} + +# # ## ### ##### ######## ############# ##################### +## Internal. Special. Set up a hook into the application exit, to show +## the remembered messages, before passing through the regular command. + +rename ::exit ::vc::tools::trouble::EXIT +proc ::exit {{status 0}} { + ::vc::tools::trouble show + ::vc::tools::trouble::EXIT $status + # Not reached. + return +} + +namespace eval ::vc::tools { + namespace eval trouble {namespace import ::vc::tools::log } + trouble::log register "" + trouble::log register fatal + trouble::log register trouble + trouble::log register warning + namespace export trouble +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide vc::tools::trouble 1.0 +return |