Tcl Library Source Code

[comment {-*- tcl -*- doctools manpage}]
[manpage_begin doctools::changelog n 1.1]
[copyright {2003-2013 Andreas Kupries <[email protected]>}]
[moddesc   {Documentation tools}]
[titledesc {Processing text in Emacs ChangeLog format}]
[category  {Documentation tools}]
[require Tcl 8.2]
[require textutil]
[require doctools::changelog [opt 1.1]]
[description]

This package provides Tcl commands for the processing and reformatting
of text in the [file ChangeLog] format generated by [syscmd emacs].


[section API]

		...
	    }
	}
	{...}
    }
}]


[call [cmd ::doctools::changelog::flatten] [arg entries]]

This command converts a list of entries as generated by
[cmd change::scan] above into a simpler list of plain
text blocks each containing all the information of a
single entry.

[call [cmd ::doctools::changelog::toDoctools] [arg title] [arg module] [arg version] [arg entries]]

This command converts the pre-parsed ChangeLog [arg entries] as
generated by the command [cmd ::doctools::changelog::scan] into a
document in [term doctools] format and returns it as the result of the
command.

package require Tcl 8.2
package require textutil

namespace eval ::doctools {}
namespace eval ::doctools::changelog {
    namespace export scan flatten merge toDoctools
}

proc ::doctools::changelog::flatten {entries} {
    # Reformat the entries into a simpler structure.

    set result {}
    foreach entry $entries {
	foreach {date user sections} $entry break
	set f {}
	set t {}
	foreach sec $sections {
	    foreach {files text} $sec break
	    foreach file $files { lappend f $file }
	    append t \n $text
	}

	set t [textutil::adjust::indent [textutil::adjust $t] "        "]
	lappend result \
	    "$date $user\n    [join $f ", "]:\n$t"
    }

    return $result
}

# ::doctools::changelog::scan --
#
#	Scan a ChangeLog generated by 'emacs' and extract the relevant information.
#
# Result
#	List of entries. Each entry is a list of three elements. These
#	are date, author, and commentary. The commentary is a list of
#	sections. Each section is a list of two elements, a list of
#	files, and the associated text.


proc ::doctools::changelog::scan {text} {
    set text [split $text \n]
    set n    [llength $text]

    set entries [list]
    set clist [list]

    lappend linebuffer [q manpage_end]
    return [join $linebuffer \n]
}

#------------------------------------
# Module initialization

package provide doctools::changelog 1.1

if {![package vsatisfies [package provide Tcl] 8.2]} {return}
package ifneeded doctools            1.4.13 [list source [file join $dir doctools.tcl]]
package ifneeded doctools::toc       1.1.3  [list source [file join $dir doctoc.tcl]]
package ifneeded doctools::idx       1.0.4  [list source [file join $dir docidx.tcl]]
package ifneeded doctools::cvs       1      [list source [file join $dir cvs.tcl]]
package ifneeded doctools::changelog 1.1    [list source [file join $dir changelog.tcl]]

proc __provided {} {
    array set packages [ppackages]
    nparray packages
    return
}

























































































































































proc checkmod {} {
    global argv
    package require sak::util
    return [sak::util::checkModules argv]
}

# -------------------------------------------------------------------------

	set fh [open $f w] ; puts -nonewline $fh $notice$data ; close $fh
    }

    gd-gen-packages
    return
}

















# --------------------------------------------------------------
# Documentation

proc __desc  {} {
    global argv ; if {![checkmod]} return
    array set pd [getpdesc]

        lmodules         - See above, however one module per line
        imodules         - Return list of modules known to the installer.
        critcl-modules   - Return a list of modules with critcl enhancements.

        packages         - Return indexed packages in the bundle, plus versions,
                           one package per line. Extracted from the
                           package indices found in the modules.

        provided         - Return list and versions of provided packages
                           (in contrast to indexed).




        critcl ?module?  - Build a critcl module [default is @@].

        bench ?opt? ?module..?
                         - Run benchmark scripts (*.bench).

                Options: -throwerrors 0|1  Propagate errors if set.

        gentip55 - Generate a TIP55-style DESCRIPTION.txt file.
        yml      - Generate a YAML description file.

        release name sf-user-id
                 - Marks the current state of all files as a new
                   release. This updates all ChangeLog's, and
                   regenerates the contents of PACKAGES

    readme -- Generate a readme listing changes to modules and packages.

    sak readme

    	This command compares the current state of the modules and
    	packages and against information from the last release
    	(support/releases/PACKAGES) and generates a README.txt listing
    	the relevant changes (new modules/packages, package version
    	changes, unchanged packages).

	The generated README is written to stdout.

	This is a support command for the release manager.

# -*- tcl -*-
# (C) 2009 Andreas Kupries <[email protected]>
##
# ###

package require sak::color

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

    set issues {}

    # package -> list(version)
    set old_version    [loadoldv [location_PACKAGES]]
    array set releasep [loadpkglist [location_PACKAGES]]
    array set currentp [ipackages]

    # Determine which packages are potentially changed, from the set

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

	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

        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

# -*- tcl -*-
# Implementation of 'review'.

# Available variables
# * argv  - Cmdline arguments
# * base  - Location of sak.tcl = Top directory of Tcllib distribution
# * cbase - Location of all files relevant to this command.
# * sbase - Location of all files supporting the SAK.

package require sak::util
package require sak::review

set raw  0
set log  0
set stem {}
set tclv {}

if {[llength $argv]} {
    sak::review::usage
}

sak::review::run

##
# ###

    review -- Interactively review changed modules and packages

    sak review

    	This command scans the system for changes and then enters
	a sub-shell where the caller can interactively review and
	tag these changes.

	This is a support command for the release manager.

if {![package vsatisfies [package provide Tcl] 8.2]} return
package ifneeded sak::review 1.0 [list source [file join $dir review.tcl]]

# -*- tcl -*-
# # ## ### ##### ######## ############# ##################### 
# (C) 2013 Andreas Kupries <[email protected]>
##
# ###

package require linenoise
package require sak::color

getpackage fileutil                 fileutil/fileutil.tcl
getpackage doctools::changelog      doctools/changelog.tcl
getpackage struct::set              struct/sets.tcl
getpackage term::ansi::send         term/ansi/send.tcl

namespace eval ::sak::review {
    namespace import ::sak::color::*
}

# ###

proc ::sak::review::usage {} {
    package require sak::help
    puts stdout \n[sak::help::on review]
    exit 1
}

proc ::sak::review::run {} {
    Scan ; Review
    return
}

# # ## ### ##### ######## ############# ##################### 
## Phase I. Determine which modules require a review.
## A derivative of the code in ::sak::readme.

proc ::sak::review::Scan {} {
    global distribution
    variable review

    Banner "Scan for modules and packages to review..."

    # Determine which packages are potentially changed and therefore
    # in need of review, from the set of modules touched since the
    # last release, as per their changelog ... (future: md5sum of
    # files in a module, and file/package association).

    array set review {}

    # package -> list(version)
    set old_version    [loadoldv [location_PACKAGES]]
    array set releasep [loadpkglist [location_PACKAGES]]
    array set currentp [ipackages]

    set modifiedm [modified-modules]
    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

    set np 0
    # Process all packages in all modules ...
    foreach m [lsort -dict [modules]] {
	Next ; Progress " $m"
	foreach name [lsort -dict [Provided $m]] {
	    #Next ; Progress "... $m/$name"
	    # Define list of versions, if undefined so far.
	    if {![info exists currentp($name)]} {
		set currentp($name) {}
	    }

	    # Detect new packages. Ignore them.

	    if {![info exists releasep($name)]} {
		#Progress " /new"
		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]

	    # Detect packages whose versions are unchanged, and whose
	    # changelog also indicates no change. Ignore these too.

	    if {!$changed($name) && $vequal} {
		#Progress " /not changed"
		continue
	    }

	    # Now look for packages where both changelog and version
	    # number indicate a change. These we have to review.

	    if {$changed($name) && !$vequal} {
		lappend review($m) [list $name classify $note]
		#Progress " [=cya classify]"
		incr np
		continue
	    }

	    # What remains are packages which are changed according to
	    # their changelog, but their version disagrees. Or the
	    # reverse. These need a big review to see who is right.
	    # We may have to bump their version information, not just
	    # classify changes. Of course, in modules with multiple
	    # packages it is quite possible to be unchanged and the
	    # changelog refers to the siblings.

	    lappend review($m) [list $name mismatch $note]
	    #Progress " [=cya mismatch]"
	    incr np
	}
    }

    Close

    # Postprocessing phase, pull in all relevant changelogs.

    foreach m [array names review] {
	set clog [fileutil::cat $distribution/modules/$m/ChangeLog]
	set entries {}
	foreach e [doctools::changelog::scan $clog] {
	    if {[string match -nocase "*Released and tagged*" $e]} break
	    lappend entries $e
	}
	set entries [doctools::changelog::flatten $entries]

	set review($m) [list $review($m) [join $entries \n\n]]
    }

    set review() $np
    return
}

# see also readme
proc ::sak::review::Provided {m} {
    set result {}
    foreach {p ___} [ppackages $m] {
	lappend result $p
    }
    return $result
}

# see also readme
proc ::sak::review::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}
}

proc ::sak::review::Progress {text} {
    puts -nonewline stdout $text
    flush stdout
    return
}

proc ::sak::review::Next {} {
    # erase to end of line, then move back to start of line.
    term::ansi::send::eeol
    puts -nonewline stdout \r
    flush stdout
    return
}

proc ::sak::review::Close {} {
    puts stdout ""
    return
}

proc ::sak::review::Clear {} {
    term::ansi::send::clear
    return
}

proc ::sak::review::Banner {text} {
    Clear
    puts stdout "\n <<SAK Tcllib: $text>>\n"
    return
}

proc ::sak::review::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 $notes($k)
    }
    return ""
}

proc ::sak::review::SaveNote {at t} {
    global distribution
    set    f [open [file join $distribution .NOTE] a]
    puts  $f [list $at $t]
    close $f
    return
}

proc ::sak::review::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
    }

    return
}

# # ## ### ##### ######## ############# ##################### 
## Phase II. Interactively review the changes packages.

# Namespace variables
#
# review      : array, database of all modules, keyed by name
# nm          : number of modules
# modules     : list of module names, keys to --> review
# current     : index in -> modules, current module
# np          : number of packages in current module
# packages    : list of packages in current module
# currentp    : index in --> packages
# im          : 1+current  | indices for display
# ip          : 1+currentp |
# end         : array : module (name) --> index of last package
# stop        : repl exit flag
# map         : array : text -> module/package index
# commands    : proper commands
# allcommands : commands + namesof(map)
# 

proc ::sak::review::Review {} {
    variable review   ;# table of everything to review
    variable nm       ;# number of modules
    variable modules  ;# list of module names, sorted
    variable stop 0   ;# repl exit flag
    variable end      ;# last module/package index.

    variable navcommands
    variable allcommands ;# list of all commands, sorted
    variable commands    ;# list of proper commands, sorted
    variable map         ;# map from package names to module/package indices.
    variable prefix

    Banner "Packages to review: $review()"
    unset   review()

    set nm [array size review]
    if {!$nm} return

    set modules [lsort -dict [array names review]]

    # Map package name --> module/package index.
    set im 0
    foreach m $modules {
	foreach {packages clog} $review($m) break
	set ip 0
	foreach p $packages {
	    set end($im) $ip
	    set end($m) $ip
	    set end() [list $im $ip]
	    foreach {name what tags} $p break
	    lappend map(@$name)    [list $im $ip]
	    lappend map(@$name/$m) [list $im $ip]
	    incr ip
	}
	incr im
    }

    # Drop amibigous mappings, and fill the list of commands.
    foreach k [array names map] {
	# Skip already dropped keys (extended forms).
	if {![info exists map($k)]} continue
	if {[llength $map($k)] < 2} {
	    set map($k) [lindex $map($k) 0]
	    # Drop extended form, not needed.
	    array unset map $k/*
	} else {
	    unset map($k)
	}
    }

    # Map module name --> module/package index
    # If not preempted by package mapping.
    set im -1
    foreach m $modules {
	incr im
	if {[info exists map(@$m)]} continue
	set map(@$m) [list $im 0]
    }

    # Map command prefix -> full command.

    array set prefix {}
    foreach c [info commands ::sak::review::C_*] {
	set c [string range [namespace tail $c] 2 end]
	lappend commands    $c
	lappend allcommands $c
	set buf {}
	foreach ch [split $c {}] {
	    append buf $ch
	    lappend prefix($buf) $c
	}
    }

    foreach c [array names map] {
	lappend allcommands $c
	set buf {}
	foreach ch [split $c {}] {
	    append buf $ch
	    lappend prefix($buf) $c
	}
    }

    set commands    [lsort -dict $commands]
    set allcommands [lsort -dict $allcommands]
    set navcommands [lsort -dict [array names map]]

    # Enter the REPL
    Goto {0 0} 1
    linenoise::cmdloop \
	-history   1 \
	-exit      ::sak::review::Exit \
	-continued ::sak::review::Continued \
	-prompt1   ::sak::review::Prompt \
	-complete  ::sak::review::Complete \
	-dispatch  ::sak::review::Dispatch
    return
}

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

proc ::sak::review::RefreshDisplay {} {
    variable m
    variable im
    variable nm
    variable clog
    variable what

    Banner "\[$im/$nm\] [=blue [string totitle $what]] [=green $m]"
    puts "| [join [split $clog \n] \n|]\n"
    return
}

proc ::sak::review::Exit {} {
    variable stop
    return  $stop
}

proc ::sak::review::Continued {buffer} {
    return 0
}

proc ::sak::review::Prompt {} {
    variable ip
    variable np
    variable name
    variable tags

    return "\[$ip/$np\] $name ($tags): "
}

proc ::sak::review::Complete {line} {
    variable allcommands
    if {$line eq {}} {
	return $allcommands
    } elseif {[llength $line] == 1} {
	set r {}
	foreach c $allcommands {
	    if {![string match ${line}* $c]} continue
	    lappend r $c
	}
	return $r
    } else {
	return {}
    }
}

proc ::sak::review::Dispatch {line} {
    variable prefix
    variable map

    if {$line == ""} { set line next }

    set cmd [lindex $line 0]

    if {![info exists prefix($cmd)]} {
	return -code error "Unknown command $cmd, use help or ? to list them"
    } elseif {[llength $prefix($cmd)] > 1} {
	return -code error "Ambigous prefix \"$cmd\", expected [join $prefix($cmd) {, }]"
    }

    # Map prefix to actual command
    set line [lreplace $line 0 0 $prefix($cmd)]

    # Run command.
    if {[info exists map($cmd)]} {
	Goto $map($cmd)
	return
    }
    eval C_$line
}

proc ::sak::review::Goto {loc {skip 0}} {
    variable review
    variable modules
    variable packages
    variable clog
    variable current
    variable currentp
    variable nm
    variable np
    variable at
    variable tags
    variable what
    variable name

    variable m
    variable p
    variable ip
    variable im

    foreach {current currentp} $loc break

    puts "Goto ($current/$currentp)"

    set m [lindex $modules $current]
    foreach {packages clog} $review($m) break

    set np [llength $packages]
    set p  [lindex  $packages $currentp]

    foreach {name what tags} $p break
    set at [list $m $name]

    set im [expr {1+$current}]
    set ip [expr {1+$currentp}]

    if {$skip && ([llength $tags] ||
		  ($tags == "---"))} {
	C_next
    } else {
	RefreshDisplay
    }
    return
}

proc ::sak::review::C_exit {} { variable stop 1 }
proc ::sak::review::C_quit {} { variable stop 1 }

proc ::sak::review::C_? {} { C_help }
proc ::sak::review::C_help {} {
    variable commands
    return [join $commands {, }]
}

proc ::sak::review::C_@? {} { C_@help }
proc ::sak::review::C_@help {} {
    variable navcommands
    return [join $navcommands {, }]
}

proc ::sak::review::C_@start {} { Goto {0 0} }
proc ::sak::review::C_@0     {} { Goto {0 0} }
proc ::sak::review::C_@end   {} { variable end ; Goto $end() }

proc ::sak::review::C_next {} {
    variable tags
    variable current
    variable currentp

    C_step 0

    set stop @$current/$currentp
    while {[llength $tags] ||
	   ($tags == "---")} {
	C_step 0
	if {"@$current/$currentp" == "$stop"} break
    }

    RefreshDisplay
    return
}

proc ::sak::review::C_step {{refresh 1}} {
    variable nm
    variable np
    variable current
    variable currentp
    variable packages

    incr currentp
    if {$currentp >= $np} {
	# skip to next module, first package
	incr current
	if {$current >= $nm} {
	    # skip to first module
	    set current 0
	}
	set currentp 0

    }
    Goto [list $current $currentp]
    return
}

proc ::sak::review::C_prev {} {
    variable end
    variable nm
    variable np
    variable current
    variable currentp
    variable packages

    incr currentp -1
    if {$currentp < 0} {
	# skip to previous module, last package
	incr current -1
	if {$current < 0} {
	    # skip to back to last module
	    set current [expr {$nm - 1}]
	}
	set currentp $end($current)
    }
    Goto [list $current $currentp]
    return
}

# Commands to add/remove tags, clear set, replace set

proc ::sak::review::C_feature {} { +T EF }
proc ::sak::review::C_test    {} { +T T }
proc ::sak::review::C_doc     {} { +T D }
proc ::sak::review::C_bug     {} { +T B }
proc ::sak::review::C_perf    {} { +T P }
proc ::sak::review::C_example {} { +T EX }
proc ::sak::review::C_api     {} { +T API }
proc ::sak::review::C_impl    {} { +T I }

proc ::sak::review::C_-feature {} { -T EF }
proc ::sak::review::C_-test    {} { -T T }
proc ::sak::review::C_-doc     {} { -T D }
proc ::sak::review::C_-bug     {} { -T B }
proc ::sak::review::C_-perf    {} { -T P }
proc ::sak::review::C_-example {} { -T EX }
proc ::sak::review::C_-api     {} { -T API }
proc ::sak::review::C_-impl    {} { -T I }

proc ::sak::review::C_---   {} { =T --- }
proc ::sak::review::C_clear {} { =T --- }
#proc ::sak::review::C_cn {} { C_clear ; C_next }

proc ::sak::review::+T {tag} {
    variable tags
    if {[lsearch -exact $tags $tag] >= 0} {
	RefreshDisplay
	return
    }
    =T [linsert $tags end $tag]
    return
}

proc ::sak::review::-T {tag} {
    variable tags
    set pos [lsearch -exact $tags $tag]
    if {$pos < 0} {
	RefreshDisplay
	return
    }
    =T [lreplace $tags $pos $pos]
    return
}

proc ::sak::review::=T {newtags} {
    variable review
    variable clog
    variable packages
    variable currentp
    variable p
    variable m
    variable at
    variable name
    variable what
    variable tags

    if {([llength $newtags] > 1) &&
	([set pos [lsearch -exact $newtags ---]] >= 0)} {
	# Drop --- if there are other tags.
	set newtags [lreplace $newtags $pos $pos]
    }

    set tags       [lsort -dict $newtags]
    set p          [list $name $what $newtags]
    set packages   [lreplace $packages $currentp $currentp $p]
    set review($m) [list $packages $clog]

    SaveNote $at $tags
    RefreshDisplay
    return
}

proc ::sak::review::?T {} {
    variable tags
    return $tags
}

##
# ###

namespace eval ::sak::review {}

package provide sak::review 1.0

review		Interactively review changes since the last release.