f166b0a63c 2007-08-31 aku: #!/bin/sh f166b0a63c 2007-08-31 aku: # -*- tcl -*- \ f166b0a63c 2007-08-31 aku: exec tclsh "$0" ${1+"$@"} f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: # ----------------------------------------------------------------------------- f166b0a63c 2007-08-31 aku: # Make private packages accessible. f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: lappend auto_path [file join [file dirname [info script]] lib] f166b0a63c 2007-08-31 aku: package require rcsparser f166b0a63c 2007-08-31 aku: package require fileutil f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: # ----------------------------------------------------------------------------- f166b0a63c 2007-08-31 aku: # Repository management (CVS) f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: namespace eval ::cvs { f166b0a63c 2007-08-31 aku: variable base ; set base {} ; # Repository toplevel directory. f166b0a63c 2007-08-31 aku: variable npaths ; array set npaths {} ; # path -> actual path mapping. f166b0a63c 2007-08-31 aku: variable rpaths ; array set rpaths {} ; # path -> rcs file mapping. f166b0a63c 2007-08-31 aku: variable cmsg ; array set cmsg {} ; # Cache of commit messages. f166b0a63c 2007-08-31 aku: } f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: proc ::cvs::hextime {hex} { f166b0a63c 2007-08-31 aku: set t 0 f166b0a63c 2007-08-31 aku: foreach d [string map { f166b0a63c 2007-08-31 aku: a 10 b 11 c 12 d 13 e 14 f 15 f166b0a63c 2007-08-31 aku: A 10 B 11 C 12 D 13 E 14 F 15 f166b0a63c 2007-08-31 aku: } [split $hex {}]] { f166b0a63c 2007-08-31 aku: set t [expr {($t << 4) + $d}];#horner f166b0a63c 2007-08-31 aku: } f166b0a63c 2007-08-31 aku: return $t f166b0a63c 2007-08-31 aku: } f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: proc ::cvs::at {path} { f166b0a63c 2007-08-31 aku: variable base $path f166b0a63c 2007-08-31 aku: return f166b0a63c 2007-08-31 aku: } f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: proc ::cvs::cmsg {path rev} { f166b0a63c 2007-08-31 aku: variable cmsg f166b0a63c 2007-08-31 aku: set key [list $path $rev] f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: if {![info exists cmsg($key)]} { f166b0a63c 2007-08-31 aku: set rcs [cvs::rcsfile $path] f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: #puts stderr "scan $path => $rcs" f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: array set p [::rcsparser::process $rcs] f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: foreach {r msg} $p(commit) { f166b0a63c 2007-08-31 aku: set cmsg([list $path $r]) $msg f166b0a63c 2007-08-31 aku: } f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: if {![info exists cmsg($key)]} { f166b0a63c 2007-08-31 aku: return -code error "Bogus revision $rev of file $path" f166b0a63c 2007-08-31 aku: } f166b0a63c 2007-08-31 aku: } f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: return $cmsg($key) f166b0a63c 2007-08-31 aku: } f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: proc ::cvs::norm {path} { f166b0a63c 2007-08-31 aku: variable npaths f166b0a63c 2007-08-31 aku: if {![info exists npaths($path)]} { f166b0a63c 2007-08-31 aku: set npaths($path) [NormFile $path] f166b0a63c 2007-08-31 aku: } f166b0a63c 2007-08-31 aku: return $npaths($path) f166b0a63c 2007-08-31 aku: } f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: proc ::cvs::NormFile {path} { f166b0a63c 2007-08-31 aku: variable base f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: set f $base/$path,v f166b0a63c 2007-08-31 aku: if {[::file exists $f]} {return $path} f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: set hd [::file dirname $path] f166b0a63c 2007-08-31 aku: set tl [::file tail $path] f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: set f $base/$hd/Attic/$tl,v f166b0a63c 2007-08-31 aku: if {[::file exists $f]} {return $path} f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: # Bad. The dir can be truncated, i.e. it may not be an exact f166b0a63c 2007-08-31 aku: # subdirectory of base, but deeper inside, with parents between it f166b0a63c 2007-08-31 aku: # and base left out. Example (from the tcllib history file): f166b0a63c 2007-08-31 aku: # f166b0a63c 2007-08-31 aku: # M3f1d1245|afaupell|<remote>|ipentry|1.2|ChangeLog f166b0a63c 2007-08-31 aku: # The correct path is 'tklib/modules/ipentry'. f166b0a63c 2007-08-31 aku: # This we have to resolve too. f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: # normalize dance - old fileutil, modern fileutil (cvs head) doesn't do that. f166b0a63c 2007-08-31 aku: set bx [file normalize $base] f166b0a63c 2007-08-31 aku: foreach c [fileutil::findByPattern $bx -glob $hd] { f166b0a63c 2007-08-31 aku: set cx [fileutil::stripPath $bx $c] f166b0a63c 2007-08-31 aku: set c $base/$cx f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: set f $c/$tl,v f166b0a63c 2007-08-31 aku: if {[::file exists $f]} {return $cx/$tl} f166b0a63c 2007-08-31 aku: set f $c/Attic/$tl,v f166b0a63c 2007-08-31 aku: if {[::file exists $f]} {return $cx/$tl} f166b0a63c 2007-08-31 aku: } f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: puts stderr <$f> f166b0a63c 2007-08-31 aku: return -code error "Unable to locate actual file for $path" f166b0a63c 2007-08-31 aku: } f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: proc ::cvs::rcsfile {path} { f166b0a63c 2007-08-31 aku: variable rpaths f166b0a63c 2007-08-31 aku: if {![info exists rpaths($path)]} { f166b0a63c 2007-08-31 aku: set rpaths($path) [RcsFile $path] f166b0a63c 2007-08-31 aku: } f166b0a63c 2007-08-31 aku: return $rpaths($path) f166b0a63c 2007-08-31 aku: } f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: proc ::cvs::RcsFile {path} { f166b0a63c 2007-08-31 aku: variable base f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: set f $base/$path,v f166b0a63c 2007-08-31 aku: if {[::file exists $f]} {return $f} f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: set hd [::file dirname $path] f166b0a63c 2007-08-31 aku: set tl [::file tail $path] f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: set f $base/$hd/Attic/$tl,v f166b0a63c 2007-08-31 aku: if {[::file exists $f]} {return $f} f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: # We do not have truncated directories here, assuming that only f166b0a63c 2007-08-31 aku: # norm paths are fed into this command. f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: if 0 { f166b0a63c 2007-08-31 aku: # Bad. The dir can be truncated, i.e. it may not be an exact f166b0a63c 2007-08-31 aku: # subdirectory of base, but deeper inside, with parents f166b0a63c 2007-08-31 aku: # between it and base left out. Example (from the tcllib f166b0a63c 2007-08-31 aku: # history file): f166b0a63c 2007-08-31 aku: # f166b0a63c 2007-08-31 aku: # M3f1d1245|afaupell|<remote>|ipentry|1.2|ChangeLog The f166b0a63c 2007-08-31 aku: # correct path is 'tklib/modules/ipentry'. This we have to f166b0a63c 2007-08-31 aku: # resolve too. f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: # normalize dance - old fileutil, modern fileutil (cvs head) f166b0a63c 2007-08-31 aku: # doesn't do that. f166b0a63c 2007-08-31 aku: set bx [file normalize $base] f166b0a63c 2007-08-31 aku: foreach c [fileutil::findByPattern $bx -glob $hd] { f166b0a63c 2007-08-31 aku: set c $base/[fileutil::stripPath $bx $c] f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: set f $c/$tl,v f166b0a63c 2007-08-31 aku: if {[::file exists $f]} {return $f} f166b0a63c 2007-08-31 aku: set f $c/Attic/$tl,v f166b0a63c 2007-08-31 aku: if {[::file exists $f]} {return $f} f166b0a63c 2007-08-31 aku: } f166b0a63c 2007-08-31 aku: } f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: puts stderr <$f> f166b0a63c 2007-08-31 aku: return -code error "Unable to locate rcs file for $path" f166b0a63c 2007-08-31 aku: } f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: proc ::cvs::history {} { f166b0a63c 2007-08-31 aku: variable base f166b0a63c 2007-08-31 aku: return $base/CVSROOT/history f166b0a63c 2007-08-31 aku: } f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: # ----------------------------------------------------------------------------- f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: # ----------------------------------------------------------------------------- f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: cvs::at [lindex $argv 0] f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: #puts [::cvs::norm ipentry/ChangeLog] f166b0a63c 2007-08-31 aku: #exit f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: #changeset state f166b0a63c 2007-08-31 aku: global cs csf f166b0a63c 2007-08-31 aku: array set cs { f166b0a63c 2007-08-31 aku: start {} end {} cm {} f166b0a63c 2007-08-31 aku: usr {} dt {} f166b0a63c 2007-08-31 aku: } f166b0a63c 2007-08-31 aku: array set csf {} f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: proc rh {} { f166b0a63c 2007-08-31 aku: global argv cs csf repo f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: set f [open [cvs::history] r] f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: while {[gets $f line] >= 0} { f166b0a63c 2007-08-31 aku: # Decode line f166b0a63c 2007-08-31 aku: foreach {op usr _ dir rev file} [split [string trim $line] |] break f166b0a63c 2007-08-31 aku: set ts [cvs::hextime [string range $op 1 end]] f166b0a63c 2007-08-31 aku: set op [string index $op 0] f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: # Filter out irrelevant parts f166b0a63c 2007-08-31 aku: if {$op eq "O"} continue ; # checkout f166b0a63c 2007-08-31 aku: if {$op eq "F"} continue ; # release f166b0a63c 2007-08-31 aku: if {$op eq "T"} continue ; # rtag f166b0a63c 2007-08-31 aku: if {$op eq "W"} continue ; # delete on update f166b0a63c 2007-08-31 aku: if {$op eq "U"} continue ; # update f166b0a63c 2007-08-31 aku: if {$op eq "P"} continue ; # update by patch f166b0a63c 2007-08-31 aku: #if {$op eq "G"} continue ; # merge on update - FUTURE - identifies mergepoints. f166b0a63c 2007-08-31 aku: if {$op eq "C"} continue ; # conflict on update - s.a. f166b0a63c 2007-08-31 aku: if {$op eq "E"} continue ; # export f166b0a63c 2007-08-31 aku: # left types f166b0a63c 2007-08-31 aku: # M: commit f166b0a63c 2007-08-31 aku: # A: addition f166b0a63c 2007-08-31 aku: # R: removal f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: set df $dir/$file f166b0a63c 2007-08-31 aku: if {[newcs $op $usr $ts $rev df cause]} { f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: # NOTE 1: ChangeSets containing CVSROOT => remove such files. f166b0a63c 2007-08-31 aku: # NOTE 2: Empty changesets, ignore. f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: #commit f166b0a63c 2007-08-31 aku: csstats f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: if {$cause eq "cmsg"} { f166b0a63c 2007-08-31 aku: set msg f166b0a63c 2007-08-31 aku: } else { f166b0a63c 2007-08-31 aku: set msg "" f166b0a63c 2007-08-31 aku: } f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: if {$cs(end) ne ""} { f166b0a63c 2007-08-31 aku: puts =============================/$cause\ delta\ [expr {$ts - $cs(end)}] f166b0a63c 2007-08-31 aku: } else { f166b0a63c 2007-08-31 aku: puts =============================/$cause f166b0a63c 2007-08-31 aku: } f166b0a63c 2007-08-31 aku: csclear f166b0a63c 2007-08-31 aku: } f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: # Note: newcs normalizes df, in case the log information is f166b0a63c 2007-08-31 aku: # bogus. So the df here may be different from before newcs f166b0a63c 2007-08-31 aku: csadd $op $usr $ts $rev $df f166b0a63c 2007-08-31 aku: # apply modification to workspace f166b0a63c 2007-08-31 aku: } f166b0a63c 2007-08-31 aku: } f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: proc newcs {op usr ts rev dfv rv} { f166b0a63c 2007-08-31 aku: global cs csf f166b0a63c 2007-08-31 aku: upvar 1 $rv reason $dfv df f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: # Logic to detect when a new change set begins. A new change sets f166b0a63c 2007-08-31 aku: # has started with the current entry when the entry f166b0a63c 2007-08-31 aku: # f166b0a63c 2007-08-31 aku: # 1. is for a different user than the last. f166b0a63c 2007-08-31 aku: # 2. tries to add a file to the changeset which is already part of it. f166b0a63c 2007-08-31 aku: # 3.is on the trunk, and the last on a branch, or vice versa. f166b0a63c 2007-08-31 aku: # 4. the current entry has a different commit message than the last. f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: set df [cvs::norm $df] f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: # User changed f166b0a63c 2007-08-31 aku: if {$usr ne $cs(usr)} { f166b0a63c 2007-08-31 aku: set reason user f166b0a63c 2007-08-31 aku: return 1 f166b0a63c 2007-08-31 aku: } f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: # File is already in the changeset f166b0a63c 2007-08-31 aku: if {[info exists csf($df)]} { f166b0a63c 2007-08-31 aku: set reason file f166b0a63c 2007-08-31 aku: return 1 f166b0a63c 2007-08-31 aku: } f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: # last/current are different regarding trunk/branch f166b0a63c 2007-08-31 aku: set depth [llength [split $rev .]] f166b0a63c 2007-08-31 aku: if {($cs(lastd) == 2) != ($depth == 2)} { f166b0a63c 2007-08-31 aku: set reason branch f166b0a63c 2007-08-31 aku: return 1 f166b0a63c 2007-08-31 aku: } f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: # Commit message changed f166b0a63c 2007-08-31 aku: if {[cvs::cmsg $cs(lastf) $cs(lastr)] ne [cvs::cmsg $df $rev]} { f166b0a63c 2007-08-31 aku: set reason cmsg f166b0a63c 2007-08-31 aku: return 1 f166b0a63c 2007-08-31 aku: } f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: # Same changeset f166b0a63c 2007-08-31 aku: return 0 f166b0a63c 2007-08-31 aku: } f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: proc csclear {} { f166b0a63c 2007-08-31 aku: global cs csf f166b0a63c 2007-08-31 aku: array set cs {start {} usr {} end {} dt {}} f166b0a63c 2007-08-31 aku: array unset csf * f166b0a63c 2007-08-31 aku: return f166b0a63c 2007-08-31 aku: } f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: proc csadd {op usr ts rev df} { f166b0a63c 2007-08-31 aku: global cs csf f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: if {$cs(usr) eq ""} {set cs(usr) $usr} f166b0a63c 2007-08-31 aku: if {$cs(start) eq ""} { f166b0a63c 2007-08-31 aku: set cs(start) $ts f166b0a63c 2007-08-31 aku: } else { f166b0a63c 2007-08-31 aku: lappend cs(dt) [expr {$ts - $cs(end)}] f166b0a63c 2007-08-31 aku: } f166b0a63c 2007-08-31 aku: set cs(end) $ts f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: set csf($df) [list $op $rev] f166b0a63c 2007-08-31 aku: set cs(lastf) $df f166b0a63c 2007-08-31 aku: set cs(lastr) $rev f166b0a63c 2007-08-31 aku: set cs(lastd) [llength [split $rev .]] f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: puts [list $op [clock format $ts] $usr $rev $df] f166b0a63c 2007-08-31 aku: return f166b0a63c 2007-08-31 aku: } f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: proc csstats {} { f166b0a63c 2007-08-31 aku: global cs csf f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: if {$cs(start) eq ""} return f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: puts "files: [array size csf]" f166b0a63c 2007-08-31 aku: puts "delta: $cs(dt)" f166b0a63c 2007-08-31 aku: puts "range: [expr {$cs(end) - $cs(start)}] seconds" f166b0a63c 2007-08-31 aku: return f166b0a63c 2007-08-31 aku: } f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: rh f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: exit f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: ========================================= f166b0a63c 2007-08-31 aku: new fossil f166b0a63c 2007-08-31 aku: new fossil workspace f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: open history f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: foreach line { f166b0a63c 2007-08-31 aku: ignore unwanted lines f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: accumulate changesets data f166b0a63c 2007-08-31 aku: new change-set => commit and continue f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: current branch and branch of new change different ? f166b0a63c 2007-08-31 aku: => move fossil workspace to proper revision. f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: apply change to workspace f166b0a63c 2007-08-31 aku: uncommitted f166b0a63c 2007-08-31 aku: } f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: if uncommitted => commit f166b0a63c 2007-08-31 aku: delete workspace f166b0a63c 2007-08-31 aku: copy fossil repo to destination f166b0a63c 2007-08-31 aku: ========================================= f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: Not dealt with in outline: branches, tags, merging f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: ========================================= f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: complexities f166b0a63c 2007-08-31 aku: - apply to workspace f166b0a63c 2007-08-31 aku: - remove simple, direct translation f166b0a63c 2007-08-31 aku: - add => requires extraction of indicated revision from ,v f166b0a63c 2007-08-31 aku: - modify => see above (without add following) f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: - ,v file => Can be the either dir/file,v, or dir/Attic/file,v f166b0a63c 2007-08-31 aku: Both ? Priority ? f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: - How to detect changes on branches ? f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: - Have to keep knowledge of which branches went there. f166b0a63c 2007-08-31 aku: => save change-sets information, + uuid in fossil f166b0a63c 2007-08-31 aku: => need only the leaves of each branch, and of branch points. f166b0a63c 2007-08-31 aku: => better keep all until complete. f166b0a63c 2007-08-31 aku: => uuid can be gotten from 'manifest.uuid' in workspace. f166b0a63c 2007-08-31 aku: - keep tag information ? (symbolics) f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: ========================================= f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: CVSROOT=ORIGIN f166b0a63c 2007-08-31 aku: f166b0a63c 2007-08-31 aku: cvs -d ORIGIN checkout -r REV FILE f166b0a63c 2007-08-31 aku: Extract specific revision of a specific file. f166b0a63c 2007-08-31 aku: -q, -Q quietness
File Annotation