summaryrefslogtreecommitdiffstats
path: root/tcllib/support/devel/sak/validate
diff options
context:
space:
mode:
Diffstat (limited to 'tcllib/support/devel/sak/validate')
-rw-r--r--tcllib/support/devel/sak/validate/cmd.tcl70
-rw-r--r--tcllib/support/devel/sak/validate/help.txt53
-rw-r--r--tcllib/support/devel/sak/validate/manpages.tcl464
-rw-r--r--tcllib/support/devel/sak/validate/pkgIndex.tcl6
-rw-r--r--tcllib/support/devel/sak/validate/syntax.tcl668
-rw-r--r--tcllib/support/devel/sak/validate/testsuites.tcl512
-rw-r--r--tcllib/support/devel/sak/validate/topic.txt1
-rw-r--r--tcllib/support/devel/sak/validate/validate.tcl37
-rw-r--r--tcllib/support/devel/sak/validate/versions.tcl258
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
generated by cgit v0.12 at 2024-08-30 03:20:29 (GMT)