1# -*- tcl -*- 2# (C) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> 3## 4# ### 5 6getpackage fileutil fileutil/fileutil.tcl 7 8package require sak::test 9package require sak::registry 10namespace eval ::sak::test::shell {} 11 12# ### 13 14proc ::sak::test::shell {argv} { 15 if {![llength $argv]} {Usage Sub command missing} 16 17 set cmd [lindex $argv 0] 18 set argv [lrange $argv 1 end] 19 20 switch -exact -- $cmd { 21 add { 22 sak::test::shell::add $argv 23 } 24 delete { 25 sak::test::shell::delete $argv 26 } 27 default { 28 sak::test::usage Unknown command "\"shell $cmd\"" 29 } 30 } 31 return 32} 33 34proc ::sak::test::shell::list {} { 35 return [sak::registry::local \ 36 get||default Tests Shells {}] 37} 38 39proc ::sak::test::shell::add {paths} { 40 foreach p $paths { 41 if {![fileutil::test $p efrx msg "Shell"]} { 42 sak::test::usage $msg 43 } 44 } 45 46 set shells [sak::registry::local \ 47 get||default Tests Shells {}] 48 array set known {} 49 foreach sh $shells {set known($sh) .} 50 51 set changed 0 52 foreach p $paths { 53 if {[info exists known($p)]} continue 54 lappend shells $p 55 set changed 1 56 } 57 58 if {$changed} { 59 sak::registry::local \ 60 set Tests Shells [lsort -dict $shells] 61 } 62 return 63} 64 65proc ::sak::test::shell::delete {paths} { 66 set shells [sak::registry::local \ 67 get||default Tests Shells {}] 68 array set known {} 69 foreach sh $shells {set known($sh) .} 70 71 set changed 0 72 foreach p $paths { 73 if {![info exists known($p)]} continue 74 unset known($p) 75 set changed 1 76 } 77 78 if {$changed} { 79 sak::registry::local \ 80 set Tests Shells [lsort -dict \ 81 [array names known]] 82 } 83 return 84} 85 86# ### 87 88namespace eval ::sak::test::shell { 89} 90 91## 92# ### 93 94package provide sak::test::shell 1.0 95