aboutsummaryrefslogtreecommitdiff
path: root/tclcompat.tcl
blob: 2a5560c2cc3e3d4f860de00eda688edbf7975958 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
# Loads some Tcl-compatible features.
# I/O commands, case, lassign, parray, errorInfo, ::tcl_platform, ::env
# try, throw, file copy, file delete -force
#
# (c) 2008 Steve Bennett <steveb@workware.net.au>


# Set up the ::env array
set env [env]

# Provide Tcl-compatible I/O commands
if {[info commands stdout] ne ""} {
	# Tcl-compatible I/O commands
	foreach p {gets flush close eof seek tell} {
		proc $p {chan args} {p} {
			tailcall $chan $p {*}$args
		}
	}
	unset p

	# puts is complicated by -nonewline
	#
	proc puts {{-nonewline {}} {chan stdout} msg} {
		if {${-nonewline} ni {-nonewline {}}} {
			tailcall ${-nonewline} puts $msg
		}
		tailcall $chan puts {*}${-nonewline} $msg
	}

	# read is complicated by -nonewline
	#
	# read chan ?maxchars?
	# read -nonewline chan
	proc read {{-nonewline {}} chan} {
		if {${-nonewline} ni {-nonewline {}}} {
			tailcall ${-nonewline} read {*}${chan}
		}
		tailcall $chan read {*}${-nonewline}
	}

	proc fconfigure {f args} {
		foreach {n v} $args {
			switch -glob -- $n {
				-bl* {
					$f ndelay $(!$v)
				}
				-bu* {
					$f buffering $v
				}
				-tr* {
					# Just ignore -translation
				}
				default {
					return -code error "fconfigure: unknown option $n"
				}
			}
		}
	}
}

# fileevent isn't needed in Jim, but provide it for compatibility
proc fileevent {args} {
	tailcall {*}$args
}

# Second, option argument is a glob pattern
# Third, optional argument is a "putter" function
#
proc parray {arrayname {pattern *} {puts puts}} {
	upvar $arrayname a

	set max 0
	foreach name [array names a $pattern]] {
		if {[string length $name] > $max} {
			set max [string length $name]
		}
	}
	incr max [string length $arrayname]
	incr max 2
	foreach name [lsort [array names a $pattern]] {
		$puts [format "%-${max}s = %s" $arrayname\($name\) $a($name)]
	}
}

# Implements 'file copy' - single file mode only
proc {file copy} {{force {}} source target} {
	try {
		if {$force ni {{} -force}} {
			error "bad option \"$force\": should be -force"
		}

		set in [open $source]

		if {[file exists $target]} {
			if {$force eq ""} {
				error "error copying \"$source\" to \"$target\": file already exists"
			}
			# If source and target are the same, nothing to do
			if {$source eq $target} {
				return
			}
			# Hard linked, or case-insensitive filesystem
			# Note: mingw returns ino=0 for every file :-(
			file stat $source ss
			file stat $target ts
			if {$ss(dev) == $ts(dev) && $ss(ino) == $ts(ino) && $ss(ino)} {
				return
			}
		}
		set out [open $target w]
		$in copyto $out
		$out close
	} on error {msg opts} {
		incr opts(-level)
		return {*}$opts $msg
	} finally {
		catch {$in close}
	}
}

# 'open "|..." ?mode?" will invoke this wrapper around exec/pipe
# Note that we return a lambda which also provides the 'pid' command
proc popen {cmd {mode r}} {
	lassign [socket pipe] r w
	try {
		if {[string match "w*" $mode]} {
			lappend cmd <@$r &
			set pids [exec {*}$cmd]
			$r close
			set f $w
		} else {
			lappend cmd >@$w &
			set pids [exec {*}$cmd]
			$w close
			set f $r
		}
		lambda {cmd args} {f pids} {
			if {$cmd eq "pid"} {
				return $pids
			}
			if {$cmd eq "close"} {
				$f close
				# And wait for the child processes to complete
				foreach p $pids { os.wait $p }
				return
			}
			tailcall $f $cmd {*}$args
		}
	} on error {error opts} {
		$r close
		$w close
		error $error
	}
}

# A wrapper around 'pid' which can return the pids for 'popen'
local proc pid {{channelId {}}} {
	if {$channelId eq ""} {
		tailcall upcall pid
	}
	if {[catch {$channelId tell}]} {
		return -code error "can not find channel named \"$channelId\""
	}
	if {[catch {$channelId pid} pids]} {
		return ""
	}
	return $pids
}

# try/on/finally conceptually similar to Tcl 8.6
#
# Usage: try ?catchopts? script ?onclause ...? ?finallyclause?
#
# Where:
#   onclause is:       on codes {?resultvar? ?optsvar?} script
#
#   codes is: a list of return codes (ok, error, etc. or integers), or * for any
#
#   finallyclause is:  finally script
#
#
# Where onclause is: on codes {?resultvar? ?optsvar?}
proc try {args} {
	set catchopts {}
	while {[string match -* [lindex $args 0]]} {
		set args [lassign $args opt]
		if {$opt eq "--"} {
			break
		}
		lappend catchopts $opt
	}
	if {[llength $args] == 0} {
		return -code error {wrong # args: should be "try ?options? script ?argument ...?"}
	}
	set args [lassign $args script]
	set code [catch -eval {*}$catchopts [list uplevel 1 $script] msg opts]

	set handled 0

	foreach {on codes vars script} $args {
		switch -- $on \
			on {
				if {!$handled && ($codes eq "*" || [info returncode $code] in $codes)} {
					lassign $vars msgvar optsvar
					if {$msgvar ne ""} {
						upvar $msgvar hmsg
						set hmsg $msg
					}
					if {$optsvar ne ""} {
						upvar $optsvar hopts
						set hopts $opts
					}
					# Override any body result
					set code [catch [list uplevel 1 $script] msg opts]
					incr handled
				}
			} \
			finally {
				set finalcode [catch [list uplevel 1 $codes] finalmsg finalopts]
				if {$finalcode} {
					# Override any body or handler result
					set code $finalcode
					set msg $finalmsg
					set opts $finalopts
				}
				break
			} \
			default {
				return -code error "try: expected 'on' or 'finally', got '$on'"
			}
	}

	if {$code} {
		incr opts(-level)
		return {*}$opts $msg
	}
	return $msg
}

# Generates an exception with the given code (ok, error, etc. or an integer)
# and the given message
proc throw {code {msg ""}} {
	return -code $code $msg
}

# Helper for "file delete -force"
proc {file delete force} {path} {
	foreach e [readdir $path] {
		file delete -force $path/$e
	}
	file delete $path
}