@@ -4,13 +4,17 @@
# -----------------------------------------------------------------------------
# Requirements
package require Tcl 8.4
-package require fileutil ; # Tcllib (cat)
-package require rcsparser ; # Handling the RCS archive files.
+package require fileutil ; # Tcllib (traverse directory hierarchy)
+package require rcsparser ; # Handling the RCS archive files.
+package require tools::log ; # User feedback
package require struct::tree
-namespace eval ::cvs {}
+namespace eval ::cvs {
+ tools::log::system cvs
+ namespace import ::tools::log::write
+}
# -----------------------------------------------------------------------------
# API
@@ -17,22 +21,15 @@
# Define repository directory.
proc ::cvs::at {path} {
variable base [file normalize $path]
+ write 0 cvs "Base: $base"
return
}
namespace eval ::cvs {
# Toplevel repository directory
variable base {}
-}
-
-# Define logging callback command
-
-proc ::cvs::feedback {logcmd} {
- variable lc $logcmd
- ::rcsparser::feedback $logcmd
- return
}
# Scan repository, collect archives, parse them, and collect revision
# information (file, revision -> date, author, commit message)
@@ -42,19 +39,19 @@
variable npaths
variable rpaths
variable timeline
- Log info "Scanning CVS tree $base"
+ 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
- Log info " Parsing archive $rcs"
+ write 1 cvs "Archive $rcs"
if {[string match CVSROOT* $rcs]} {
- Log info " => Ignoring admin file"
+ write 2 cvs {Ignored. Administrative file}
continue
}
# Derive the regular path from the rcs path. Meaning: Chop of
@@ -65,9 +62,10 @@
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.
- Log info " => Ignoring attic for regular archive"
+
+ 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
@@ -86,10 +84,8 @@
# Get the meta data we need (revisions, timeline, messages).
set meta [::rcsparser::process $base/$rcs]
- Log info " => $f"
-
set npaths($rcs) $f
set rpaths($f) $rcs
array set p $meta
@@ -104,9 +100,9 @@
# 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")} {
- Log info " => Dead first"
+ write 2 cvs {Dead root revision}
}
lappend timeline($ts) [list $op $ts $a $rev $f $cm]
}
@@ -116,9 +112,9 @@
incr n
}
- Log info "Processed $n [expr {($n == 1) ? "file" : "files"}]"
+ write 0 cvs "Processed $n [expr {($n == 1) ? "file" : "files"}]"
return
}
namespace eval ::cvs {
@@ -144,9 +140,9 @@
array unset csets * ; array set csets {}
array unset cmap * ; array set cmap {}
set ncs 0
- Log info "Processing timeline"
+ write 0 cvs "Processing timeline"
set n 0
CSClear
foreach ts [lsort -dict [array names timeline]] {
@@ -168,11 +164,12 @@
incr n
}
}
- Log info "Processed $n [expr {($n == 1) ? "entry" : "entries"}]"
+ write 0 cvs "Processed $n [expr {($n == 1) ? "entry" : "entries"}]"
+
set n [array size csets]
- Log info "Found $n [expr {($n == 1) ? "changeset" : "changesets"}]"
+ write 0 cvs "Found $n [expr {($n == 1) ? "changeset" : "changesets"}]"
return
}
@@ -193,9 +190,9 @@
variable csets
variable rtree {}
variable ntrunk 0
- Log info "Extracting the trunk"
+ write 0 cvs "Extracting the trunk"
set rtree [struct::tree ::cvs::RT]
$rtree rename root 0 ; # Root is first changeset, always.
set trunk 0
@@ -219,10 +216,10 @@
set trunk $c
incr ntrunk
}
- Log info "Processed $ntrunk trunk [expr {($ntrunk == 1) ? "changeset" : "changesets"}]"
- Log info "Ignored $b branch [expr {($b == 1) ? "changeset" : "changesets"}]"
+ 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 ::cvs {
@@ -238,9 +235,9 @@
variable workspace [fileutil::tempfile importF_cvs_ws_]
file delete $workspace
file mkdir $workspace
- Log info " Workspace: $workspace"
+ write 0 cvs "Workspace: $workspace"
cd $workspace ; # Checkouts go here.
return $workspace
}
@@ -267,17 +264,17 @@
# pwd = workspace
foreach {u cm s e rd fs} $csets($c) break
- Log info " @ $s"
+ write 1 cvs "@ $s"
foreach l [split [string trim $cm] \n] {
- Log info " | $l"
+ write 1 cvs "| $l"
}
foreach {f or} $fs {
foreach {op r} $or break
- Log info " -- $op $f $r"
+ write 2 cvs "$op $f $r"
if {$op eq "R"} {
# Remove file from workspace. Prune empty directories.
#
@@ -313,9 +310,9 @@
# contain the full history of the named file. By
# ignoring the problem we however get as much as
# is possible.
- Log info " EE Corrupted archive file. Inaccessible revision."
+ write 0 cvs "EE Corrupted archive file. Inaccessible revision."
continue
}
return -code error $msg
}
@@ -346,9 +343,9 @@
# 0 - ok, 1 - error, 2 - return, 3 - break, 4 - continue
switch -- $code {
0 {}
- 1 { return -errorcode $::errorcode -code error $res }
+ 1 { return -errorcode $::errorCode -errorinfo $::errorInfo -code error $res }
2 {}
3 { return }
4 {}
default {
@@ -373,8 +370,13 @@
proc ::cvs::ntrunk {} {
variable ntrunk
return $ntrunk
+}
+
+proc ::cvs::ncsets {} {
+ variable ncs
+ return $ncs
}
proc ::cvs::uuid {c uuid} {
variable rtree
@@ -471,27 +473,11 @@
foreach {o r} $or break
puts "$b $o $f $r"
}
return
-}
-
-# -----------------------------------------------------------------------------
-# Internal helper commands
-
-proc ::cvs::Log {level text} {
- variable lc
- uplevel #0 [linsert $lc end $level $text]
- return
-}
-
-proc ::cvs::Nop {args} {}
-
-namespace eval ::cvs {
- # Logging callback. No logging by default.
- variable lc ::cvs::Nop
}
# -----------------------------------------------------------------------------
# Ready
package provide cvs 1.0
return