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