forked from msteveb/jimtcl
-
Notifications
You must be signed in to change notification settings - Fork 0
/
tclcompat.tcl
279 lines (254 loc) · 6.01 KB
/
tclcompat.tcl
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
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
# (c) 2008 Steve Bennett <steveb@workware.net.au>
#
# Loads some Tcl-compatible features.
# I/O commands, case, lassign, parray, errorInfo, ::tcl_platform, ::env
# try, throw, file copy, file delete -force
# Set up the ::env array
set env [env]
if {[info commands stdout] ne ""} {
# Tcl-compatible I/O commands
foreach p {gets flush close eof seek tell} {
proc $p {chan args} {p} {
tailcall $chan $p {*}$args
}
}
unset p
# puts is complicated by -nonewline
#
proc puts {{-nonewline {}} {chan stdout} msg} {
if {${-nonewline} ni {-nonewline {}}} {
tailcall ${-nonewline} puts $msg
}
tailcall $chan puts {*}${-nonewline} $msg
}
# read is complicated by -nonewline
#
# read chan ?maxchars?
# read -nonewline chan
proc read {{-nonewline {}} chan} {
if {${-nonewline} ni {-nonewline {}}} {
tailcall ${-nonewline} read {*}${chan}
}
tailcall $chan read {*}${-nonewline}
}
proc fconfigure {f args} {
foreach {n v} $args {
switch -glob -- $n {
-bl* {
$f ndelay $(!$v)
}
-bu* {
$f buffering $v
}
-tr* {
# Just ignore -translation
}
default {
return -code error "fconfigure: unknown option $n"
}
}
}
}
}
# 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
}
}
# fileevent isn't needed in Jim, but provide it for compatibility
proc fileevent {args} {
tailcall {*}$args
}
# Second, option argument is a glob pattern
# Third, optional argument is a "putter" function
#
proc parray {arrayname {pattern *} {puts puts}} {
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)]
}
}
# 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]
$in copyto $out
$out close
} on error {msg opts} {
incr opts(-level)
return {*}$opts $msg
} finally {
catch {$in close}
}
}
# 'open "|..." ?mode?" will invoke this wrapper around exec/pipe
# Note that we return a lambda which also provides the 'pid' command
proc popen {cmd {mode r}} {
lassign [socket pipe] r w
try {
if {[string match "w*" $mode]} {
lappend cmd <@$r &
set pids [exec {*}$cmd]
$r close
set f $w
} else {
lappend cmd >@$w &
set pids [exec {*}$cmd]
$w close
set f $r
}
lambda {cmd args} {f pids} {
if {$cmd eq "pid"} {
return $pids
}
if {$cmd eq "close"} {
$f close
# And wait for the child processes to complete
foreach p $pids { os.wait $p }
return
}
tailcall $f $cmd {*}$args
}
} on error {error opts} {
$r close
$w close
error $error
}
}
# A wrapper around 'pid' which can return the pids for 'popen'
local proc pid {{chan {}}} {
if {$chan eq ""} {
tailcall upcall pid
}
if {[catch {$chan tell}]} {
return -code error "can not find channel named \"$chan\""
}
if {[catch {$chan pid} pids]} {
return ""
}
return $pids
}
# 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
}
# Helper for "file delete -force"
proc {file delete force} {path} {
foreach e [readdir $path] {
file delete -force $path/$e
}
file delete $path
}