diff options
author | Steve Bennett <steveb@workware.net.au> | 2010-09-28 08:09:39 +1000 |
---|---|---|
committer | Steve Bennett <steveb@workware.net.au> | 2010-10-15 11:02:56 +1000 |
commit | 4dd7c62a513ffafa080419f9848c601921b45da5 (patch) | |
tree | 8386a03084d351cda4d73d101573fd65d65022d6 /tclcompat.tcl | |
parent | bc87d7fb591121937761c433823dd14ce4781151 (diff) | |
download | jimtcl-4dd7c62a513ffafa080419f9848c601921b45da5.zip jimtcl-4dd7c62a513ffafa080419f9848c601921b45da5.tar.gz jimtcl-4dd7c62a513ffafa080419f9848c601921b45da5.tar.bz2 |
Implement 'pid handle'
Signed-off-by: Steve Bennett <steveb@workware.net.au>
Diffstat (limited to 'tclcompat.tcl')
-rw-r--r-- | tclcompat.tcl | 32 |
1 files changed, 27 insertions, 5 deletions
diff --git a/tclcompat.tcl b/tclcompat.tcl index 6c981b7..c632103 100644 --- a/tclcompat.tcl +++ b/tclcompat.tcl @@ -163,19 +163,26 @@ proc {file copy} {{force {}} source target} { } # '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 & - exec {*}$cmd + set pids [exec {*}$cmd] $r close - return $w + set f $w } else { lappend cmd >@$w & - exec {*}$cmd + set pids [exec {*}$cmd] $w close - return $r + set f $r + } + lambda {cmd args} {f pids} { + if {$cmd eq "pid"} { + return $pids + } + tailcall $f $cmd {*}$args } } on error {error opts} { $r close @@ -184,6 +191,21 @@ proc popen {cmd {mode r}} { } } +# A wrapper around 'pid' which can return the pids for 'popen' +rename pid .pid +proc pid {{chan {}}} { + if {$chan eq ""} { + tailcall .pid + } + if {[catch {$chan tell}} { + return -code error "can not find channel named \"$chan\"" + } + if {[catch {$chan pid} pids} { + return "" + } + return $pids +} + # try/on/finally conceptually similar to Tcl 8.6 # # Usage: try ?catchopts? script ?onclause ...? ?finallyclause? @@ -260,4 +282,4 @@ proc throw {code {msg ""}} { return -code $code $msg } -set ::tcl_platform(platform) unix +set tcl_platform(platform) unix |