diff options
Diffstat (limited to 'tcllib/support/devel/sak/validate')
-rw-r--r-- | tcllib/support/devel/sak/validate/cmd.tcl | 70 | ||||
-rw-r--r-- | tcllib/support/devel/sak/validate/help.txt | 53 | ||||
-rw-r--r-- | tcllib/support/devel/sak/validate/manpages.tcl | 464 | ||||
-rw-r--r-- | tcllib/support/devel/sak/validate/pkgIndex.tcl | 6 | ||||
-rw-r--r-- | tcllib/support/devel/sak/validate/syntax.tcl | 668 | ||||
-rw-r--r-- | tcllib/support/devel/sak/validate/testsuites.tcl | 512 | ||||
-rw-r--r-- | tcllib/support/devel/sak/validate/topic.txt | 1 | ||||
-rw-r--r-- | tcllib/support/devel/sak/validate/validate.tcl | 37 | ||||
-rw-r--r-- | tcllib/support/devel/sak/validate/versions.tcl | 258 |
9 files changed, 2069 insertions, 0 deletions
diff --git a/tcllib/support/devel/sak/validate/cmd.tcl b/tcllib/support/devel/sak/validate/cmd.tcl new file mode 100644 index 0000000..ca2ddc9 --- /dev/null +++ b/tcllib/support/devel/sak/validate/cmd.tcl @@ -0,0 +1,70 @@ +# -*- tcl -*- +# Implementation of 'validate'. + +# 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::validate + +set raw 0 +set log 0 +set stem {} +set tclv {} + +if {[llength $argv]} { + # First argument may be a command. + set cmd [lindex $argv 0] + if {![catch { + package require sak::validate::$cmd + } msg]} { + set argv [lrange $argv 1 end] + } else { + set cmd all + } + + # Now process any possible options (-v, -l, --log). + + while {[string match -* [set opt [lindex $argv 0]]]} { + switch -exact -- $opt { + -v { + set raw 1 + set argv [lrange $argv 1 end] + } + -l - --log { + set log 1 + set stem [lindex $argv 1] + set argv [lrange $argv 2 end] + } + -t - --tcl { + set tclv [lindex $argv 1] + set argv [lrange $argv 2 end] + } + default { + sak::validate::usage Unknown option "\"$opt\"" + } + } + } +} else { + set cmd all +} + +# At last now handle all remaining arguments as module specifications. +if {![sak::util::checkModules argv]} return + +if {$log} { set raw 0 } + +array set mode { + 00 short + 01 log + 10 verbose + 11 _impossible_ +} + +sak::validate::$cmd $argv $mode($raw$log) $stem $tclv + +## +# ### diff --git a/tcllib/support/devel/sak/validate/help.txt b/tcllib/support/devel/sak/validate/help.txt new file mode 100644 index 0000000..6ded891 --- /dev/null +++ b/tcllib/support/devel/sak/validate/help.txt @@ -0,0 +1,53 @@ + + validate -- Validate modules and packages + + sak validate ?-v? ?-l|--log STEM? ?MODULE ...? + sak validate manpages ?-v? ?-l|--log STEM? ?MODULE ...? + sak validate versions ?-v? ?-l|--log STEM? ?MODULE ...? + sak validate testsuites ?-v? ?-l|--log STEM? ?MODULE ...? + sak validate syntax ?-v? ?-l|--log STEM? ?MODULE ...? + + Validate one or more aspects of the specified modules and the + packages they contain. If no module is specified all modules + are validated. If no aspect was specified all possible aspects + are validated. + + By default the output from a validation run is animated + feedback of the progress made, plus summarized color-coded + results. If -v is specified the actual log is returned + instead. + + If a log STEM is specified the extended log normally activated + via -v is written to STEM.log while the user is provided with + the regular feedback during execution. Usage of the -l switch + overides -v. + + The system is currently able to validate the following aspects + of the module and package sources: + + manpages + Reports modules/packages without documentation, and + modules/packages which have syntactically flawed + documentation. The second part is identical to + + sak doc validate + + versions + Reports modules and packages with mismatches between + 'package ifneeded' and 'package provided' commands. + + testsuites + Report modules and packages without testsuites. + + Note that this command is _not_ actually executing the + testsuites. That is done via + + sak test run ... + + See its documentation (sak help test) for more + information. + + syntax + Scan modules and packages using various tools + statically checking Tcl syntax, and report their + outputs. diff --git a/tcllib/support/devel/sak/validate/manpages.tcl b/tcllib/support/devel/sak/validate/manpages.tcl new file mode 100644 index 0000000..fbb0e86 --- /dev/null +++ b/tcllib/support/devel/sak/validate/manpages.tcl @@ -0,0 +1,464 @@ +# -*- tcl -*- +# (C) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net> +## +# ### + +package require sak::animate +package require sak::feedback +package require sak::color + +getpackage textutil::repeat textutil/repeat.tcl +getpackage doctools doctools/doctools.tcl + +namespace eval ::sak::validate::manpages { + namespace import ::textutil::repeat::blank + namespace import ::sak::color::* + namespace import ::sak::feedback::! + namespace import ::sak::feedback::>> + namespace import ::sak::feedback::+= + namespace import ::sak::feedback::= + namespace import ::sak::feedback::=| + namespace import ::sak::feedback::log + namespace import ::sak::feedback::summary + rename summary sum +} + +# ### + +proc ::sak::validate::manpages {modules mode stem tclv} { + manpages::run $modules $mode $stem $tclv + manpages::summary + return +} + +proc ::sak::validate::manpages::run {modules mode stem tclv} { + sak::feedback::init $mode $stem + sak::feedback::first log "\[ Documentation \] ===============================================" + sak::feedback::first unc "\[ Documentation \] ===============================================" + sak::feedback::first fail "\[ Documentation \] ===============================================" + sak::feedback::first warn "\[ Documentation \] ===============================================" + sak::feedback::first miss "\[ Documentation \] ===============================================" + sak::feedback::first none "\[ Documentation \] ===============================================" + + # Preprocessing of module names to allow better formatting of the + # progress output, i.e. vertically aligned columns + + # Per module we can distinguish the following levels of + # documentation completeness and validity + + # Completeness: + # - No package has documentation + # - Some, but not all packages have documentation + # - All packages have documentation. + # + # Validity, restricted to the set packages which have documentation: + # - Documentation has errors and warnings + # - Documentation has errors, but no warnings. + # - Documentation has no errors, but warnings. + # - Documentation has neither errors nor warnings. + + # Progress report per module: Packages it is working on. + # Summary at module level: + # - Number of packages, number of packages with documentation, + # - Number of errors, number of warnings. + + # Full log: + # - Lists packages without documentation. + # - Lists packages with errors/warnings. + # - Lists the exact errors/warnings per package, and location. + + # Global preparation: Pull information about all packages and the + # modules they belong to. + + ::doctools::new dt -format desc -deprecated 1 + + Count $modules + MapPackages + + InitCounters + foreach m $modules { + # Skip tcllibc shared library, not a module. + if {[string equal $m tcllibc]} continue + + InitModuleCounters + ! + log "@@ Module $m" + Head $m + + # Per module: Find all doctools manpages inside and process + # them. We get errors, warnings, and determine the package(s) + # they may belong to. + + # Per package: Have they doc files claiming them? After that, + # are doc files left over (i.e. without a package)? + + ProcessPages $m + ProcessPackages $m + ProcessUnclaimed + ModuleSummary + } + + dt destroy + return +} + +proc ::sak::validate::manpages::summary {} { + Summary + return +} + +# ### + +proc ::sak::validate::manpages::ProcessPages {m} { + !claims + dt configure -module $m + foreach f [glob -nocomplain [file join [At $m] *.man]] { + ProcessManpage $f + } + return +} + +proc ::sak::validate::manpages::ProcessManpage {f} { + =file $f + dt configure -file $f + + if {[catch { + dt format [get_input $f] + } msg]} { + +e $msg + } else { + foreach {pkg _ _} $msg { +claim $pkg } + } + + set warnings [dt warnings] + if {![llength $warnings]} return + + foreach msg $warnings { +w $msg } + return +} + +proc ::sak::validate::manpages::ProcessPackages {m} { + !used + if {![HasPackages $m]} return + + foreach p [ThePackages $m] { + +pkg $p + if {[claimants $p]} { + +doc $p + } else { + nodoc $p + } + } + return +} + +proc ::sak::validate::manpages::ProcessUnclaimed {} { + variable claims + if {![array size claims]} return + foreach p [lsort -dict [array names claims]] { + foreach fx $claims($p) { +u $fx } + } + return +} + +### + +proc ::sak::validate::manpages::=file {f} { + variable current [file tail $f] + = "$current ..." + return +} + +### + +proc ::sak::validate::manpages::!claims {} { + variable claims + array unset claims * + return +} + +proc ::sak::validate::manpages::+claim {pkg} { + variable current + variable claims + lappend claims($pkg) $current + return +} + +proc ::sak::validate::manpages::claimants {pkg} { + variable claims + expr { [info exists claims($pkg)] && [llength $claims($pkg)] } +} + + +### + +proc ::sak::validate::manpages::!used {} { + variable used + array unset used * + return +} + +proc ::sak::validate::manpages::+use {pkg} { + variable used + variable claims + foreach fx $claims($pkg) { set used($fx) . } + unset claims($pkg) + return +} + +### + +proc ::sak::validate::manpages::MapPackages {} { + variable pkg + array unset pkg * + + ! + += Package + foreach {pname pdata} [ipackages] { + = "$pname ..." + foreach {pver pmodule} $pdata break + lappend pkg($pmodule) $pname + } + ! + =| {Packages mapped ...} + return +} + +proc ::sak::validate::manpages::HasPackages {m} { + variable pkg + expr { [info exists pkg($m)] && [llength $pkg($m)] } +} + +proc ::sak::validate::manpages::ThePackages {m} { + variable pkg + return [lsort -dict $pkg($m)] +} + +### + +proc ::sak::validate::manpages::+pkg {pkg} { + variable mtotal ; incr mtotal + variable total ; incr total + return +} + +proc ::sak::validate::manpages::+doc {pkg} { + variable mhavedoc ; incr mhavedoc + variable havedoc ; incr havedoc + = "$pkg Ok" + +use $pkg + return +} + +proc ::sak::validate::manpages::nodoc {pkg} { + = "$pkg Bad" + log "@@ WARN No documentation: $pkg" + return +} + +### + +proc ::sak::validate::manpages::+w {msg} { + variable mwarnings ; incr mwarnings + variable warnings ; incr warnings + variable current + foreach {a b c} [split $msg \n] break + log "@@ WARN $current: [Trim $a] [Trim $b] [Trim $c]" + return +} + +proc ::sak::validate::manpages::+e {msg} { + variable merrors ; incr merrors + variable errors ; incr errors + variable current + log "@@ ERROR $current $msg" + return +} + +proc ::sak::validate::manpages::+u {f} { + variable used + if {[info exists used($f)]} return + variable munclaimed ; incr munclaimed + variable unclaimed ; incr unclaimed + set used($f) . + log "@@ WARN Unclaimed documentation file: $f" + return +} + +### + +proc ::sak::validate::manpages::Count {modules} { + variable maxml 0 + ! + foreach m [linsert $modules 0 Module] { + = "M $m" + set l [string length $m] + if {$l > $maxml} {set maxml $l} + } + =| "Validate documentation (existence, errors, warnings) ..." + return +} + +proc ::sak::validate::manpages::Head {m} { + variable maxml + += ${m}[blank [expr {$maxml - [string length $m]}]] + return +} + +### + +proc ::sak::validate::manpages::InitModuleCounters {} { + variable mtotal 0 + variable mhavedoc 0 + variable munclaimed 0 + variable merrors 0 + variable mwarnings 0 + return +} + +proc ::sak::validate::manpages::ModuleSummary {} { + variable mtotal + variable mhavedoc + variable munclaimed + variable merrors + variable mwarnings + + set complete [F $mhavedoc]/[F $mtotal] + set not "! [F [expr {$mtotal - $mhavedoc}]]" + set err "E [F $merrors]" + set warn "W [F $mwarnings]" + set unc "U [F $munclaimed]" + + if {$munclaimed} { + set unc [=cya $unc] + >> unc + } + if {!$mhavedoc && $mtotal} { + set complete [=red $complete] + set not [=red $not] + >> none + } elseif {$mhavedoc < $mtotal} { + set complete [=yel $complete] + set not [=yel $not] + >> miss + } + if {$merrors} { + set err [=red $err] + set warn [=yel $warn] + >> fail + } elseif {$mwarnings} { + set warn [=yel $warn] + >> warn + } + + =| "~~ $complete $not $unc $err $warn" + return +} + +### + +proc ::sak::validate::manpages::InitCounters {} { + variable total 0 + variable havedoc 0 + variable unclaimed 0 + variable errors 0 + variable warnings 0 + return +} + +proc ::sak::validate::manpages::Summary {} { + variable total + variable havedoc + variable unclaimed + variable errors + variable warnings + + set tot [F $total] + set doc [F $havedoc] + set udc [F [expr {$total - $havedoc}]] + + set unc [F $unclaimed] + set per [format %6.2f [expr {$havedoc*100./$total}]] + set uper [format %6.2f [expr {($total - $havedoc)*100./$total}]] + set err [F $errors] + set wrn [F $warnings] + + if {$errors} { set err [=red $err] } + if {$warnings} { set wrn [=yel $wrn] } + if {$unclaimed} { set unc [=cya $unc] } + + if {!$havedoc && $total} { + set doc [=red $doc] + set udc [=red $udc] + } elseif {$havedoc < $total} { + set doc [=yel $doc] + set udc [=yel $udc] + } + + sum "" + sum "Documentation statistics" + sum "#Packages: $tot" + sum "#Documented: $doc (${per}%)" + sum "#Undocumented: $udc (${uper}%)" + sum "#Unclaimed: $unc" + sum "#Errors: $err" + sum "#Warnings: $wrn" + return +} + +### + +proc ::sak::validate::manpages::F {n} { format %6d $n } + +proc ::sak::validate::manpages::Trim {text} { + regsub {^[^:]*:} $text {} text + return [string trim $text] +} + +### + +proc ::sak::validate::manpages::At {m} { + global distribution + return [file join $distribution modules $m] +} + +# ### + +namespace eval ::sak::validate::manpages { + # Max length of module names and patchlevel information. + variable maxml 0 + + # Counters across all modules + variable total 0 ; # Number of packages overall. + variable havedoc 0 ; # Number of packages with documentation. + variable unclaimed 0 ; # Number of manpages not claimed by a specific package. + variable errors 0 ; # Number of errors found in all documentation. + variable warnings 0 ; # Number of warnings found in all documentation. + + # Same counters, per module. + variable mtotal 0 + variable mhavedoc 0 + variable munclaimed 0 + variable merrors 0 + variable mwarnings 0 + + # Name of currently processed manpage + variable current "" + + # Map from packages to files claiming to document them. + variable claims + array set claims {} + + # Set of files taken by packages, as array + variable used + array set used {} + + # Map from modules to packages contained in them + variable pkg + array set pkg {} +} + +## +# ### + +package provide sak::validate::manpages 1.0 diff --git a/tcllib/support/devel/sak/validate/pkgIndex.tcl b/tcllib/support/devel/sak/validate/pkgIndex.tcl new file mode 100644 index 0000000..d6ad128 --- /dev/null +++ b/tcllib/support/devel/sak/validate/pkgIndex.tcl @@ -0,0 +1,6 @@ +if {![package vsatisfies [package provide Tcl] 8.2]} return +package ifneeded sak::validate 1.0 [list source [file join $dir validate.tcl]] +package ifneeded sak::validate::manpages 1.0 [list source [file join $dir manpages.tcl]] +package ifneeded sak::validate::versions 1.0 [list source [file join $dir versions.tcl]] +package ifneeded sak::validate::testsuites 1.0 [list source [file join $dir testsuites.tcl]] +package ifneeded sak::validate::syntax 1.0 [list source [file join $dir syntax.tcl]] diff --git a/tcllib/support/devel/sak/validate/syntax.tcl b/tcllib/support/devel/sak/validate/syntax.tcl new file mode 100644 index 0000000..24e06d2 --- /dev/null +++ b/tcllib/support/devel/sak/validate/syntax.tcl @@ -0,0 +1,668 @@ +# -*- tcl -*- +# (C) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net> +## +# ### + +package require sak::animate +package require sak::feedback +package require sak::color + +getpackage textutil::repeat textutil/repeat.tcl +getpackage doctools doctools/doctools.tcl + +namespace eval ::sak::validate::syntax { + namespace import ::textutil::repeat::blank + namespace import ::sak::color::* + namespace import ::sak::feedback::! + namespace import ::sak::feedback::>> + namespace import ::sak::feedback::+= + namespace import ::sak::feedback::= + namespace import ::sak::feedback::=| + namespace import ::sak::feedback::log + namespace import ::sak::feedback::summary + rename summary sum +} + +# ### + +proc ::sak::validate::syntax {modules mode stem tclv} { + syntax::run $modules $mode $stem $tclv + syntax::summary + return +} + +proc ::sak::validate::syntax::run {modules mode stem tclv} { + sak::feedback::init $mode $stem + sak::feedback::first log "\[ Syntax \] ======================================================" + sak::feedback::first unc "\[ Syntax \] ======================================================" + sak::feedback::first fail "\[ Syntax \] ======================================================" + sak::feedback::first warn "\[ Syntax \] ======================================================" + sak::feedback::first miss "\[ Syntax \] ======================================================" + sak::feedback::first none "\[ Syntax \] ======================================================" + + # Preprocessing of module names to allow better formatting of the + # progress output, i.e. vertically aligned columns + + # Per module we can distinguish the following levels of + # syntactic completeness and validity. + + # Rule completeness + # - No package has pcx rules + # - Some, but not all packages have pcx rules + # - All packages have pcx rules + # + # Validity. Not of the pcx rules, but of the files in the + # packages. + # - Package has errors and warnings + # - Package has errors, but no warnings. + # - Package has no errors, but warnings. + # - Package has neither errors nor warnings. + + # Progress report per module: Modules and packages it is working on. + # Summary at module level: + # - Number of packages, number of packages with pcx rules + # - Number of errors, number of warnings. + + # Full log: + # - Lists packages without pcx rules. + # - Lists packages with errors/warnings. + # - Lists the exact errors/warnings per package, and location. + + # Global preparation: Pull information about all packages and the + # modules they belong to. + + Setup + Count $modules + MapPackages + + InitCounters + foreach m $modules { + # Skip tcllibc shared library, not a module. + if {[string equal $m tcllibc]} continue + + InitModuleCounters + ! + log "@@ Module $m" + Head $m + + # Per module: Find all syntax definition (pcx) files inside + # and process them. Further find all the Tcl files and process + # them as well. We get errors, warnings, and determine the + # package(s) they may belong to. + + # Per package: Have they pcx files claiming them? After that, + # are pcx files left over (i.e. without a package)? + + ProcessAllPCX $m + ProcessPackages $m + ProcessUnclaimed + ProcessTclSources $m $tclv + ModuleSummary + } + + Shutdown + return +} + +proc ::sak::validate::syntax::summary {} { + Summary + return +} + +# ### + +proc ::sak::validate::syntax::ProcessAllPCX {m} { + !claims + foreach f [glob -nocomplain [file join [At $m] *.pcx]] { + ProcessOnePCX $f + } + return +} + +proc ::sak::validate::syntax::ProcessOnePCX {f} { + =file $f + + if {[catch { + Scan [get_input $f] + } msg]} { + +e $msg + } else { + +claim $msg + } + + return +} + +proc ::sak::validate::syntax::ProcessPackages {m} { + !used + if {![HasPackages $m]} return + + foreach p [ThePackages $m] { + +pkg $p + if {[claimants $p]} { + +pcx $p + } else { + nopcx $p + } + } + return +} + +proc ::sak::validate::syntax::ProcessUnclaimed {} { + variable claims + if {![array size claims]} return + foreach p [lsort -dict [array names claims]] { + foreach fx $claims($p) { +u $fx } + } + return +} + +proc ::sak::validate::syntax::ProcessTclSources {m tclv} { + variable tclchecker + if {![llength $tclchecker]} return + + foreach t [modtclfiles $m] { + # Ignore TeX files. + if {[string equal [file extension $t] .tex]} continue + + =file $t + set cmd [Command $t $tclv] + if {[catch {Close [Process [open |$cmd r+]]} msg]} { + if {[string match {*child process exited abnormally*} $msg]} continue + +e $msg + } + } + return +} + +### + +proc ::sak::validate::syntax::Setup {} { + variable ip [interp create] + + # Make it mostly empty (We keep the 'set' command). + + foreach n [interp eval $ip [list ::namespace children ::]] { + if {[string equal $n ::tcl]} continue + interp eval $ip [list namespace delete $n] + } + foreach c [interp eval $ip [list ::info commands]] { + if {[string equal $c set]} continue + if {[string equal $c if]} continue + if {[string equal $c rename]} continue + if {[string equal $c namespace]} continue + interp eval $ip [list ::rename $c {}] + } + + if {![package vsatisfies [package present Tcl] 8.6]} { + interp eval $ip [list ::namespace delete ::tcl] + } + interp eval $ip [list ::rename namespace {}] + interp eval $ip [list ::rename rename {}] + + foreach m { + pcx::register unknown + } { + interp alias $ip $m {} ::sak::validate::syntax::PCX/[string map {:: _} $m] $ip + } + return +} + +proc ::sak::validate::syntax::Shutdown {} { + variable ip + interp delete $ip + return +} + +proc ::sak::validate::syntax::Scan {data} { + variable ip + variable pcxpackage + while {1} { + if {[catch { + $ip eval $data + } msg]} { + if {[string match {can't read "*": no such variable} $msg]} { + regexp {can't read "(.*)": no such variable} $msg -> var + log "@@ + variable \"$var\"" + $ip eval [list set $var {}] + continue + } + return -code error $msg + } + break + } + return $pcxpackage +} + +proc ::sak::validate::syntax::PCX/pcx_register {ip pkg} { + variable pcxpackage $pkg + return +} + +proc ::sak::validate::syntax::PCX/unknown {ip args} { + return 0 +} + +### + +proc ::sak::validate::syntax::Process {pipe} { + variable current + set dst log + while {1} { + if {[eof $pipe]} break + if {[gets $pipe line] < 0} break + + set tline [string trim $line] + if {[string equal $tline ""]} continue + + if {[string match scanning:* $tline]} { + log $line + continue + } + if {[string match checking:* $tline]} { + log $line + continue + } + if {[regexp {^([^:]*):(\d+) \(([^)]*)\) (.*)$} $tline -> path at code detail]} { + = "$current $at $code" + set dst code,$code + if {[IsError $code]} { + +e $line + } else { + +w $line + } + } + log $line $dst + } + return $pipe +} + +proc ::sak::validate::syntax::IsError {code} { + variable codetype + variable codec + if {[info exists codec($code)]} { + return $codec($code) + } + + foreach {p t} $codetype { + if {![string match $p $code]} continue + set codec($code) $t + return $t + } + + # We assume that codetype contains a default * pattern as the last + # entry, capturing all unknown codes. + +e INTERNAL + exit +} + +proc ::sak::validate::syntax::Command {t tclv} { + # Unix. Construction of the pipe to run the tclchecker against a + # single tcl file. + + set cmd [Driver $tclv] + lappend cmd $t + + #lappend cmd >@ stdout 2>@ stderr + #puts <<$cmd>> + + return $cmd +} + +proc ::sak::validate::syntax::Close {pipe} { + close $pipe + return +} + +proc ::sak::validate::syntax::Driver {tclv} { + variable tclchecker + set cmd $tclchecker + + if {$tclv ne {}} { lappend cmd -use Tcl-$tclv } + + # Make all syntax definition files we may have available to the + # checker for higher accuracy of its output. + foreach m [modules] { lappend cmd -pcx [At $m] } + + # Memoize + proc ::sak::validate::syntax::Driver {tclv} [list return $cmd] + return $cmd +} + +### + +proc ::sak::validate::syntax::=file {f} { + variable current [file tail $f] + = "$current ..." + return +} + +### + +proc ::sak::validate::syntax::!claims {} { + variable claims + array unset claims * + return +} + +proc ::sak::validate::syntax::+claim {pkg} { + variable current + variable claims + lappend claims($pkg) $current + return +} + +proc ::sak::validate::syntax::claimants {pkg} { + variable claims + expr { [info exists claims($pkg)] && [llength $claims($pkg)] } +} + + +### + +proc ::sak::validate::syntax::!used {} { + variable used + array unset used * + return +} + +proc ::sak::validate::syntax::+use {pkg} { + variable used + variable claims + foreach fx $claims($pkg) { set used($fx) . } + unset claims($pkg) + return +} + +### + +proc ::sak::validate::syntax::MapPackages {} { + variable pkg + array unset pkg * + + ! + += Package + foreach {pname pdata} [ipackages] { + = "$pname ..." + foreach {pver pmodule} $pdata break + lappend pkg($pmodule) $pname + } + ! + =| {Packages mapped ...} + return +} + +proc ::sak::validate::syntax::HasPackages {m} { + variable pkg + expr { [info exists pkg($m)] && [llength $pkg($m)] } +} + +proc ::sak::validate::syntax::ThePackages {m} { + variable pkg + return [lsort -dict $pkg($m)] +} + +### + +proc ::sak::validate::syntax::+pkg {pkg} { + variable mtotal ; incr mtotal + variable total ; incr total + return +} + +proc ::sak::validate::syntax::+pcx {pkg} { + variable mhavepcx ; incr mhavepcx + variable havepcx ; incr havepcx + = "$pkg Ok" + +use $pkg + return +} + +proc ::sak::validate::syntax::nopcx {pkg} { + = "$pkg Bad" + log "@@ WARN No syntax definition: $pkg" + return +} + +### + +proc ::sak::validate::syntax::+w {msg} { + variable mwarnings ; incr mwarnings + variable warnings ; incr warnings + variable current + foreach {a b c} [split $msg \n] break + log "@@ WARN $current: [Trim $a] [Trim $b] [Trim $c]" + return +} + +proc ::sak::validate::syntax::+e {msg} { + variable merrors ; incr merrors + variable errors ; incr errors + variable current + log "@@ ERROR $current $msg" + return +} + +proc ::sak::validate::syntax::+u {f} { + variable used + if {[info exists used($f)]} return + variable munclaimed ; incr munclaimed + variable unclaimed ; incr unclaimed + set used($f) . + log "@@ WARN Unclaimed syntax definition file: $f" + return +} + +### + +proc ::sak::validate::syntax::Count {modules} { + variable maxml 0 + ! + foreach m [linsert $modules 0 Module] { + = "M $m" + set l [string length $m] + if {$l > $maxml} {set maxml $l} + } + =| "Validate syntax (code, and API definitions) ..." + return +} + +proc ::sak::validate::syntax::Head {m} { + variable maxml + += ${m}[blank [expr {$maxml - [string length $m]}]] + return +} + +### + +proc ::sak::validate::syntax::InitModuleCounters {} { + variable mtotal 0 + variable mhavepcx 0 + variable munclaimed 0 + variable merrors 0 + variable mwarnings 0 + return +} + +proc ::sak::validate::syntax::ModuleSummary {} { + variable mtotal + variable mhavepcx + variable munclaimed + variable merrors + variable mwarnings + variable tclchecker + + set complete [F $mhavepcx]/[F $mtotal] + set not "! [F [expr {$mtotal - $mhavepcx}]]" + set err "E [F $merrors]" + set warn "W [F $mwarnings]" + set unc "U [F $munclaimed]" + + if {$munclaimed} { + set unc [=cya $unc] + >> unc + } + if {!$mhavepcx && $mtotal} { + set complete [=red $complete] + set not [=red $not] + >> none + } elseif {$mhavepcx < $mtotal} { + set complete [=yel $complete] + set not [=yel $not] + >> miss + } + if {[llength $tclchecker]} { + if {$merrors} { + set err " [=red $err]" + set warn " [=yel $warn]" + >> fail + } elseif {$mwarnings} { + set err " $err" + set warn " [=yel $warn]" + >> warn + } else { + set err " $err" + set warn " $warn" + } + } else { + set err "" + set warn "" + } + + =| "~~ $complete $not $unc$err$warn" + return +} + +### + +proc ::sak::validate::syntax::InitCounters {} { + variable total 0 + variable havepcx 0 + variable unclaimed 0 + variable errors 0 + variable warnings 0 + return +} + +proc ::sak::validate::syntax::Summary {} { + variable total + variable havepcx + variable unclaimed + variable errors + variable warnings + variable tclchecker + + set tot [F $total] + set doc [F $havepcx] + set udc [F [expr {$total - $havepcx}]] + + set unc [F $unclaimed] + set per [format %6.2f [expr {$havepcx*100./$total}]] + set uper [format %6.2f [expr {($total - $havepcx)*100./$total}]] + set err [F $errors] + set wrn [F $warnings] + + if {$errors} { set err [=red $err] } + if {$warnings} { set wrn [=yel $wrn] } + if {$unclaimed} { set unc [=cya $unc] } + + if {!$havepcx && $total} { + set doc [=red $doc] + set udc [=red $udc] + } elseif {$havepcx < $total} { + set doc [=yel $doc] + set udc [=yel $udc] + } + + if {[llength $tclchecker]} { + set sfx " ($tclchecker)" + } else { + set sfx " ([=cya {No tclchecker available}])" + } + + sum "" + sum "Syntax statistics$sfx" + sum "#Packages: $tot" + sum "#Syntax def: $doc (${per}%)" + sum "#No syntax: $udc (${uper}%)" + sum "#Unclaimed: $unc" + if {[llength $tclchecker]} { + sum "#Errors: $err" + sum "#Warnings: $wrn" + } + return +} + +### + +proc ::sak::validate::syntax::F {n} { format %6d $n } + +proc ::sak::validate::syntax::Trim {text} { + regsub {^[^:]*:} $text {} text + return [string trim $text] +} + +### + +proc ::sak::validate::syntax::At {m} { + global distribution + return [file join $distribution modules $m] +} + +# ### + +namespace eval ::sak::validate::syntax { + # Max length of module names and patchlevel information. + variable maxml 0 + + # Counters across all modules + variable total 0 ; # Number of packages overall. + variable havepcx 0 ; # Number of packages with syntax definition (pcx) files. + variable unclaimed 0 ; # Number of PCX files not claimed by a specific package. + variable errors 0 ; # Number of errors found in all code. + variable warnings 0 ; # Number of warnings found in all code. + + # Same counters, per module. + variable mtotal 0 + variable mhavepcx 0 + variable munclaimed 0 + variable merrors 0 + variable mwarnings 0 + + # Name of currently processed syntax definition or code file + variable current "" + + # Map from packages to files claiming to define the syntax of their API. + variable claims + array set claims {} + + # Set of files taken by packages, as array + variable used + array set used {} + + # Map from modules to packages contained in them + variable pkg + array set pkg {} + + # Transient storage used while collecting packages per syntax definition. + variable pcxpackage {} + variable ip {} + + # Location of the tclchecker used to perform syntactic validation. + variable tclchecker [auto_execok tclchecker] + + # Patterns for separation of errors from warnings + variable codetype { + warn* 0 + nonPort* 0 + pkgUnchecked 0 + pkgVConflict 0 + * 1 + } + variable codec ; array set codec {} +} + +## +# ### + +package provide sak::validate::syntax 1.0 diff --git a/tcllib/support/devel/sak/validate/testsuites.tcl b/tcllib/support/devel/sak/validate/testsuites.tcl new file mode 100644 index 0000000..71ea694 --- /dev/null +++ b/tcllib/support/devel/sak/validate/testsuites.tcl @@ -0,0 +1,512 @@ +# -*- tcl -*- +# (C) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net> +## +# ### + +package require sak::animate +package require sak::feedback +package require sak::color + +getpackage textutil::repeat textutil/repeat.tcl +getpackage interp interp/interp.tcl + +namespace eval ::sak::validate::testsuites { + namespace import ::textutil::repeat::blank + namespace import ::sak::color::* + namespace import ::sak::feedback::! + namespace import ::sak::feedback::>> + namespace import ::sak::feedback::+= + namespace import ::sak::feedback::= + namespace import ::sak::feedback::=| + namespace import ::sak::feedback::log + namespace import ::sak::feedback::summary + rename summary sum +} + +# ### + +proc ::sak::validate::testsuites {modules mode stem tclv} { + testsuites::run $modules $mode $stem $tclv + testsuites::summary + return +} + +proc ::sak::validate::testsuites::run {modules mode stem tclv} { + sak::feedback::init $mode $stem + sak::feedback::first log "\[ Testsuites \] ==================================================" + sak::feedback::first unc "\[ Testsuites \] ==================================================" + sak::feedback::first fail "\[ Testsuites \] ==================================================" + sak::feedback::first miss "\[ Testsuites \] ==================================================" + sak::feedback::first none "\[ Testsuites \] ==================================================" + + # Preprocessing of module names to allow better formatting of the + # progress output, i.e. vertically aligned columns + + # Per module we can distinguish the following levels of + # testsuite completeness: + # - No package has a testsuite + # - Some, but not all packages have a testsuite + # - All packages have a testsuite. + # + # Validity of the testsuites is not done here. It requires + # execution, see 'sak test run ...'. + + # Progress report per module: Packages it is working on. + # Summary at module level: + # - Number of packages, number of packages with testsuites, + + # Full log: + # - Lists packages without testsuites. + + # Global preparation: Pull information about all packages and the + # modules they belong to. + + Setup + Count $modules + MapPackages + + InitCounters + foreach m $modules { + # Skip tcllibc shared library, not a module. + if {[string equal $m tcllibc]} continue + + InitModuleCounters + ! + log "@@ Module $m" + Head $m + + # Per module: Find all testsuites in the module and process + # them. We determine the package(s) they may belong to. + + # Per package: Have they .test files claiming them? After + # that, are .test files left over (i.e. without a package)? + + ProcessTestsuites $m + ProcessPackages $m + ProcessUnclaimed + ModuleSummary + } + + Shutdown + return +} + +proc ::sak::validate::testsuites::summary {} { + Summary + return +} + +# ### + +proc ::sak::validate::testsuites::ProcessTestsuites {m} { + !claims + foreach f [glob -nocomplain [file join [At $m] *.test]] { + ProcessTestsuite $f + } + return +} + +proc ::sak::validate::testsuites::ProcessTestsuite {f} { + variable testing + =file $f + + if {[catch { + Scan [get_input $f] + } msg]} { + +e $msg + } else { + foreach p $testing { +claim $p } + } + + + return +} + +proc ::sak::validate::testsuites::Setup {} { + variable ip [interp create] + + # Make it mostly empty (We keep the 'set' command). + + foreach n [interp eval $ip [list ::namespace children ::]] { + if {[string equal $n ::tcl]} continue + interp eval $ip [list namespace delete $n] + } + foreach c [interp eval $ip [list ::info commands]] { + if {[string equal $c set]} continue + if {[string equal $c if]} continue + if {[string equal $c rename]} continue + if {[string equal $c namespace]} continue + interp eval $ip [list ::rename $c {}] + } + + if {![package vsatisfies [package present Tcl] 8.6]} { + interp eval $ip [list ::namespace delete ::tcl] + } + interp eval $ip [list ::rename namespace {}] + interp eval $ip [list ::rename rename {}] + + foreach m { + testing unknown useLocal useLocalKeep useAccel + } { + interp alias $ip $m {} ::sak::validate::testsuites::Process/$m $ip + } + return +} + +proc ::sak::validate::testsuites::Shutdown {} { + variable ip + interp delete $ip + return +} + +proc ::sak::validate::testsuites::Scan {data} { + variable ip + while {1} { + if {[catch { + $ip eval $data + } msg]} { + if {[string match {can't read "*": no such variable} $msg]} { + regexp {can't read "(.*)": no such variable} $msg -> var + log "@@ + variable \"$var\"" + $ip eval [list set $var {}] + continue + } + return -code error $msg + } + break + } + return +} + +proc ::sak::validate::testsuites::Process/useTcllibC {ip args} { + return 0 +} + +proc ::sak::validate::testsuites::Process/unknown {ip args} { + return 0 +} + +proc ::sak::validate::testsuites::Process/testing {ip script} { + variable testing {} + $ip eval $script + return -code return +} + +proc ::sak::validate::testsuites::Process/useLocal {ip f p args} { + variable testing + lappend testing $p + return +} + +proc ::sak::validate::testsuites::Process/useLocalKeep {ip f p args} { + variable testing + lappend testing $p + return +} + +proc ::sak::validate::testsuites::Process/useAccel {ip _ f p} { + variable testing + lappend testing $p + return +} + +proc ::sak::validate::testsuites::ProcessPackages {m} { + !used + if {![HasPackages $m]} return + + foreach p [ThePackages $m] { + +pkg $p + if {[claimants $p]} { + +tests $p + } else { + notests $p + } + } + return +} + +proc ::sak::validate::testsuites::ProcessUnclaimed {} { + variable claims + if {![array size claims]} return + foreach p [lsort -dict [array names claims]] { + foreach fx $claims($p) { +u $fx } + } + return +} + +### + +proc ::sak::validate::testsuites::=file {f} { + variable current [file tail $f] + = "$current ..." + return +} + +### + +proc ::sak::validate::testsuites::!claims {} { + variable claims + array unset claims * + return +} + +proc ::sak::validate::testsuites::+claim {pkg} { + variable current + variable claims + lappend claims($pkg) $current + return +} + +proc ::sak::validate::testsuites::claimants {pkg} { + variable claims + expr { [info exists claims($pkg)] && [llength $claims($pkg)] } +} + + +### + +proc ::sak::validate::testsuites::!used {} { + variable used + array unset used * + return +} + +proc ::sak::validate::testsuites::+use {pkg} { + variable used + variable claims + foreach fx $claims($pkg) { set used($fx) . } + unset claims($pkg) + return +} + +### + +proc ::sak::validate::testsuites::MapPackages {} { + variable pkg + array unset pkg * + + ! + += Package + foreach {pname pdata} [ipackages] { + = "$pname ..." + foreach {pver pmodule} $pdata break + lappend pkg($pmodule) $pname + } + ! + =| {Packages mapped ...} + return +} + +proc ::sak::validate::testsuites::HasPackages {m} { + variable pkg + expr { [info exists pkg($m)] && [llength $pkg($m)] } +} + +proc ::sak::validate::testsuites::ThePackages {m} { + variable pkg + return [lsort -dict $pkg($m)] +} + +### + +proc ::sak::validate::testsuites::+pkg {pkg} { + variable mtotal ; incr mtotal + variable total ; incr total + return +} + +proc ::sak::validate::testsuites::+tests {pkg} { + variable mhavetests ; incr mhavetests + variable havetests ; incr havetests + = "$pkg Ok" + +use $pkg + return +} + +proc ::sak::validate::testsuites::notests {pkg} { + = "$pkg Bad" + log "@@ WARN No testsuite: $pkg" + return +} + +### + +proc ::sak::validate::testsuites::+e {msg} { + variable merrors ; incr merrors + variable errors ; incr errors + variable current + log "@@ ERROR $current $msg" + return +} + +proc ::sak::validate::testsuites::+u {f} { + variable used + if {[info exists used($f)]} return + variable munclaimed ; incr munclaimed + variable unclaimed ; incr unclaimed + set used($f) . + log "@@ NOTE Unclaimed testsuite $f" + return +} + +### + +proc ::sak::validate::testsuites::Count {modules} { + variable maxml 0 + ! + foreach m [linsert $modules 0 Module] { + = "M $m" + set l [string length $m] + if {$l > $maxml} {set maxml $l} + } + =| "Validate testsuites (existence) ..." + return +} + +proc ::sak::validate::testsuites::Head {m} { + variable maxml + += ${m}[blank [expr {$maxml - [string length $m]}]] + return +} + +### + +proc ::sak::validate::testsuites::InitModuleCounters {} { + variable mtotal 0 + variable mhavetests 0 + variable munclaimed 0 + variable merrors 0 + return +} + +proc ::sak::validate::testsuites::ModuleSummary {} { + variable mtotal + variable mhavetests + variable munclaimed + variable merrors + + set complete [F $mhavetests]/[F $mtotal] + set not "! [F [expr {$mtotal - $mhavetests}]]" + set err "E [F $merrors]" + set unc "U [F $munclaimed]" + + if {$munclaimed} { + set unc [=cya $unc] + >> unc + } + if {!$mhavetests && $mtotal} { + set complete [=red $complete] + set not [=red $not] + >> none + } elseif {$mhavetests < $mtotal} { + set complete [=yel $complete] + set not [=yel $not] + >> miss + } + if {$merrors} { + set err [red]$err[rst] + >> fail + } + + =| "~~ $complete $not $unc $err" + return +} + +### + +proc ::sak::validate::testsuites::InitCounters {} { + variable total 0 + variable havetests 0 + variable unclaimed 0 + variable errors 0 + return +} + +proc ::sak::validate::testsuites::Summary {} { + variable total + variable havetests + variable unclaimed + variable errors + + set tot [F $total] + set tst [F $havetests] + set uts [F [expr {$total - $havetests}]] + set unc [F $unclaimed] + set per [format %6.2f [expr {$havetests*100./$total}]] + set uper [format %6.2f [expr {($total - $havetests)*100./$total}]] + set err [F $errors] + + if {$errors} { set err [=red $err] } + if {$unclaimed} { set unc [=cya $unc] } + + if {!$havetests && $total} { + set tst [=red $tst] + set uts [=red $uts] + } elseif {$havetests < $total} { + set tst [=yel $tst] + set uts [=yel $uts] + } + + sum "" + sum "Testsuite statistics" + sum "#Packages: $tot" + sum "#Tested: $tst (${per}%)" + sum "#Untested: $uts (${uper}%)" + sum "#Unclaimed: $unc" + sum "#Errors: $err" + return +} + +### + +proc ::sak::validate::testsuites::F {n} { format %6d $n } + +### + +proc ::sak::validate::testsuites::At {m} { + global distribution + return [file join $distribution modules $m] +} + +# ### + +namespace eval ::sak::validate::testsuites { + # Max length of module names and patchlevel information. + variable maxml 0 + + # Counters across all modules + variable total 0 ; # Number of packages overall. + variable havetests 0 ; # Number of packages with testsuites. + variable unclaimed 0 ; # Number of testsuites not claimed by a specific package. + variable errors 0 ; # Number of errors found with all testsuites. + + # Same counters, per module. + variable mtotal 0 + variable mhavetests 0 + variable munclaimed 0 + variable merrors 0 + + # Name of currently processed testsuite + variable current "" + + # Map from packages to files claiming to test them. + variable claims + array set claims {} + + # Set of files taken by packages, as array + variable used + array set used {} + + # Map from modules to packages contained in them + variable pkg + array set pkg {} + + # Transient storage used while collecting packages per testsuite. + variable testing {} + variable ip {} +} + +## +# ### + +package provide sak::validate::testsuites 1.0 diff --git a/tcllib/support/devel/sak/validate/topic.txt b/tcllib/support/devel/sak/validate/topic.txt new file mode 100644 index 0000000..1ddc79b --- /dev/null +++ b/tcllib/support/devel/sak/validate/topic.txt @@ -0,0 +1 @@ +validate Validate modules and packages diff --git a/tcllib/support/devel/sak/validate/validate.tcl b/tcllib/support/devel/sak/validate/validate.tcl new file mode 100644 index 0000000..1901deb --- /dev/null +++ b/tcllib/support/devel/sak/validate/validate.tcl @@ -0,0 +1,37 @@ +# -*- tcl -*- +# (C) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net> +## +# ### + +namespace eval ::sak::validate {} + +# ### + +proc ::sak::validate::usage {args} { + package require sak::help + puts stdout [join $args { }]\n[sak::help::on validate] + exit 1 +} + +proc ::sak::validate::all {modules mode stem tclv} { + package require sak::validate::versions + package require sak::validate::manpages + package require sak::validate::testsuites + package require sak::validate::syntax + + sak::validate::versions::run $modules $mode $stem $tclv + sak::validate::manpages::run $modules $mode $stem $tclv + sak::validate::testsuites::run $modules $mode $stem $tclv + sak::validate::syntax::run $modules $mode $stem $tclv + + sak::validate::versions::summary + sak::validate::manpages::summary + sak::validate::testsuites::summary + sak::validate::syntax::summary + return +} + +## +# ### + +package provide sak::validate 1.0 diff --git a/tcllib/support/devel/sak/validate/versions.tcl b/tcllib/support/devel/sak/validate/versions.tcl new file mode 100644 index 0000000..4d622ae --- /dev/null +++ b/tcllib/support/devel/sak/validate/versions.tcl @@ -0,0 +1,258 @@ +# -*- tcl -*- +# (C) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net> +## +# ### + +package require sak::animate +package require sak::feedback +package require sak::color + +getpackage textutil::repeat textutil/repeat.tcl +getpackage interp interp/interp.tcl +getpackage struct::set struct/sets.tcl +getpackage struct::list struct/list.tcl + +namespace eval ::sak::validate::versions { + namespace import ::textutil::repeat::blank + namespace import ::sak::color::* + namespace import ::sak::feedback::! + namespace import ::sak::feedback::>> + namespace import ::sak::feedback::+= + namespace import ::sak::feedback::= + namespace import ::sak::feedback::=| + namespace import ::sak::feedback::log + namespace import ::sak::feedback::summary + rename summary sum +} + +# ### + +proc ::sak::validate::versions {modules mode stem tclv} { + versions::run $modules $mode $stem $tclv + versions::summary + return +} + +proc ::sak::validate::versions::run {modules mode stem tclv} { + sak::feedback::init $mode $stem + sak::feedback::first log "\[ Versions \] ====================================================" + sak::feedback::first warn "\[ Versions \] ====================================================" + sak::feedback::first fail "\[ Versions \] ====================================================" + + # Preprocessing of module names to allow better formatting of the + # progress output, i.e. vertically aligned columns + + # Per module + # - List modules without package index (error) + # - List packages provided missing from pkgIndex.tcl + # - List packages in the pkgIndex.tcl, but not provided. + # - List packages where provided and indexed versions differ. + + Count $modules + MapPackages + + InitCounters + foreach m $modules { + # Skip tcllibc shared library, not a module. + if {[string equal $m tcllibc]} continue + + InitModuleCounters + ! + log "@@ Module $m" + Head $m + + if {![llength [glob -nocomplain [file join [At $m] pkgIndex.tcl]]]} { + +e "No package index" + } else { + # Compare package provided to ifneeded. + + struct::list assign \ + [struct::set intersect3 [Indexed $m] [Provided $m]] \ + compare only_indexed only_provided + + foreach p [lsort -dict $only_indexed ] { +w "Indexed/No Provider: $p" } + foreach p [lsort -dict $only_provided] { +w "Provided/Not Indexed: $p" } + + foreach p [lsort -dict $compare] { + set iv [IndexedVersions $m $p] + set pv [ProvidedVersions $m $p] + if {[struct::set equal $iv $pv]} continue + + struct::list assign \ + [struct::set intersect3 $pv $iv] \ + __ pmi imp + + +w "Indexed </> Provided: $p \[<$imp </> $pmi\]" + } + } + ModuleSummary + } + return +} + +proc ::sak::validate::versions::summary {} { + Summary + return +} + +# ### + +proc ::sak::validate::versions::MapPackages {} { + variable pkg + array unset pkg * + + ! + += Package + foreach {pname pdata} [ipackages] { + = "$pname ..." + foreach {pvlist pmodule} $pdata break + lappend pkg(mi,$pmodule) $pname + lappend pkg(vi,$pmodule,$pname) $pvlist + + foreach {pname pvlist} [ppackages $pmodule] { + lappend pkg(mp,$pmodule) $pname + lappend pkg(vp,$pmodule,$pname) $pvlist + } + } + ! + =| {Packages mapped ...} + return +} + +proc ::sak::validate::versions::Provided {m} { + variable pkg + if {![info exists pkg(mp,$m)]} { return {} } + return [lsort -dict $pkg(mp,$m)] +} + +proc ::sak::validate::versions::Indexed {m} { + variable pkg + if {![info exists pkg(mi,$m)]} { return {} } + return [lsort -dict $pkg(mi,$m)] +} + +proc ::sak::validate::versions::ProvidedVersions {m p} { + variable pkg + return [lsort -dict $pkg(vp,$m,$p)] +} + +proc ::sak::validate::versions::IndexedVersions {m p} { + variable pkg + return [lsort -dict $pkg(vi,$m,$p)] +} + +### + +proc ::sak::validate::versions::+e {msg} { + variable merrors ; incr merrors + variable errors ; incr errors + log "@@ ERROR $msg" + return +} + +proc ::sak::validate::versions::+w {msg} { + variable mwarnings ; incr mwarnings + variable warnings ; incr warnings + log "@@ WARN $msg" + return +} + +proc ::sak::validate::versions::Count {modules} { + variable maxml 0 + ! + foreach m [linsert $modules 0 Module] { + = "M $m" + set l [string length $m] + if {$l > $maxml} {set maxml $l} + } + =| "Validate versions (indexed vs. provided) ..." + return +} + +proc ::sak::validate::versions::Head {m} { + variable maxml + += ${m}[blank [expr {$maxml - [string length $m]}]] + return +} + +### + +proc ::sak::validate::versions::InitModuleCounters {} { + variable merrors 0 + variable mwarnings 0 + return +} + +proc ::sak::validate::versions::ModuleSummary {} { + variable merrors + variable mwarnings + + set err "E [F $merrors]" + set wrn "W [F $mwarnings]" + + if {$mwarnings} { set wrn [=yel $wrn] ; >> warn } + if {$merrors} { set err [=red $err] ; >> fail } + + =| "~~ $err $wrn" + return +} + +### + +proc ::sak::validate::versions::InitCounters {} { + variable errors 0 + variable warnings 0 + return +} + +proc ::sak::validate::versions::Summary {} { + variable errors + variable warnings + + set err [F $errors] + set wrn [F $warnings] + + if {$errors} { set err [=red $err] } + if {$warnings} { set wrn [=yel $wrn] } + + sum "" + sum "Versions statistics" + sum "#Errors: $err" + sum "#Warnings: $wrn" + return +} + +### + +proc ::sak::validate::versions::F {n} { format %6d $n } + +### + +proc ::sak::validate::versions::At {m} { + global distribution + return [file join $distribution modules $m] +} + +# ### + +namespace eval ::sak::validate::versions { + # Max length of module names and patchlevel information. + variable maxml 0 + + # Counters across all modules + variable errors 0 ; # Number of errors found (= modules without pkg index) + variable warnings 0 ; # Number of warings + + # Same counters, per module. + variable merrors 0 + variable mwarnings 0 + + # Map from modules to packages and their versions. + variable pkg + array set pkg {} +} + +## +# ### + +package provide sak::validate::versions 1.0 |