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 # fileevent isn't needed in Jim, but provide it for compatibility
60 proc fileevent {args
} {
64 # Second, option argument is a glob pattern
65 # Third, optional argument is a "putter" function
67 proc parray {arrayname
{pattern
*} {puts puts}} {
71 foreach name
[array names a
$pattern]] {
72 if {[string length
$name] > $max} {
73 set max
[string length
$name]
76 incr max
[string length
$arrayname]
78 foreach name
[lsort [array names a
$pattern]] {
79 $puts [format "%-${max}s = %s" $arrayname\($name\) $a($name)]
83 # Implements 'file copy' - single file mode only
84 proc {file copy
} {{force
{}} source target
} {
86 if {$force ni
{{} -force}} {
87 error "bad option \"$force\": should be -force"
92 if {[file exists
$target]} {
94 error "error copying \"$source\" to \"$target\": file already exists"
96 # If source and target are the same, nothing to do
97 if {$source eq
$target} {
100 # Hard linked, or case-insensitive filesystem
101 # Note: mingw returns ino=0 for every file :-(
104 if {$ss(dev
) == $ts(dev
) && $ss(ino
) == $ts(ino
) && $ss(ino
)} {
108 set out
[open $target w
]
111 } on
error {msg opts
} {
119 # 'open "|..." ?mode?" will invoke this wrapper around exec/pipe
120 # Note that we return a lambda which also provides the 'pid' command
121 proc popen
{cmd
{mode r
}} {
122 lassign
[socket pipe
] r w
124 if {[string match
"w*" $mode]} {
126 set pids
[exec {*}$cmd]
131 set pids
[exec {*}$cmd]
135 lambda
{cmd args
} {f pids
} {
139 if {$cmd eq
"close"} {
141 # And wait for the child processes to complete
142 foreach p
$pids { os.wait
$p }
145 tailcall
$f $cmd {*}$args
147 } on
error {error opts
} {
154 # A wrapper around 'pid' which can return the pids for 'popen'
155 local
proc pid {{channelId
{}}} {
156 if {$channelId eq
""} {
159 if {[catch {$channelId tell}]} {
160 return -code error "can not find channel named \"$channelId\""
162 if {[catch {$channelId pid} pids
]} {
168 # try/on/finally conceptually similar to Tcl 8.6
170 # Usage: try ?catchopts? script ?onclause ...? ?finallyclause?
173 # onclause is: on codes {?resultvar? ?optsvar?} script
175 # codes is: a list of return codes (ok, error, etc. or integers), or * for any
177 # finallyclause is: finally script
180 # Where onclause is: on codes {?resultvar? ?optsvar?}
183 while {[string match
-* [lindex $args 0]]} {
184 set args
[lassign
$args opt
]
188 lappend catchopts
$opt
190 if {[llength $args] == 0} {
191 return -code error {wrong
# args: should be "try ?options? script ?argument ...?"}
193 set args
[lassign
$args script
]
194 set code
[catch -eval {*}$catchopts [list uplevel 1 $script] msg opts
]
198 foreach {on codes vars script
} $args {
201 if {!$handled && ($codes eq
"*" ||
[info returncode
$code] in
$codes)} {
202 lassign
$vars msgvar optsvar
207 if {$optsvar ne
""} {
211 # Override any body result
212 set code
[catch [list uplevel 1 $script] msg opts
]
217 set finalcode
[catch [list uplevel 1 $codes] finalmsg finalopts
]
219 # Override any body or handler result
227 return -code error "try: expected 'on' or 'finally', got '$on'"
238 # Generates an exception with the given code (ok, error, etc. or an integer)
239 # and the given message
240 proc throw
{code
{msg
""}} {
241 return -code $code $msg
244 # Helper for "file delete -force"
245 proc {file delete force
} {path
} {
246 foreach e
[readdir
$path] {
247 file delete
-force $path/$e