138 lines
3.6 KiB
Tcl
138 lines
3.6 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];
|
|
}
|
|
|
|
# \brief Enables or disables the debug_msg command
|
|
#
|
|
# \param mode on turns on debugging, off turns off debugging
|
|
#
|
|
# \see debug_msg
|
|
# TODO Set a callstack global variable
|
|
proc debug_mode {mode} {
|
|
switch $mode {
|
|
on {
|
|
proc debug_msg {args} {
|
|
switch [info level] {
|
|
0 {
|
|
# This happens when debug_msg is used with trace
|
|
clientput $args
|
|
}
|
|
1 {
|
|
# This probably only occurs if you debug_msg directly. Why would you do that?
|
|
set cmdinfo [info level 0]
|
|
set cmd [lindex $cmdinfo 0]
|
|
set nscmd [namespace origin $cmd]
|
|
clientput "DEBUG, ${nscmd}::$cmdinfo]$args"
|
|
}
|
|
2 {
|
|
set cmdinfo [info level -1]
|
|
set cmd [lindex $cmdinfo 0]
|
|
set nscmd [namespace origin $cmd]
|
|
clientput "DEBUG, ${nscmd}::$cmdinfo]$args"
|
|
}
|
|
3 - default {
|
|
set cmdinfo [info level -1]
|
|
set cmd [lindex $cmdinfo 0]
|
|
set nscmd [namespace origin $cmd]
|
|
set callerinfo [info level -2]
|
|
set caller [lindex $callerinfo 0]
|
|
set nscaller [namespace origin $caller]
|
|
clientput "DEBUG, ${nscaller}::$callerinfo\n\t${nscmd}::$cmdinfo]$args"
|
|
}
|
|
}
|
|
}
|
|
}
|
|
off {
|
|
proc debug_msg {args} {};
|
|
}
|
|
}
|
|
}
|
|
|
|
## \brief You can use debug_msg in place of 'puts' for debug info in Tcl macros.
|
|
#
|
|
# Add debug messages on the fly with
|
|
# strace add execution <proc> enter debug_msg
|
|
proc debug_msg {args} {};
|
|
publish debug_mode mugger
|
|
|
|
proc todo_msg {args} {
|
|
set cmdinfo [info level -1]
|
|
set cmd [lindex $cmdinfo 0]
|
|
clientput "TODO <$cmd> $args"
|
|
}
|
|
|
|
proc error_msg {args} {
|
|
set cmdinfo [info level -1]
|
|
set cmd [lindex $cmdinfo 0]
|
|
set arglist [lrange $cmdinfo 1 end]
|
|
error "ERROR: [namespace origin $cmd] $arglist: $args"
|
|
}
|