diff options
author | William Joye <wjoye@cfa.harvard.edu> | 2016-10-27 19:39:39 (GMT) |
---|---|---|
committer | William Joye <wjoye@cfa.harvard.edu> | 2016-10-27 19:39:39 (GMT) |
commit | ea28451286d3ea4a772fa174483f9a7a66bb1ab3 (patch) | |
tree | 6ee9d8a7848333a7ceeee3b13d492e40225f8b86 /tcllib/support/devel/sak/readme/readme.tcl | |
parent | b5ca09bae0d6a1edce939eea03594dd56383f2c8 (diff) | |
parent | 7c621da28f07e449ad90c387344f07a453927569 (diff) | |
download | blt-ea28451286d3ea4a772fa174483f9a7a66bb1ab3.zip blt-ea28451286d3ea4a772fa174483f9a7a66bb1ab3.tar.gz blt-ea28451286d3ea4a772fa174483f9a7a66bb1ab3.tar.bz2 |
Merge commit '7c621da28f07e449ad90c387344f07a453927569' as 'tcllib'
Diffstat (limited to 'tcllib/support/devel/sak/readme/readme.tcl')
-rw-r--r-- | tcllib/support/devel/sak/readme/readme.tcl | 448 |
1 files changed, 448 insertions, 0 deletions
diff --git a/tcllib/support/devel/sak/readme/readme.tcl b/tcllib/support/devel/sak/readme/readme.tcl new file mode 100644 index 0000000..165335e --- /dev/null +++ b/tcllib/support/devel/sak/readme/readme.tcl @@ -0,0 +1,448 @@ +# -*- tcl -*- +# (C) 2009 Andreas Kupries <andreas_kupries@users.sourceforge.net> +## +# ### + +package require sak::color +package require sak::review + +namespace eval ::sak::readme { + namespace import ::sak::color::* +} + +# ### + +proc ::sak::readme::usage {} { + package require sak::help + puts stdout \n[sak::help::on readme] + exit 1 +} + +proc ::sak::readme::run {} { + global package_name package_version + + getpackage struct::set struct/sets.tcl + getpackage struct::matrix struct/matrix.tcl + getpackage textutil::adjust textutil/adjust.tcl + + # Future: Consolidate with ... review ... + # Determine which packages are potentially changed, from the set + # of modules touched since the last release, as per the fossil + # repository's commit log. + + foreach {trunk tuid} [sak::review::Leaf trunk] break ;# rid + uuid + foreach {release ruid} [sak::review::YoungestOfTag release] break ;# datetime+uuid + + sak::review::AllParentsAfter $trunk $tuid $release $ruid -> rid uuid { + sak::review::FileSet $rid -> path action { + lappend modifiedm [lindex [file split $path] 1] + } + } + set modifiedm [lsort -unique $modifiedm] + + set issues {} + + # package -> list(version) + set old_version [loadoldv [location_PACKAGES]] + array set releasep [loadpkglist [location_PACKAGES]] + array set currentp [ipackages] + + array set changed {} + foreach p [array names currentp] { + foreach {vlist module} $currentp($p) break + set currentp($p) $vlist + set changed($p) [struct::set contains $modifiedm $module] + } + + LoadNotes + + # Containers for results + struct::matrix NEW ; NEW add columns 4 ; # module, package, version, notes + struct::matrix CHG ; CHG add columns 5 ; # module, package, old/new version, notes + struct::matrix ICH ; ICH add columns 5 ; # module, package, old/new version, notes + struct::matrix CNT ; CNT add columns 5; + set UCH {} + + NEW add row {Module Package {New Version} Comments} + + CHG add row [list {} {} "$package_name $old_version" "$package_name $package_version" {}] + CHG add row {Module Package {Old Version} {New Version} Comments} + + ICH add row [list {} {} "$package_name $old_version" "$package_name $package_version" {}] + ICH add row {Module Package {Old Version} {New Version} Comments} + + set newp {} ; set chgp {} ; set ichp {} + set newm {} ; set chgm {} ; set ichm {} ; set uchm {} + set nm 0 + set np 0 + + # Process all packages in all modules ... + foreach m [lsort -dict [modules]] { + puts stderr ...$m + incr nm + + foreach name [lsort -dict [Provided $m]] { + #puts stderr ......$p + incr np + + # Define list of versions, if undefined so far. + if {![info exists currentp($name)]} { + set currentp($name) {} + } + + # Detect and process new packages. + + if {![info exists releasep($name)]} { + # New package. + foreach v $currentp($name) { + puts stderr .........NEW + NEW add row [list $m $name $v [Note $m $name]] + lappend newm $m + lappend newp $name + } + continue + } + + # The package is not new, but possibly changed. And even + # if the version has not changed it may have been, this is + # indicated by changed(), which is based on the ChangeLog. + + set vequal [struct::set equal $releasep($name) $currentp($name)] + set note [Note $m $name] + + if {$vequal && ($note ne {})} { + if {$note eq "---"} { + # The note declares the package as unchanged. + puts stderr .........UNCHANGED/1 + lappend uchm $m + lappend UCH $name + } else { + # Note for package without version changes => must be invisible + puts stderr .........INVISIBLE-CHANGE + Enter $m $name $note ICH + lappend ichm $m + lappend ichp $name + } + continue + } + + if {!$changed($name) && $vequal} { + # Versions are unchanged, changelog also indicates no + # change. No particular attention here. + + puts stderr .........UNCHANGED/2 + lappend uchm $m + lappend UCH $name + continue + } + + if {$changed($name) && !$vequal} { + # Both changelog and version number indicate a + # change. Small alert, have to classify the order of + # changes. But not if there is a note, this is assumed + # to be the classification. + + if {$note eq {}} { + set note "\t=== Classify changes." + lappend issues [list $m $name "Classify changes"] + } + Enter $m $name $note + + lappend chgm $m + lappend chgp $name + continue + } + + # Changed according to ChangeLog, Version is not. ALERT. + # or: Versions changed, but according to changelog nothing + # in the code. ALERT. + + # Suppress the alert if we have a note, and dispatch per + # the note's contents (some tags are special, instructions + # to us here). + + if {($note eq {})} { + if {$changed($name)} { + # Changed according to ChangeLog, Version is not. ALERT. + set note "\t<<< MISMATCH. Version ==, ChangeLog ++" + } else { + set note "\t<<< MISMATCH. ChangeLog ==, Version ++" + } + + lappend issues [list $m $name [string range $note 5 end]] + } + + Enter $m $name $note + lappend chgm $m + lappend chgp $name + } + } + + # .... process the matrices and others results, make them presentable ... + + set newp [llength [lsort -uniq $newp]] + set newm [llength [lsort -uniq $newm]] + if {$newp} { + CNT add row [list $newp {new packages} in $newm modules] + } + + set chgp [llength [lsort -uniq $chgp]] + set chgm [llength [lsort -uniq $chgm]] + if {$chgp} { + CNT add row [list $chgp {changed packages} in $chgm modules] + } + + set ichp [llength [lsort -uniq $ichp]] + set ichm [llength [lsort -uniq $ichm]] + if {$ichp} { + CNT add row [list $ichp {internally changed packages} in $ichm modules] + } + + set uchp [llength [lsort -uniq $UCH]] + set uchm [llength [lsort -uniq $uchm]] + if {$uchp} { + CNT add row [list $uchp {unchanged packages} in $uchm modules] + } + + CNT add row [list $np {packages, total} in $nm {modules, total}] + + Header Overview + puts "" + if {[CNT rows] > 0} { + puts [Indent " " [Detrail [CNT format 2string]]] + } + puts "" + + if {[NEW rows] > 1} { + Header "New in $package_name $package_version" + puts "" + Sep NEW - [Clean NEW 1 0] + puts [Indent " " [Detrail [NEW format 2string]]] + puts "" + } + + if {[CHG rows] > 2} { + Header "Changes from $package_name $old_version to $package_version" + puts "" + Sep CHG - [Clean CHG 2 0] + puts [Indent " " [Detrail [CHG format 2string]]] + puts "" + } + + if {[ICH rows] > 2} { + Header "Invisible changes (documentation, testsuites)" + puts "" + Sep ICH - [Clean ICH 2 0] + puts [Indent " " [Detrail [ICH format 2string]]] + puts "" + } + + if {[llength $UCH]} { + Header Unchanged + puts "" + puts [Indent " " [textutil::adjust::adjust \ + [join [lsort -dict $UCH] {, }] -length 64]] + } + + variable legend + puts $legend + + if {![llength $issues]} return + + puts stderr [=red "Issues found ([llength $issues])"] + puts stderr " Please run \"./sak.tcl review\" to resolve," + puts stderr " then run \"./sak.tcl readme\" again." + puts stderr Details: + + struct::matrix ISS ; ISS add columns 3 + foreach issue $issues { + foreach {m p w} $issue break + set m " $m" + ISS add row [list $m $p $w] + } + + puts stderr [ISS format 2string] + + + puts stderr [=red "Issues found ([llength $issues])"] + puts stderr " Please run \"./sak.tcl review\" to resolve," + puts stderr " then run \"./sak.tcl readme\" again." + return +} + +proc ::sak::readme::Header {s {sep =}} { + puts $s + puts [string repeat $sep [string length $s]] + return +} + +proc ::sak::readme::Enter {m name note {mat CHG}} { + upvar 1 currentp currentp releasep releasep + + # To handle multiple versions we match the found versions up by + # major version. We assume that we have only one version per major + # version. This allows us to detect changes within each major + # version, new major versions, etc. + + array set om {} ; foreach v $releasep($name) {set om([lindex [split $v .] 0]) $v} + array set cm {} ; foreach v $currentp($name) {set cm([lindex [split $v .] 0]) $v} + + set all [lsort -dict [struct::set union [array names om] [array names cm]]] + + sakdebug { + puts @@@@@@@@@@@@@@@@ + parray om + parray cm + puts all\ $all + puts @@@@@@@@@@@@@@@@ + } + + foreach v $all { + if {[info exists om($v)]} {set ov $om($v)} else {set ov ""} + if {[info exists cm($v)]} {set cv $cm($v)} else {set cv ""} + $mat add row [list $m $name $ov $cv $note] + } + return +} + +proc ::sak::readme::Clean {m start col} { + set n [$m rows] + set marks [list $start] + set last {} + set lastm -1 + set sq 0 + + for {set i $start} {$i < $n} {incr i} { + set str [$m get cell $col $i] + + if {$str eq $last} { + set sq 1 + $m set cell $col $i {} + if {$lastm >= 0} { + #puts stderr "@ $i / <$last> / <$str> / ++ $lastm" + lappend marks $lastm + set lastm -1 + } else { + #puts stderr "@ $i / <$last> / <$str> /" + } + } else { + set last $str + set lastm $i + if {$sq} { + #puts stderr "@ $i / <$last> / <$str> / ++ $i /saved" + lappend marks $i + set sq 0 + } else { + #puts stderr "@ $i / <$last> / <$str> / saved" + } + } + } + return [lsort -uniq -increasing -integer $marks] +} + +proc ::sak::readme::Sep {m char marks} { + + #puts stderr "$m = $marks" + + set n [$m columns] + set sep {} + for {set i 0} {$i < $n} {incr i} { + lappend sep [string repeat $char [expr {2+[$m columnwidth $i]}]] + } + + foreach k [linsert [lsort -decreasing -integer -uniq $marks] 0 end] { + $m insert row $k $sep + } + return +} + +proc ::sak::readme::Indent {pfx text} { + return ${pfx}[join [split $text \n] \n$pfx] +} + +proc ::sak::readme::Detrail {text} { + set res {} + foreach line [split $text \n] { + lappend res [string trimright $line] + } + return [join $res \n] +} + +proc ::sak::readme::Note {m p} { + # Look for a note, and present to caller, if any. + variable notes + #parray notes + set k [list $m $p] + #puts <$k> + if {[info exists notes($k)]} { + return [join $notes($k) { }] + } + return "" +} + +proc ::sak::readme::Provided {m} { + set result {} + foreach {p ___} [ppackages $m] { + lappend result $p + } + return $result +} + +proc ::sak::readme::LoadNotes {} { + global distribution + variable notes + array set notes {} + + catch { + set f [file join $distribution .NOTE] + set f [open $f r] + while {![eof $f]} { + if {[gets $f line] < 0} continue + set line [string trim $line] + if {$line == {}} continue + foreach {k t} $line break + set notes($k) $t + } + close $f + } msg + return +} + +proc ::sak::readme::loadoldv {fname} { + set f [open $fname r] + foreach line [split [read $f] \n] { + set line [string trim $line] + if {[string match @* $line]} { + foreach {__ __ v} $line break + close $f + return $v + } + } + close $f + return -code error {Version not found} +} + +## +# ### + +namespace eval ::sak::readme { + variable legend { +Legend Change Details Comments + ------ ------- --------- + Major API: ** incompatible ** API changes. + + Minor EF : Extended functionality, API. + I : Major rewrite, but no API change + + Patch B : Bug fixes. + EX : New examples. + P : Performance enhancement. + + None T : Testsuite changes. + D : Documentation updates. + } + + variable review {} +} + +package provide sak::readme 1.0 |