1# (c) 2008 Steve Bennett <steveb@workware.net.au> 2# 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 6 7# Set up the ::env array 8set env [env] 9 10if {[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 15 } 16 } 17 unset p 18 19 # puts is complicated by -nonewline 20 # 21 proc puts {{-nonewline {}} {chan stdout} msg} { 22 if {${-nonewline} ni {-nonewline {}}} { 23 tailcall ${-nonewline} puts $msg 24 } 25 tailcall $chan puts {*}${-nonewline} $msg 26 } 27 28 # read is complicated by -nonewline 29 # 30 # read chan ?maxchars? 31 # read -nonewline chan 32 proc read {{-nonewline {}} chan} { 33 if {${-nonewline} ni {-nonewline {}}} { 34 tailcall ${-nonewline} read {*}${chan} 35 } 36 tailcall $chan read {*}${-nonewline} 37 } 38 39 proc fconfigure {f args} { 40 foreach {n v} $args { 41 switch -glob -- $n { 42 -bl* { 43 $f ndelay $v 44 } 45 -bu* { 46 $f buffering $v 47 } 48 -tr* { 49 # Just ignore -translation 50 } 51 default { 52 return -code error "fconfigure: unknown option $n" 53 } 54 } 55 } 56 } 57} 58 59# case var ?in? pattern action ?pattern action ...? 60proc case {var args} { 61 # Skip dummy parameter 62 if {[lindex $args 0] eq "in"} { 63 set args [lrange $args 1 end] 64 } 65 66 # Check for single arg form 67 if {[llength $args] == 1} { 68 set args [lindex $args 0] 69 } 70 71 # Check for odd number of args 72 if {[llength $args] % 2 != 0} { 73 return -code error "extra case pattern with no body" 74 } 75 76 # Internal function to match a value agains a list of patterns 77 local proc case.checker {value pattern} { 78 string match $pattern $value 79 } 80 81 foreach {value action} $args { 82 if {$value eq "default"} { 83 set do_action $action 84 continue 85 } elseif {[lsearch -bool -command case.checker $value $var]} { 86 set do_action $action 87 break 88 } 89 } 90 91 if {[info exists do_action]} { 92 set rc [catch [list uplevel 1 $do_action] result opts] 93 if {$rc} { 94 incr opts(-level) 95 } 96 return {*}$opts $result 97 } 98} 99 100# fileevent isn't needed in Jim, but provide it for compatibility 101proc fileevent {args} { 102 tailcall {*}$args 103} 104 105# Second, option argument is a glob pattern 106# Third, optional argument is a "putter" function 107# 108proc parray {arrayname {pattern *} {puts puts}} { 109 upvar $arrayname a 110 111 set max 0 112 foreach name [array names a $pattern]] { 113 if {[string length $name] > $max} { 114 set max [string length $name] 115 } 116 } 117 incr max [string length $arrayname] 118 incr max 2 119 foreach name [lsort [array names a $pattern]] { 120 $puts [format "%-${max}s = %s" $arrayname\($name\) $a($name)] 121 } 122} 123 124# Implements 'file copy' - single file mode only 125proc {file copy} {{force {}} source target} { 126 try { 127 if {$force ni {{} -force}} { 128 error "bad option \"$force\": should be -force" 129 } 130 131 set in [open $source] 132 133 if {$force eq "" && [file exists $target]} { 134 $in close 135 error "error copying \"$source\" to \"$target\": file already exists" 136 } 137 set out [open $target w] 138 $in copyto $out 139 $out close 140 } on error {msg opts} { 141 incr opts(-level) 142 return {*}$opts $msg 143 } finally { 144 catch {$in close} 145 } 146} 147 148# 'open "|..." ?mode?" will invoke this wrapper around exec/pipe 149# Note that we return a lambda which also provides the 'pid' command 150proc popen {cmd {mode r}} { 151 lassign [socket pipe] r w 152 try { 153 if {[string match "w*" $mode]} { 154 lappend cmd <@$r & 155 set pids [exec {*}$cmd] 156 $r close 157 set f $w 158 } else { 159 lappend cmd >@$w & 160 set pids [exec {*}$cmd] 161 $w close 162 set f $r 163 } 164 lambda {cmd args} {f pids} { 165 if {$cmd eq "pid"} { 166 return $pids 167 } 168 if {$cmd eq "close"} { 169 $f close 170 # And wait for the child processes to complete 171 foreach p $pids { os.wait $p } 172 return 173 } 174 tailcall $f $cmd {*}$args 175 } 176 } on error {error opts} { 177 $r close 178 $w close 179 error $error 180 } 181} 182 183# A wrapper around 'pid' which can return the pids for 'popen' 184local proc pid {{chan {}}} { 185 if {$chan eq ""} { 186 tailcall upcall pid 187 } 188 if {[catch {$chan tell}]} { 189 return -code error "can not find channel named \"$chan\"" 190 } 191 if {[catch {$chan pid} pids]} { 192 return "" 193 } 194 return $pids 195} 196 197# try/on/finally conceptually similar to Tcl 8.6 198# 199# Usage: try ?catchopts? script ?onclause ...? ?finallyclause? 200# 201# Where: 202# onclause is: on codes {?resultvar? ?optsvar?} script 203# 204# codes is: a list of return codes (ok, error, etc. or integers), or * for any 205# 206# finallyclause is: finally script 207# 208# 209# Where onclause is: on codes {?resultvar? ?optsvar?} 210proc try {args} { 211 set catchopts {} 212 while {[string match -* [lindex $args 0]]} { 213 set args [lassign $args opt] 214 if {$opt eq "--"} { 215 break 216 } 217 lappend catchopts $opt 218 } 219 if {[llength $args] == 0} { 220 return -code error {wrong # args: should be "try ?options? script ?argument ...?"} 221 } 222 set args [lassign $args script] 223 set code [catch -eval {*}$catchopts [list uplevel 1 $script] msg opts] 224 225 set handled 0 226 227 foreach {on codes vars script} $args { 228 switch -- $on \ 229 on { 230 if {!$handled && ($codes eq "*" || [info returncode $code] in $codes)} { 231 lassign $vars msgvar optsvar 232 if {$msgvar ne ""} { 233 upvar $msgvar hmsg 234 set hmsg $msg 235 } 236 if {$optsvar ne ""} { 237 upvar $optsvar hopts 238 set hopts $opts 239 } 240 # Override any body result 241 set code [catch [list uplevel 1 $script] msg opts] 242 incr handled 243 } 244 } \ 245 finally { 246 set finalcode [catch [list uplevel 1 $codes] finalmsg finalopts] 247 if {$finalcode} { 248 # Override any body or handler result 249 set code $finalcode 250 set msg $finalmsg 251 set opts $finalopts 252 } 253 break 254 } \ 255 default { 256 return -code error "try: expected 'on' or 'finally', got '$on'" 257 } 258 } 259 260 if {$code} { 261 incr opts(-level) 262 return {*}$opts $msg 263 } 264 return $msg 265} 266 267# Generates an exception with the given code (ok, error, etc. or an integer) 268# and the given message 269proc throw {code {msg ""}} { 270 return -code $code $msg 271} 272 273# Helper for "file delete -force" 274proc {file delete force} {path} { 275 foreach e [readdir $path] { 276 file delete -force $path/$e 277 } 278 file delete $path 279} 280