Martin Lemburg - 02.10.2002:
To execute and control a FORTRAN executable I've chosen to use open this executable using a pipe. The only things to be done is to configure the resulting channel and to setup the event handlers for the events readable and/or writable. But ... it's true, it depends not on a FORTRAN executable, any executable could be handled like that.
Here the pkgIndex.tcl code:
package ifneeded runExe 1.0 [list source [file join $dir runExe.tcl]];
Here the package runExe code:
uplevel #0 {
global auto_path env;
if {[lsearch -exact $auto_path [file dirname [info script]]] < 0} {
lappend auto_path [file dirname [info script]];
}
package provide runExe 1.0;
proc runExe {args} {
if {![llength $args]} {
error "runExe option ?arg arg ...?";
}
set options {run stop cleanup running};
set option [lindex $args 0];
set args [lrange $args 1 end];
if {[set idx [lsearch -glob $options ${option}*]] >= 0} {
return [eval runExe::[lindex $options $idx] $args];
}
error "bad option \"$option\": must be [join [linsert [join [lsort -dictionary $options] {, }] end-1 {or}]]";
}
}
namespace eval ::runExe {
variable executables;
proc this {} "return [namespace current];";
# proc run
#
# args
#
# executable - name of the executable and all parameters
# mode - access mode to the pipe to be created (r, r+, w, or w+)
# blocking - flag to signal if this proc should wait until the executable
# is finished
# callback - script to be executed to prepare the execution, to return input
# for the executable, to get output of the executable, to be the
# execution finish callback. Must be given, if blocking is disabled!
# timeout - double value in seconds, 0 disables the timeout handler
# outputVar - (optional) name of the name of a variable to contain the
# output of the executable
#
proc run {executable mode blocking callback timeout {outputVar ""}} {
if {[lsearch -exact {r r+ w w+} $mode] < 0} {
error "bad mode \"$mode\": must be r, r+, w, or w+";
}
if {![string is boolean -strict $blocking]} {
error "expected valid boolean as blocking flag, but got \"$blocking\"";
}
if {![string is double -strict $timeout]} {
error "expected valid double as timeout in seconds, but got \"$timeout\"";
}
if {!$blocking && ($callback == "")} {
error "expected callback script, because blocking is disabled";
}
# (re)set the variable to store outputs of the executable in
#
if {$outputVar != ""} {
global $outputVar;
set $outputVar "";
}
# do preparations to be done before starting the executable
#
if {$callback != ""} {
execCallback $callback prepare $executable $blocking 0 0 $outputVar;
}
if {[catch {set pid [open "|$executable" r];} reason]} {
error "couldn't run executable with \"$executable\": $reason";
}
# set the process related variables
#
set [this]::executables($pid.executable) $executable;
set [this]::executables($pid.success) -1;
set [this]::executables($pid.blocking) $blocking;
set [this]::executables($pid.callback) $callback;
set [this]::executables($pid.after) "";
set [this]::executables($pid.timeout) $timeout;
set [this]::executables($pid.outputVar) $outputVar;
# start if wanted the timeout handler
#
if {$timeout} {
set [this]::executables($pid.after) [after \
[expr {int($timeout * 1000)}] \
[list [this]::timeoutCB $pid] \
];
}
# configure the process channel
#
fconfigure $pid -buffering none -blocking 0;
if {[lsearch {r r+ w+} $mode] >= 0} {
fileevent $pid readable [list [this]::inCB $pid];
}
if {[lsearch {r+ w w+} $mode] >= 0} {
fileevent $pid readable [list [this]::outCB $pid];
}
# let this proc wait if blocking is wanted
# and set the return value depending on the blocking flag
#
if {$blocking} {
if {[info commands tk] == ""} {
vwait [this]::executables($pid.success);
} else {
tkwait variable [this]::executables($pid.success);
}
set result [set [this]::executables($pid.success)];
cleanup $pid;
} elseif {!$blocking && ($callback != "")} {
set result $pid;
}
return $result;
}
proc stop {pid} {
if {[running $pid]} {
finishCB $pid;
}
cleanup $pid;
return;
}
proc cleanup {pid} {
array unset [this]::executables $pid.*;
return;
}
proc running {pid} {
if {[array names [this]::executables $pid.*] == ""} {
return 0;
}
if {([file channels $pid] == "") || [eof $pid]} {
return 0;
}
return 1;
}
proc execCallback {callback mode executable blocking success timeout outputVar args} {
# replace all substitutes for ...
# %m = execution mode of the blocking command (prepare, input, output or finished)
# %e = name of the executable (including all parameters)
# %s = success flag (boolean)
# %t = timeout flag (boolean)
# %o = output variable contents
# %O = name of the output variable
#
regsub -all -- {%m} $callback $mode callback;
regsub -all -- {%e} $callback $executable callback;
regsub -all -- {%b} $callback $blocking callback;
regsub -all -- {%s} $callback $success callback;
regsub -all -- {%t} $callback $timeout callback;
regsub -all -- {%O} $callback $outputVar callback;
if {$outputVar != ""} {
global $outputVar;
set output [set $outputVar];
} else {
set output "";
}
regsub -all -- {%o} $callback $output callback;
# execute the blocking command (or callback)
#
return [uplevel #0 $callback $args];
}
proc finishCB {pid {timeout 0}} {
if {[set [this]::executables($pid.after)] != ""} {
after cancel [set [this]::executables($pid.after)];
}
fileevent $pid readable {};
fconfigure $pid -blocking 1;
if {[catch {close $pid;}] || $timeout} {
set [this]::executables($pid.success) 0;
} else {
set [this]::executables($pid.success) 1;
}
# set the output variable, if given
#
set outputVar [set [this]::executables($pid.outputVar)];
if {$outputVar != ""} {
global $outputVar;
set $outputVar [join [set $outputVar] "\n"];
}
# execute the callback, if set
#
set callback [set [this]::executables($pid.callback)];
if {$callback != ""} {
execCallback \
$callback \
finished \
[set [this]::executables($pid.executable)] \
[set [this]::executables($pid.blocking)] \
[set [this]::executables($pid.success)] \
$timeout \
[set [this]::executables($pid.outputVar)];
}
return;
}
proc inCB {pid} {
if {[eof $pid]} {
finishCB $pid;
} else {
set outputVar [set [this]::executables($pid.outputVar)];
if {$outputVar != ""} {
upvar #0 $outputVar dummy;
}
lappend dummy [set output [read $pid]];
execCallback \
[set [this]::executables($pid.callback)] \
output \
[set [this]::executables($pid.executable)] \
[set [this]::executables($pid.blocking)] \
[set [this]::executables($pid.success)] \
[set [this]::executables($pid.timeout)] \
[set [this]::executables($pid.outputVar)] \
$output;
}
return;
}
proc outCB {pid} {
if {[eof $pid]} {
finishCB $pid;
} else {
puts $pid [execCallback \
[set [this]::executables($pid.callback)] \
input \
[set [this]::executables($pid.executable)] \
[set [this]::executables($pid.blocking)] \
[set [this]::executables($pid.success)] \
[set [this]::executables($pid.timeout)] \
[set [this]::executables($pid.outputVar)] \
];
flush $pid;
}
return;
}
proc timeoutCB {pid} {
if {[file channels $pid] != ""} {
finishCB $pid 1;
}
return;
}
namespace export [list run stop cleanup running];
}