1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
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
|
