diff options
author | William Joye <wjoye@cfa.harvard.edu> | 2019-02-15 18:19:17 (GMT) |
---|---|---|
committer | William Joye <wjoye@cfa.harvard.edu> | 2019-02-15 18:19:17 (GMT) |
commit | b863b050cd0148499e6725724829e066890f518c (patch) | |
tree | 7828a9e8d84da3f73abe446fc50a9c0b0c11528a /tcllib/support/devel/sak/test/shell.tcl | |
parent | 7f1623e3f658b2dc4ddad0f1b9309a156de82065 (diff) | |
download | blt-b863b050cd0148499e6725724829e066890f518c.zip blt-b863b050cd0148499e6725724829e066890f518c.tar.gz blt-b863b050cd0148499e6725724829e066890f518c.tar.bz2 |
update tcllib
Diffstat (limited to 'tcllib/support/devel/sak/test/shell.tcl')
-rw-r--r-- | tcllib/support/devel/sak/test/shell.tcl | 94 |
1 files changed, 94 insertions, 0 deletions
diff --git a/tcllib/support/devel/sak/test/shell.tcl b/tcllib/support/devel/sak/test/shell.tcl new file mode 100644 index 0000000..f0f0e5d --- /dev/null +++ b/tcllib/support/devel/sak/test/shell.tcl @@ -0,0 +1,94 @@ +# -*- tcl -*- +# (C) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> +## +# ### + +getpackage fileutil fileutil/fileutil.tcl + +package require sak::test +package require sak::registry +namespace eval ::sak::test::shell {} + +# ### + +proc ::sak::test::shell {argv} { + if {![llength $argv]} {Usage Sub command missing} + + set cmd [lindex $argv 0] + set argv [lrange $argv 1 end] + + switch -exact -- $cmd { + add { + sak::test::shell::add $argv + } + delete { + sak::test::shell::delete $argv + } + default { + sak::test::usage Unknown command "\"shell $cmd\"" + } + } + return +} + +proc ::sak::test::shell::list {} { + return [sak::registry::local \ + get||default Tests Shells {}] +} + +proc ::sak::test::shell::add {paths} { + foreach p $paths { + if {![fileutil::test $p efrx msg "Shell"]} { + sak::test::usage $msg + } + } + + set shells [sak::registry::local \ + get||default Tests Shells {}] + array set known {} + foreach sh $shells {set known($sh) .} + + set changed 0 + foreach p $paths { + if {[info exists known($p)]} continue + lappend shells $p + set changed 1 + } + + if {$changed} { + sak::registry::local \ + set Tests Shells [lsort -dict $shells] + } + return +} + +proc ::sak::test::shell::delete {paths} { + set shells [sak::registry::local \ + get||default Tests Shells {}] + array set known {} + foreach sh $shells {set known($sh) .} + + set changed 0 + foreach p $paths { + if {![info exists known($p)]} continue + unset known($p) + set changed 1 + } + + if {$changed} { + sak::registry::local \ + set Tests Shells [lsort -dict \ + [array names known]] + } + return +} + +# ### + +namespace eval ::sak::test::shell { +} + +## +# ### + +package provide sak::test::shell 1.0 |