diff options
Diffstat (limited to 'tcl6.tcl')
-rw-r--r-- | tcl6.tcl | 100 |
1 files changed, 100 insertions, 0 deletions
diff --git a/tcl6.tcl b/tcl6.tcl new file mode 100644 index 0000000..d62b895 --- /dev/null +++ b/tcl6.tcl @@ -0,0 +1,100 @@ +# (c) 2008 Steve Bennett <steveb@workware.net.au> +# +# Loads a Tcl6-compatible environment plus some newer features, +# including stdio, array, file, clock, glob, regexp, regsub, lsearch, case, ::env + +package provide tcl6 1.0 + +package require stdio + +# Extremely simple autoload approach +set autoload {glob glob array array} + +proc unknown {cmd args} { + if {[info exists ::autoload($cmd)]} { + package require $::autoload($cmd) + return [uplevel 1 $cmd $args] + } + error "invalid command name \"$cmd\"" +} + +# Set up the ::env array +set env [env] + +# Very basic lsearch -exact with no options +proc lsearch {list value} { + set i 0 + foreach elem $list { + if {$elem eq $value} { + return $i + } + incr i + } + return -1 +} + +# Internal function to match a value agains a list of patterns +proc _case_search_patterns {patterns value} { + set i 0 + foreach pattern $patterns { + if {[string match $pattern $value]} { + return $i + } + incr i + } + return -1 +} + +# case var ?in? pattern action ?pattern action ...? +proc case {var args} { + # Skip dummy parameter + if {[lindex $args 0] eq "in"} { + set args [lrange $args 1 end] + } + + # Check for single arg form + if {[llength $args] == 1} { + set args [lindex $args 0] + } + + # Check for odd number of args + if {[llength $args] % 2 != 0} { + error "extra case pattern with no body" + } + + #puts "looking for $var in '$args'" + foreach {value action} $args { + if {$value eq "default"} { + set do_action $action + continue + } else { + if {[_case_search_patterns $value $var] >= 0} { + set do_action $action + break + } + } + } + + if {[info exists do_action]} { + return [uplevel 1 $do_action] + } +} + +# Optional argument is a glob pattern +proc parray {arrayname {pattern *}} { + upvar $arrayname a + + set max 0 + foreach name [array names a $pattern]] { + if {[string length $name] > $max} { + set max [string length $name] + } + } + incr max [string length $arrayname] + incr max 2 + foreach name [lsort [array names a $pattern]] { + puts [format "%-${max}s = $a($name)" $arrayname\($name\)] + } +} + +set ::tcl_platform(platform) unix |