1 # (c) 2008 Steve Bennett <steveb@workware.net.au>
3 # Loads some Tcl-compatible features.
4 # case, lassign, parray, errorInfo, ::tcl_platform, ::env
6 package provide tclcompat
1.0
8 # Set up the ::env array
12 proc lassign
{list args
} {
13 # in case the list is empty...
15 uplevel 1 [list foreach $args $list break]
16 lrange $list [llength $args] end-1
19 # case var ?in? pattern action ?pattern action ...?
20 proc case
{var args
} {
21 # Skip dummy parameter
22 if {[lindex $args 0] eq
"in"} {
23 set args
[lrange $args 1 end
]
26 # Check for single arg form
27 if {[llength $args] == 1} {
28 set args
[lindex $args 0]
31 # Check for odd number of args
32 if {[llength $args] % 2 != 0} {
33 return -code error "extra case pattern with no body"
36 # Internal function to match a value agains a list of patterns
37 local
proc case.checker
{value pattern
} {
38 string match
$pattern $value
41 foreach {value action
} $args {
42 if {$value eq
"default"} {
45 } elseif
{[lsearch -bool -command case.checker
$value $var]} {
51 if {[info exists do_action
]} {
52 set rc
[catch [list uplevel 1 $do_action] result opts
]
56 return {*}$opts $result
60 # Optional argument is a glob pattern
61 proc parray {arrayname
{pattern
*}} {
65 foreach name
[array names a
$pattern]] {
66 if {[string length
$name] > $max} {
67 set max
[string length
$name]
70 incr max
[string length
$arrayname]
72 foreach name
[lsort [array names a
$pattern]] {
73 puts [format "%-${max}s = %s" $arrayname\($name\) $a($name)]
77 # Sort of replacement for $::errorInfo
78 # Usage: errorInfo error ?stacktrace?
79 proc errorInfo
{error {stacktrace
""}} {
80 if {$stacktrace eq
""} {
81 set stacktrace
[info stacktrace
]
83 lassign
$stacktrace p f l
87 append result
"Runtime Error: $error\n"
88 append result
[stackdump
$stacktrace]
91 proc {info nameofexecutable
} {} {
92 if {[info exists
::jim_argv0]} {
93 if {[string first
"/" $::jim_argv0] >= 0} {
96 foreach path
[split [env PATH
""] :] {
97 set exec [file join $path $::jim_argv0]
98 if {[file executable
$exec]} {
106 # Implements 'file copy' - single file mode only
107 proc {file copy
} {{force
{}} source target
} {
109 if {$force ni
{{} -force}} {
110 error "bad option \"$force\": should be -force"
113 set in
[open $source]
115 if {$force eq
"" && [file exists
$target]} {
117 error "error copying \"$source\" to \"$target\": file already exists"
119 set out
[open $target w
]
122 } on
error {msg opts
} {
130 # try/on/finally conceptually similar to Tcl 8.6
132 # Usage: try ?catchopts? script ?onclause ...? ?finallyclause?
135 # onclause is: on codes {?resultvar? ?optsvar?} script
137 # codes is: a list of return codes (ok, error, etc. or integers), or * for any
139 # finallyclause is: finally script
142 # Where onclause is: on codes {?resultvar? ?optsvar?}
145 while {[string match
-* [lindex $args 0]]} {
146 set args
[lassign
$args opt
]
150 lappend catchopts
$opt
152 if {[llength $args] == 0} {
153 return -code error {wrong
# args: should be "try ?options? script ?argument ...?"}
155 set args
[lassign
$args script
]
156 set code
[catch -eval {*}$catchopts [list uplevel 1 $script] msg opts
]
160 foreach {on codes vars script
} $args {
163 if {!$handled && ($codes eq
"*" ||
[info returncode
$code] in
$codes)} {
164 lassign
$vars msgvar optsvar
169 if {$optsvar ne
""} {
173 # Override any body result
174 set code
[catch [list uplevel 1 $script] msg opts
]
179 set finalcode
[catch [list uplevel 1 $codes] finalmsg finalopts
]
181 # Override any body or handler result
189 return -code error "try: expected 'on' or 'finally', got '$on'"
200 # Generates an exception with the given code (ok, error, etc. or an integer)
201 # and the given message
202 proc throw
{code
{msg
""}} {
203 return -code $code $msg
206 set ::tcl_platform(platform
) unix