1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
|
# (c) 2008 Steve Bennett <steveb@workware.net.au>
#
# Loads some Tcl-compatible features.
# case, lassign, parray, errorInfo, ::tcl_platform, ::env
package provide tclcompat 1.0
# Set up the ::env array
set env [env]
# Tcl 8.5 lassign
proc lassign {list args} {
# in case the list is empty...
lappend list {}
uplevel 1 [list foreach $args $list break]
lrange $list [llength $args] end-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} {
return -code error "extra case pattern with no body"
}
# Internal function to match a value agains a list of patterns
local proc case.checker {value pattern} {
string match $pattern $value
}
foreach {value action} $args {
if {$value eq "default"} {
set do_action $action
continue
} elseif {[lsearch -bool -command case.checker $value $var]} {
set do_action $action
break
}
}
if {[info exists do_action]} {
set rc [catch [list uplevel 1 $do_action] result opts]
if {$rc} {
incr opts(-level)
}
return {*}$opts $result
}
}
# 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 = %s" $arrayname\($name\) $a($name)]
}
}
# Sort of replacement for $::errorInfo
# Usage: errorInfo error ?stacktrace?
proc errorInfo {error {stacktrace ""}} {
if {$stacktrace eq ""} {
set stacktrace [info stacktrace]
}
set result "Runtime Error: $error"
foreach {l f p} [lreverse $stacktrace] {
append result \n
if {$p ne ""} {
append result "in procedure '$p' "
if {$f ne ""} {
append result "called "
}
}
if {$f ne ""} {
append result "at file \"$f\", line $l"
}
}
if {[info exists f] && $f ne ""} {
return "$f:$l: $result"
}
return $result
}
proc {info nameofexecutable} {} {
if {[info exists ::jim_argv0]} {
if {[string first "/" $::jim_argv0] >= 0} {
return $::jim_argv0
}
foreach path [split [env PATH ""] :] {
set exec [file join $path $::jim_argv0]
if {[file executable $exec]} {
return $exec
}
}
}
return ""
}
# Implements 'file copy' - single file mode only
proc {file copy} {{force {}} source target} {
try {
if {$force ni {{} -force}} {
error "bad option \"$force\": should be -force"
}
set in [open $source]
if {$force eq "" && [file exists $target]} {
$in close
error "error copying \"$source\" to \"$target\": file already exists"
}
set out [open $target w]
bio copy $in $out
$out close
} on error {msg opts} {
incr opts(-level)
return {*}$opts $msg
} finally {
catch {$in close}
}
}
# try/on/finally conceptually similar to Tcl 8.6
#
# Usage: try ?catchopts? script ?onclause ...? ?finallyclause?
#
# Where:
# onclause is: on codes {?resultvar? ?optsvar?} script
#
# codes is: a list of return codes (ok, error, etc. or integers), or * for any
#
# finallyclause is: finally script
#
#
# Where onclause is: on codes {?resultvar? ?optsvar?}
proc try {args} {
set catchopts {}
while {[string match -* [lindex $args 0]]} {
set args [lassign $args opt]
if {$opt eq "--"} {
break
}
lappend catchopts $opt
}
if {[llength $args] == 0} {
return -code error {wrong # args: should be "try ?options? script ?argument ...?"}
}
set args [lassign $args script]
set code [catch -eval {*}$catchopts [list uplevel 1 $script] msg opts]
set handled 0
foreach {on codes vars script} $args {
switch -- $on \
on {
if {!$handled && ($codes eq "*" || [info returncode $code] in $codes)} {
lassign $vars msgvar optsvar
if {$msgvar ne ""} {
upvar $msgvar hmsg
set hmsg $msg
}
if {$optsvar ne ""} {
upvar $optsvar hopts
set hopts $opts
}
# Override any body result
set code [catch [list uplevel 1 $script] msg opts]
incr handled
}
} \
finally {
set finalcode [catch [list uplevel 1 $codes] finalmsg finalopts]
if {$finalcode} {
# Override any body or handler result
set code $finalcode
set msg $finalmsg
set opts $finalopts
}
break
} \
default {
return -code error "try: expected 'on' or 'finally', got '$on'"
}
}
if {$code} {
incr opts(-level)
return {*}$opts $msg
}
return $msg
}
# Generates an exception with the given code (ok, error, etc. or an integer)
# and the given message
proc throw {code {msg ""}} {
return -code $code $msg
}
set ::tcl_platform(platform) unix
|
