/usb-modeswitch-1.2.3/jim/tclcompat.tcl

  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}