1 # (c) 2008 Steve Bennett <steveb@workware.net.au>
3 # Loads some Tcl-compatible features.
4 # I/O commands, case, lassign, parray, errorInfo, ::tcl_platform, ::env
5 # try, throw, file copy, file delete -force
7 # Set up the ::env array
10 if {[info commands stdout
] ne
""} {
11 # Tcl-compatible I/O commands
12 foreach p
{gets flush close eof seek tell} {
13 proc $p {chan args
} {p
} {
14 tailcall
$chan $p {*}$args
19 # puts is complicated by -nonewline
21 proc puts {{-nonewline {}} {chan stdout
} msg
} {
22 if {${-nonewline} ni
{-nonewline {}}} {
23 tailcall
${-nonewline} puts $msg
25 tailcall
$chan puts {*}${-nonewline} $msg
28 # read is complicated by -nonewline
30 # read chan ?maxchars?
31 # read -nonewline chan
32 proc read {{-nonewline {}} chan
} {
33 if {${-nonewline} ni
{-nonewline {}}} {
34 tailcall
${-nonewline} read {*}${chan
}
36 tailcall
$chan read {*}${-nonewline}
39 proc fconfigure {f args
} {
49 # Just ignore -translation
52 return -code error "fconfigure: unknown option $n"
59 # case var ?in? pattern action ?pattern action ...?
60 proc case
{var args
} {
61 # Skip dummy parameter
62 if {[lindex $args 0] eq
"in"} {
63 set args
[lrange $args 1 end
]
66 # Check for single arg form
67 if {[llength $args] == 1} {
68 set args
[lindex $args 0]
71 # Check for odd number of args
72 if {[llength $args] % 2 != 0} {
73 return -code error "extra case pattern with no body"
76 # Internal function to match a value agains a list of patterns
77 local
proc case.checker
{value pattern
} {
78 string match
$pattern $value
81 foreach {value action
} $args {
82 if {$value eq
"default"} {
85 } elseif
{[lsearch -bool -command case.checker
$value $var]} {
91 if {[info exists do_action
]} {
92 set rc
[catch [list uplevel 1 $do_action] result opts
]
96 return {*}$opts $result
100 # fileevent isn't needed in Jim, but provide it for compatibility
101 proc fileevent {args
} {
105 # Second, option argument is a glob pattern
106 # Third, optional argument is a "putter" function
108 proc parray {arrayname
{pattern
*} {puts puts}} {
112 foreach name
[array names a
$pattern]] {
113 if {[string length
$name] > $max} {
114 set max
[string length
$name]
117 incr max
[string length
$arrayname]
119 foreach name
[lsort [array names a
$pattern]] {
120 $puts [format "%-${max}s = %s" $arrayname\($name\) $a($name)]
124 # Implements 'file copy' - single file mode only
125 proc {file copy
} {{force
{}} source target
} {
127 if {$force ni
{{} -force}} {
128 error "bad option \"$force\": should be -force"
131 set in
[open $source]
133 if {[file exists
$target]} {
135 error "error copying \"$source\" to \"$target\": file already exists"
137 # If source and target are the same, nothing to do
138 if {$source eq
$target} {
141 # Hard linked, or case-insensitive filesystem
142 # Note: mingw returns ino=0 for every file :-(
145 if {$ss(dev
) == $ts(dev
) && $ss(ino
) == $ts(ino
) && $ss(ino
)} {
149 set out
[open $target w
]
152 } on
error {msg opts
} {
160 # 'open "|..." ?mode?" will invoke this wrapper around exec/pipe
161 # Note that we return a lambda which also provides the 'pid' command
162 proc popen
{cmd
{mode r
}} {
163 lassign
[socket pipe
] r w
165 if {[string match
"w*" $mode]} {
167 set pids
[exec {*}$cmd]
172 set pids
[exec {*}$cmd]
176 lambda
{cmd args
} {f pids
} {
180 if {$cmd eq
"close"} {
182 # And wait for the child processes to complete
183 foreach p
$pids { os.wait
$p }
186 tailcall
$f $cmd {*}$args
188 } on
error {error opts
} {
195 # A wrapper around 'pid' which can return the pids for 'popen'
196 local
proc pid {{chan
{}}} {
200 if {[catch {$chan tell}]} {
201 return -code error "can not find channel named \"$chan\""
203 if {[catch {$chan pid} pids
]} {
209 # try/on/finally conceptually similar to Tcl 8.6
211 # Usage: try ?catchopts? script ?onclause ...? ?finallyclause?
214 # onclause is: on codes {?resultvar? ?optsvar?} script
216 # codes is: a list of return codes (ok, error, etc. or integers), or * for any
218 # finallyclause is: finally script
221 # Where onclause is: on codes {?resultvar? ?optsvar?}
224 while {[string match
-* [lindex $args 0]]} {
225 set args
[lassign
$args opt
]
229 lappend catchopts
$opt
231 if {[llength $args] == 0} {
232 return -code error {wrong
# args: should be "try ?options? script ?argument ...?"}
234 set args
[lassign
$args script
]
235 set code
[catch -eval {*}$catchopts [list uplevel 1 $script] msg opts
]
239 foreach {on codes vars script
} $args {
242 if {!$handled && ($codes eq
"*" ||
[info returncode
$code] in
$codes)} {
243 lassign
$vars msgvar optsvar
248 if {$optsvar ne
""} {
252 # Override any body result
253 set code
[catch [list uplevel 1 $script] msg opts
]
258 set finalcode
[catch [list uplevel 1 $codes] finalmsg finalopts
]
260 # Override any body or handler result
268 return -code error "try: expected 'on' or 'finally', got '$on'"
279 # Generates an exception with the given code (ok, error, etc. or an integer)
280 # and the given message
281 proc throw
{code
{msg
""}} {
282 return -code $code $msg
285 # Helper for "file delete -force"
286 proc {file delete force
} {path
} {
287 foreach e
[readdir
$path] {
288 file delete
-force $path/$e