blob: c996c190db8ae9d7445bbda2c00a96f916d06684 (
plain)
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
|
# (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} {
uplevel 1 [list foreach $args [concat $list {}] break]
lrange $list [llength $args] end
}
# 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
set checker [lambda {value pattern} {string match $pattern $value}]
foreach {value action} $args {
if {$value eq "default"} {
set do_action $action
continue
} elseif {[lsearch -bool -command $checker $value $var]} {
set do_action $action
break
}
}
rename $checker ""
if {[info exists do_action]} {
set rc [catch [list uplevel 1 $do_action] result]
return -code $rc $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} {
set rc [catch {
if {$force ni {{} -force}} {
error "bad option \"$force\": should be -force"
}
set in [open $source]
try {
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
} finally {
catch {$in close}
}
} result]
return -code $rc $result
}
# Poor mans try/catch/finally
# Note that in this version 'finally' is required
proc try {script finally finalscript} {
if {$finally ne "finally"} {
return -code error {mis-spelt "finally" keyword}
}
set bodycode [catch [list uplevel 1 $script] bodymsg]
set finalcode [catch [list uplevel 1 $finalscript] finalmsg]
if {$bodycode || !$finalcode} {
return -code $bodycode $bodymsg
}
return -code $finalcode $finalmsg
}
set ::tcl_platform(platform) unix
|
