Merged new hdb and nexus code.

r2099 | ffr | 2007-07-22 15:23:41 +1000 (Sun, 22 Jul 2007) | 2 lines

site_ansto/instrument/util/extra_utility.tcl

@@ -0,0 +1,107 @@
+# 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
+}