108 lines
2.7 KiB
Tcl
108 lines
2.7 KiB
Tcl
# Many of these functions are also useful in test and debug code
|
|
# running on an external Tcl interpreter.
|
|
|
|
# LIST FUNCTIONS
|
|
proc head {args} {lindex [join $args] 0}
|
|
proc tail {args} {join [lrange [join $args] 1 end]}
|
|
|
|
# SET FUNCTIONS
|
|
|
|
# Set membership
|
|
proc setmem {el A} {
|
|
expr {[lsearch $A $el] >= 0}
|
|
}
|
|
|
|
# Set difference: A\B, members of A that are not in B
|
|
proc setdiff {A B} {
|
|
foreach el $A {
|
|
if {[lsearch -exact $B $el] == -1} {
|
|
lappend missing $el;
|
|
}
|
|
}
|
|
if {[info exists missing]} {
|
|
return $missing;
|
|
}
|
|
}
|
|
|
|
proc _intersection {lista listb} {
|
|
set result {}
|
|
foreach elem [join $listb] {
|
|
if { [lsearch -exact $lista $elem] != -1 } {
|
|
lappend result $elem
|
|
}
|
|
}
|
|
return $result
|
|
}
|
|
|
|
proc intersection {lista args} {
|
|
if {[llength $args] == 0} {return $lista}
|
|
if {[llength $args] == 1} {return [_intersection $lista $args]}
|
|
return [intersection [_intersection $lista [head $args]] [tail $args]];
|
|
}
|
|
|
|
|
|
# TYPE CHECKING
|
|
# This is an enhanced set membership function.
|
|
# It can check that an element is a member of a list or
|
|
# of a named type
|
|
proc isoneof {element setb} {
|
|
global simpleType;
|
|
set result 0;
|
|
|
|
foreach elb $setb {
|
|
switch $elb {
|
|
alpha {set result [string is alpha $element]}
|
|
text {set result [string is wordchar $element]}
|
|
print {set result [string is print $element]}
|
|
float {set result [string is double $element]}
|
|
int {set result [string is integer $element]}
|
|
default {set result [expr {$element == $elb}]}
|
|
}
|
|
if {$result == 1} {return 1}
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
# Returns 'sicslist' output in lower case, this may be useful in macros.
|
|
# This function is used a lot in the hdbbuilder
|
|
proc tolower_sicslist {args} {
|
|
set result [eval sicslist $args]
|
|
return [string tolower $result];
|
|
}
|
|
|
|
# You can use debug_msg in place of 'puts' for debug info in Tcl macros.
|
|
# debug on, turns on debugging
|
|
# debug off, turns off debugging
|
|
proc debug_mode {mode} {
|
|
switch $mode {
|
|
on {
|
|
proc debug_msg {args} {
|
|
set cmdinfo [info level -1]
|
|
set cmd [lindex $cmdinfo 0]
|
|
set arglist [lrange $cmdinfo 1 end]
|
|
clientput "DEBUG:$args> [namespace origin $cmd] $arglist"
|
|
}
|
|
}
|
|
off {
|
|
proc debug_msg {args} {};
|
|
}
|
|
}
|
|
}
|
|
proc debug_msg {args} {};
|
|
publish debug_mode mugger
|
|
sicslist setatt debug_mode privilege internal
|
|
|
|
proc todo_msg {args} {
|
|
set cmdinfo [info level -1]
|
|
set cmd [lindex $cmdinfo 0]
|
|
set arglist [lrange $cmdinfo 1 end]
|
|
clientput "TODO:$args> [namespace origin $cmd] $arglist"
|
|
}
|
|
|
|
proc error_msg {args} {
|
|
set cmdinfo [info level -1]
|
|
set cmd [lindex $cmdinfo 0]
|
|
set arglist [lrange $cmdinfo 1 end]
|
|
clientput "ERROR: [namespace origin $cmd] $arglist: $args" error
|
|
}
|