Artifact a015f1382f998fda8c172c918e905d43a356a9ae
File
tools/lib/cvs.tcl
part of check-in
[b504674c5f]
- Fixed problems with the untested statistics module.
Moved cset <-> uuid map out of cvs to control layer, separate package.
Currently not really useful, will be needed when handling cvs branches.
Moved some user feedback around, and the import control too.
by
aku on
2007-09-15 03:18:31.
# -----------------------------------------------------------------------------
# Repository management (CVS)
# -----------------------------------------------------------------------------
# Requirements
package require Tcl 8.4
package require fileutil ; # Tcllib (traverse directory hierarchy)
package require vc::rcs::parser ; # Handling the RCS archive files.
package require vc::tools::log ; # User feedback
package require vc::cvs::cmd ; # Access to cvs application.
package require struct::tree
namespace eval ::vc::cvs::ws {
vc::tools::log::system cvs
namespace import ::vc::tools::log::write
namespace import ::vc::rcs::parser::process
namespace import ::vc::cvs::cmd::dova
}
# -----------------------------------------------------------------------------
# API
# Define repository directory.
proc ::vc::cvs::ws::at {path} {
variable base [file normalize $path]
write 0 cvs "Base: $base"
return
}
namespace eval ::vc::cvs::ws {
# Toplevel repository directory
variable base {}
}
# Scan repository, collect archives, parse them, and collect revision
# information (file, revision -> date, author, commit message)
proc ::vc::cvs::ws::scan {} {
variable base
variable npaths
variable rpaths
variable timeline
write 0 cvs {Scanning directory hierarchy}
set n 0
foreach rcs [fileutil::findByPattern $base -glob *,v] {
set rcs [fileutil::stripPath $base $rcs]
# Now rcs is relative to base
write 1 cvs "Archive $rcs"
if {[string match CVSROOT* $rcs]} {
write 2 cvs {Ignored. Administrative file}
continue
}
# Derive the regular path from the rcs path. Meaning: Chop of
# 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]} {
set f [file join [file dirname [file dirname $f]] [file tail $f]]
if {[file exists $base/$f,v]} {
# We have a regular archive and an Attic archive
# refering to the same user visible file. Ignore the
# file in the Attic.
write 2 cvs "Ignored. Attic superceded by regular archive"
# TODO/CHECK. My method of co'ing exact file revisions
# per the info in the collected csets has the flaw
# that I may have to know exactly when what archive
# file to use, see above. It might be better to use
# the info only to gather when csets begin and end,
# and then to co complete slices per exact timestamp
# (-D) instead of file revisions (-r). The flaw in
# that is that csets can occur in the same second
# (trf, memchan - check for examples). For that exact
# checkout may be needed to recreate exact sequence of
# changes. Grr. Six of one ...
continue
}
}
# Get the meta data we need (revisions, timeline, messages).
set meta [process $base/$rcs]
set npaths($rcs) $f
set rpaths($f) $rcs
array set p $meta
foreach {rev ts} $p(date) {_ a} $p(author) {_ cm} $p(commit) {_ st} $p(state) {
set op [expr {($rev eq "1.1") ? "A" : "M"}]
if {$st eq "dead"} {set op "R"}
# A dead-first revision is rev 1.1 with op R. For an
# example see the file memchan/DEPENDENCIES. Such a file
# seems to exist only! on its branch. The branches
# information is set on the revision (extend rcsparser!),
# symbols has a tag, refering to a branch, possibly magic.
if {($rev eq "1.1") && ($op eq "R")} {
write 2 cvs {Dead root revision}
}
lappend timeline($ts) [list $op $ts $a $rev $f $cm]
}
#unset p(commit)
#parray p
incr n
}
write 0 cvs "Processed $n [expr {($n == 1) ? "file" : "files"}]"
return
}
namespace eval ::vc::cvs::ws {
# Path mappings. npaths: rcs file -> user file
# rpaths: user file -> rcs file, dead-status
variable npaths ; array set npaths {}
variable rpaths ; array set rpaths {}
# Timeline: tstamp -> (op, tstamp, author, revision, file, commit message)
variable timeline ; array set timeline {}
}
# Group single changes into changesets
proc ::vc::cvs::ws::csets {} {
variable timeline
variable csets
variable ncs
variable cmap
array unset csets * ; array set csets {}
array unset cmap * ; array set cmap {}
set ncs 0
write 0 cvs "Processing timeline"
set n 0
CSClear
foreach ts [lsort -dict [array names timeline]] {
# op tstamp author revision file commit
# 0 1 2 3 4 5/end
# b c a
set entries [lsort -index 2 [lsort -index 0 [lsort -index end $timeline($ts)]]]
#puts [join $entries \n]
foreach entry $entries {
if {![CSNone] && [CSNew $entry]} {
CSSave
CSClear
#puts ==\n$reason
}
CSAdd $entry
incr n
}
}
write 0 cvs "Processed $n [expr {($n == 1) ? "entry" : "entries"}]"
set n [array size csets]
write 0 cvs "Found $n [expr {($n == 1) ? "changeset" : "changesets"}]"
return
}
namespace eval ::vc::cvs::ws {
# Changeset data:
# ncs: Counter-based id generation
# csets: id -> (user commit start end depth (file -> (op rev)))
variable ncs ; set ncs 0 ; # Counter for changesets
variable csets ; array set csets {} ; # Changeset data
}
# Building the revision tree from the changesets.
# Limitation: Currently only trunk csets is handled.
# Limitation: Dead files are not removed, i.e. no 'R' actions right now.
proc ::vc::cvs::ws::rtree {} {
variable csets
variable rtree {}
variable ntrunk 0
write 0 cvs "Extracting the trunk"
set rtree [struct::tree ::vc::cvs::ws::RT]
$rtree rename root 0 ; # Root is first changeset, always.
set trunk 0
set ntrunk 1 ; # Root is on the trunk.
set b 0 ; # No branch csets found yet.
# Extracting the trunk is easy, simply by looking at the involved
# version numbers.
foreach c [lrange [lsort -integer [array names csets]] 1 end] {
foreach {u cm s e rd f} $csets($c) break
# Ignore branch changes, just count them for the statistics.
if {$rd != 2} {
incr b
continue
}
# Trunk revision, connect to, and update the head.
$rtree insert $trunk end $c
set trunk $c
incr ntrunk
}
write 0 cvs "Processed $ntrunk trunk [expr {($ntrunk == 1) ? "changeset" : "changesets"}]"
write 0 cvs "Ignored $b branch [expr {($b == 1) ? "changeset" : "changesets"}]"
return
}
namespace eval ::vc::cvs::ws {
# Tree holding trunk and branch information (struct::tree).
# Node names are cset id's.
variable rtree {}
variable ntrunk 0
}
proc ::vc::cvs::ws::workspace {} {
variable cwd [pwd]
variable workspace [fileutil::tempfile importF_cvs_ws_]
file delete $workspace
file mkdir $workspace
write 0 cvs "Workspace: $workspace"
cd $workspace ; # Checkouts go here.
return $workspace
}
proc ::vc::cvs::ws::wsignore {path} {
# Ignore CVS admin files.
if {[string match */CVS/* $path]} {return 1}
return 0
}
proc ::vc::cvs::ws::wsclear {} {
variable cwd
variable workspace
cd $cwd
file delete -force $workspace
return
}
proc ::vc::cvs::ws::wssetup {c} {
variable csets
variable base
# pwd = workspace
foreach {u cm s e rd fs} $csets($c) break
write 1 cvs "@ $s"
foreach l [split [string trim $cm] \n] {
write 1 cvs "| $l"
}
foreach {f or} $fs {
foreach {op r} $or break
write 2 cvs "$op $f $r"
if {$op eq "R"} {
# Remove file from workspace. Prune empty directories.
#
# NOTE: A dead-first file (rev 1.1 dead) will never have
# existed.
#
# NOTE: Logically empty directories still physically
# contain the CVS admin directory, hence the check for ==
# 1, not == 0. There might also be hidden files, we count
# them as well. Always hidden are . and .. and they do not
# count as user file.
file delete $f
set fd [file dirname $f]
if {
([llength [glob -nocomplain -directory $fd *]] == 1) &&
([llength [glob -nocomplain -directory -type hidden $fd *]] == 2)
} {
file delete -force $fd
}
} else {
# Added or modified, put the requested version of the file
# into the workspace.
if {[catch {
dova -d $base co -r $r $f
} msg]} {
if {[string match {*invalid change text*} $msg]} {
# The archive of the file is corrupted and the
# chosen version not accessible due to that. We
# report the problem, but otherwise ignore it. As
# a consequence the fossil repository will not
# contain the full history of the named file. By
# ignoring the problem we however get as much as
# is possible.
write 0 cvs "EE Corrupted archive file. Inaccessible revision."
continue
}
return -code error $msg
}
}
}
# Provide metadata about the changeset the backend may wish to have
return [list $u $s $cm]
}
namespace eval ::vc::cvs::ws {
# Workspace where checkouts happen
# Current working directory to go back to after the import.
variable workspace {}
variable cwd {}
}
proc ::vc::cvs::ws::foreach_cset {cv node script} {
upvar 1 $cv c
variable rtree
set c $node
while {1} {
set code [catch {uplevel 1 $script} res]
# 0 - ok, 1 - error, 2 - return, 3 - break, 4 - continue
switch -- $code {
0 {}
1 { return -errorcode $::errorCode -errorinfo $::errorInfo -code error $res }
2 {}
3 { return }
4 {}
default {
return -code $code $result
}
}
# Stop on reaching the head.
if {![llength [$rtree children $c]]} break
#puts <[$rtree children $c]>
# Go to next child in trunk (leftmost).
set c [lindex [$rtree children $c] 0]
}
return
}
proc ::vc::cvs::ws::root {} {
return 0
}
proc ::vc::cvs::ws::ntrunk {} {
variable ntrunk
return $ntrunk
}
proc ::vc::cvs::ws::ncsets {} {
variable ncs
return $ncs
}
# -----------------------------------------------------------------------------
# Internal helper commands: Changeset inspection and construction.
proc ::vc::cvs::ws::CSClear {} {
upvar 1 start start end end cm cm user user files files lastd lastd
set start {}
set end {}
set cm {}
set user {}
set lastd {}
array unset files *
array set files {}
return
}
proc ::vc::cvs::ws::CSNone {} {
upvar 1 start start
return [expr {$start eq ""}]
}
proc ::vc::cvs::ws::CSNew {entry} {
upvar 1 start start end end cm cm user user files files lastd lastd reason reason
#puts -nonewline stdout . ; flush stdout
foreach {op ts a rev f ecm} $entry break
# User change
if {$a ne $user} {set reason user ; return 1}
# File already in current cset
if {[info exists files($f)]} {set reason file ; return 1}
# Current cset trunk/branch different from entry.
set depth [llength [split $rev .]]
if {($lastd == 2) != ($depth == 2)} {set reason depth/$lastd/$depth/($rev)/$f ; return 1}
# Commit message changed
if {$cm ne $ecm} {set reason cmsg\ <<$ecm>> ; return 1}
# Everything is good, still the same cset
return 0
}
proc ::vc::cvs::ws::CSSave {} {
variable cmap
variable csets
variable ncs
upvar 1 start start end end cm cm user user files files lastd lastd
set csets($ncs) [list $user $cm $start $end $lastd [array get files]]
# Record which revisions of a file are in what csets
foreach {f or} [array get files] {
foreach {_ rev} $or break
set cmap([list $f $rev]) $ncs
}
#CSDump $ncs
incr ncs
return
}
proc ::vc::cvs::ws::CSAdd {entry} {
upvar 1 start start end end cm cm user user files files lastd lastd
foreach {op ts a rev f ecm} $entry break
if {$start eq ""} {set start $ts}
set end $ts
set cm $ecm
set user $a
set files($f) [list $op $rev]
set lastd [llength [split $rev .]]
return
}
proc ::vc::cvs::ws::CSDump {c} {
variable csets
foreach {u cm s e rd f} $csets($c) break
puts "$u $s"; regsub -all {.} $u { } b
puts "$b $e"
foreach {f or} $f {
foreach {o r} $or break
puts "$b $o $f $r"
}
return
}
namespace eval ::vc::cvs::ws {
namespace export at scan csets rtree workspace wsignore wsclear wssetup \
foreach_cset root ntrunk ncsets
}
# -----------------------------------------------------------------------------
# Ready
package provide vc::cvs::ws 1.0
return