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 {$force eq
"" && [file exists
$target]} {
135 error "error copying \"$source\" to \"$target\": file already exists"
137 set out
[open $target w
]
140 } on
error {msg opts
} {
148 # 'open "|..." ?mode?" will invoke this wrapper around exec/pipe
149 # Note that we return a lambda which also provides the 'pid' command
150 proc popen
{cmd
{mode r
}} {
151 lassign
[socket pipe
] r w
153 if {[string match
"w*" $mode]} {
155 set pids
[exec {*}$cmd]
160 set pids
[exec {*}$cmd]
164 lambda
{cmd args
} {f pids
} {
168 if {$cmd eq
"close"} {
170 # And wait for the child processes to complete
171 foreach p
$pids { os.wait
$p }
174 tailcall
$f $cmd {*}$args
176 } on
error {error opts
} {
183 # A wrapper around 'pid' which can return the pids for 'popen'
184 local
proc pid {{chan
{}}} {
188 if {[catch {$chan tell}]} {
189 return -code error "can not find channel named \"$chan\""
191 if {[catch {$chan pid} pids
]} {
197 # try/on/finally conceptually similar to Tcl 8.6
199 # Usage: try ?catchopts? script ?onclause ...? ?finallyclause?
202 # onclause is: on codes {?resultvar? ?optsvar?} script
204 # codes is: a list of return codes (ok, error, etc. or integers), or * for any
206 # finallyclause is: finally script
209 # Where onclause is: on codes {?resultvar? ?optsvar?}
212 while {[string match
-* [lindex $args 0]]} {
213 set args
[lassign
$args opt
]
217 lappend catchopts
$opt
219 if {[llength $args] == 0} {
220 return -code error {wrong
# args: should be "try ?options? script ?argument ...?"}
222 set args
[lassign
$args script
]
223 set code
[catch -eval {*}$catchopts [list uplevel 1 $script] msg opts
]
227 foreach {on codes vars script
} $args {
230 if {!$handled && ($codes eq
"*" ||
[info returncode
$code] in
$codes)} {
231 lassign
$vars msgvar optsvar
236 if {$optsvar ne
""} {
240 # Override any body result
241 set code
[catch [list uplevel 1 $script] msg opts
]
246 set finalcode
[catch [list uplevel 1 $codes] finalmsg finalopts
]
248 # Override any body or handler result
256 return -code error "try: expected 'on' or 'finally', got '$on'"
267 # Generates an exception with the given code (ok, error, etc. or an integer)
268 # and the given message
269 proc throw
{code
{msg
""}} {
270 return -code $code $msg
273 # Helper for "file delete -force"
274 proc {file delete force
} {path
} {
275 foreach e
[readdir
$path] {
276 file delete
-force $path/$e