Fossil

## Requirements

package require Tcl 8.4                             ; # Required runtime.
package require snit                                ; # OO system.
package require struct::set                         ; # Set operations.
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::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]
	return
    }

    method setid {id} {
	if {$myid ne ""} { trouble internal "File '$mypath' already has an id, '$myid'" }
	set myid $id
	return
    }

    method id      {} { return $myid }
    method path    {} { return $mypath }
    method usrpath {} { return $myusrpath }
    method project {} { return $myproject }

    delegate method commitmessageof to myproject

    # # ## ### ##### ######## #############

    #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 }
	}
	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
    }

    # # ## ### ##### ######## #############
    ## 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.

    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.

		$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

	    # Cut out the vendor branch symbol

	    set vendor [$first parentbranch]
	    if {$vendor eq ""} { trouble internal "First NTDB revision has no branch" }
	    if {[$vendor parent] eq $rev11} {
		$rev11 removebranch        $vendor
		$rev11 removechildonbranch $first
		$vendor cutchild
		$first cutfromparentbranch
		lappend myroots $first
	    }

	    # Change the type of first (typically from Change to Add):
	    $first retype add

	    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] {
		if {![$branch haschild]} continue
		set first [$branch child]
		$first cutfromparentbranch
		$first cutfromparent
		$branch cutchild
		lappend myroots $first
	    }
	    $root removeallbranches

	    # Tagging a dead revision doesn't do anything, so remove
	    # any tags that were set on it.

	    set branch [$root parentbranch]
	    set parent [$root parent]
	    set child  [$root child]

	    ldelete myroots $root
	    lappend myroots $child

	    $branch cutchild
	    $child  cutfromparent

	    $parent removebranch        $branch
	    $parent removechildonbranch $root
	}
	return
    }

    method LinesOfDevelopment {} {

		$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] { lappend symbols $branch }
		set lod [$root lod]
		if {![$lod istrunk]} { lappend symbols $lod }
		set root [$root child]
	    }
	}

	return [list [lsort -unique -dict $revisions] [lsort -unique -dict $symbols]]
    }

    # # ## ### ##### ######## #############
    ## 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::state
    }
}

# # ## ### ##### ######## ############# #####################
## Ready

package provide vc::fossil::import::cvs::file 1.0
return

# # ## ### ##### ######## ############# #####################
## 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.

# # ## ### ##### ######## ############# #####################
## 

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 }

    # Basic pieces ________________________

    method hasmeta {} { return [expr {$mymetaid ne ""}] }
    method hastext {} {
	struct::list assign $mytext s e
	return [expr {$s <= $e}]
    }

	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 op  $myopcode($myoperation)
	set idb $myisondefaultbranch

	struct::list assign $mytext cs cl
	set cl [expr {$cl - $cs}]

	lappend map @L@ [expr { [$mylod istrunk]        ? "NULL" : [$mylod          id] }]
	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, lod,  rev,      date,    state,    mid,       cs,  cl, op,   isdefault, parent, child, dbparent, dbchild, bparent)
	    VALUES               ($myid, $fid, @L@, $myrevnr, $mydate, $mystate, $mymetaid, $cs, $cl, $op, $idb,       @P@,    @C@,   @DP,      @DC,     @BP);
	}

	state transaction {
	    state run [string map $map $cmd]
	}
	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              - revision.{cs,cl}
    #             myparent            - revision.parent
    #             mychild             - revision.child
    #             myparentbranch      - revision.bparent
    #             myoperation         - revision.op
    #             myisondefaultbranch - revision.isdefault
    #             mydbparent          - revision.dbparent
    #             mydbchild           - revision.dbchild
 

    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 mytext      {} ; # Range of the (delta) text for this revision in the file.

    # dead(self) x dead(parent) -> operation
    typevariable myopstate -array {
	{0 0} change
	{0 1} delete
	{1 0} add
	{1 1} nothing
    }
    typevariable myopcode -array {
	change   2
	delete  -1
	add      1
	nothing  0
    }

    # # ## ### ##### ######## #############
    ## 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
    }
}

# # ## ### ##### ######## ############# #####################
## Ready

package provide vc::fossil::import::cvs::file::rev 1.0
return

# # ## ### ##### ######## ############# #####################
## 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.

# # ## ### ##### ######## ############# #####################
## 

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 }
	    tag     { }
	    default { trouble internal "Bad symbol type '$mytype'" }
	}
	return
    }

    method defid {} {
	set myid [incr myidcounter]
	return
    }

    method fid {} { return $myid }

    # Symbol acessor methods.

    delegate method name to mysymbol
    delegate method id   to mysymbol

    method istrunk {} { return 0 }

    # Branch acessor methods.

    method setchildrevnr  {revnr} {
	if {$mybranchchildrevnr ne ""} { trouble internal "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 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.

	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.

	# NOTE: mybranchposition is currently not saved. This can
	# likely be figured out later from the id itself. If yes, we
	# can also get rid of 'sortbranches' (cvs::file) and the
	# associated information.

	set fid [$myfile   id]
	set sid [$mysymbol id]

	lappend map @L@ [expr { [$mylod istrunk] ? "NULL" : [$mylod id] }]

	switch -exact -- $mytype {
	    tag {
		set rid [$mytagrev id]
		set cmd {
		    INSERT INTO tag ( tid,   fid, lod,  sid,  rev)
		    VALUES          ($myid, $fid, @L@, $sid, $rid);
		}
	    }
	    branch {
		lappend map @F@ [expr { ($mybranchchild eq "") ? "NULL" : [$mybranchchild id] }]

		set rid [$mybranchparent id]
		set cmd {
		    INSERT INTO branch ( bid,   fid, lod,  sid,  root, first, bra )
		    VALUES             ($myid, $fid, @L@, $sid, $rid,  @F@, $mynr);
		}
	    }
	}

	state transaction {
	    state run [string map $map $cmd]
	}
	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

    # # ## ### ##### ######## #############
}

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::tools::trouble
    }
}

# # ## ### ##### ######## ############# #####################
## Ready

package provide vc::fossil::import::cvs::file::sym 1.0
return

	# 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 writing revision {
	    rid  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)

	    -- The tags and branches belonging to a revision can be
	    -- determined by selecting on the backreferences in the
	    -- tag and branch tables.

	    rev   TEXT     NOT NULL,                 -- revision number
	    date  INTEGER  NOT NULL,                 -- date of entry, seconds since epoch
	    state TEXT     NOT NULL,                 -- state of revision
	    mid   INTEGER  NOT NULL REFERENCES meta, -- meta data (author, commit message)
	    cs    INTEGER  NOT NULL,                 -- Revision content as offset and
	    cl    INTEGER  NOT NULL,                 -- length into the archive file.

	    -- Derived information, and links
	    -- Basic: Parent/Child
	    -- NTDB:  DefaultParent/DefaultChild
	    -- Branches: Branch parent revision

	    op        INTEGER NOT NULL,
	    isdefault INTEGER NOT NULL,
	    parent    INTEGER        REFERENCES revision,
	    child     INTEGER        REFERENCES revision,
	    dbparent  INTEGER        REFERENCES revision,
	    dbchild   INTEGER        REFERENCES revision,
	    bparent   INTEGER        REFERENCES symbol
	}

	state writing 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.
	}

	state writing 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  NOT NULL  REFERENCES revision, -- Revision the branch sprouts from
	    first INTEGER            REFERENCES revision, -- First revision committed to the branch
	    bra   TEXT     NOT NULL                       -- branch number
	}

	# It is in principle possible to collapse the four tables
	# above (from item to barnch) into a single table, with

		    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
	    }
	}

	repository printrevstatistics
	repository persistrev

	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 meta

    method printbase {} {
	if {$mybase eq ""} {return <Repository>}
	return $mybase
    }

    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]]
    }

		[sym %AUTO% $name [$myrepository defsymbol $myid $name]]
	}
	return $mysymbols($name)
    }

    # 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, immediately after
	# processing it, to keep out use of memory under control. Now
	# we just have to save the remaining project level parts to
	# fix the left-over dangling references.

	state transaction {
	    # TODO: per project persistence (symbols, meta data)



	}
	return
    }

    # # ## ### ##### ######## #############
    ## 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 prject belongs to.
    variable mysymbols -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

		lappend myprojpaths $name
		lappend myprojects [set pr($pid) [project %AUTO% $name $type]]
		$pr($pid) setid $pid
	    }
	    foreach   {fid  pid  name  visible  exec} [state run {
		SELECT fid, pid, name, visible, exec FROM file ;
	    }] {
		$pr($pid) addfile $name $visible $exec $fid
	    }
	}
	return
    }

    # pass II results
    typemethod printrevstatistics {} {