summaryrefslogtreecommitdiff
path: root/tools/cvs2fossil/lib/c2f_prev.tcl
diff options
context:
space:
mode:
authorcashmere <cashmere@autistici.org>2026-09-04 09:05:24 +0200
committercashmere <cashmere@autistici.org>2026-09-04 09:05:24 +0200
commit4f49b16079b27d7ce633619e4cddfdf2bffbc952 (patch)
treec296c1e7f3c3e2f6859c6d3a1b1b208779b89679 /tools/cvs2fossil/lib/c2f_prev.tcl
downloadrelic-4f49b16079b27d7ce633619e4cddfdf2bffbc952.tar.gz
initial commitHEADmaster
Diffstat (limited to 'tools/cvs2fossil/lib/c2f_prev.tcl')
-rw-r--r--tools/cvs2fossil/lib/c2f_prev.tcl1846
1 files changed, 1846 insertions, 0 deletions
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