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.
I wrote a package named runExe. I need this package explicitely to control a FORTRAN executable doing calculations. This package works with an callback, which is called when ...
The bold words above are the keywords the callback could rely on to determine, which mode is currently active.
The callback could contain substitutes (like bind callbacks), which are replaced before the execution of the callback:
If the callback is called in the input mode, than to the callback retrieves as additional argument the text the executable delivered. If the callback is called in the output mode, than the callback has to return the text to be send to the executable.
So the callback should be written like this:
proc executableCallback { ... args } {
...
return $output;
}AM (See also Managing Fortran programs for details on the Fortran side.) I like this package, but could you perhaps add a worked-out example?
Martin Lemburg - 04.10.2002:
Sorry, the only really working example is one I can't really publish.
I developed this package to be used to control external "machine controller software".
As explaination:
I work in a team that works on a simulation software to simulate presslines, dies, die kinematics for sheet metal manifacturing.
We have the need to use pressline manifacture software, calculating the movement of pressline components - called controllers. Most of these controllers are "old" or have to do so much mathmatics, that they are written in FORTRAN. So we have external blackboxes doing the calculations and all we have to do is giving information to this blackboxes and to extract the needed information from the blackboxes calculation results.
This package works for "our" controllers, but none of them needs input via stdin!
I use this package in the way, that my callback prepares the information to be handed to the controller blackboxes, if called in the prepare mode. Called in the finished mode, the callback extracts the needed information from the calculation results. My callback doesn't react on the input and output modes.
So much about my usage, but ... sorry ... I can't tell really more.
AM No problem, there are at least two people (including myself :-) interested in this type of things. So, a small, though trivial example might help out. Perhaps a slight adaptation of my example (see the referenced page) could achieve just that.
Martin Lemburg - 04.10.2002:
Ok, I added an example at the bottom of the page!
Syntax:
runExe options ?arg arg ...?
runExe run executable mode blocking callback timeout ?outputvar?
Description:
Arguments:
Result:
runExe stop pid
Description:
Arguments:
Result:
runExe cleanup pid
Description:
Arguments:
Result:
runExe running pid
Description:
Arguments:
Result:
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" $mode];} 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 {[file channels $pid] == ""} {
return;
}
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]];
if {$output != ""} {
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 {[file channels $pid] == ""} {
return;
}
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];
}Example:
This example has two procedures (both inside a namespace):
variable blackboxDir .;
variable pwd "";
proc calc {args} {
if {([set argsc [llength $args]] < 4) || ($argsc > 10) || ($argsc % 2)} {
error "wrong # args: should be \"calc ?options? scheme strokeRate xPitch yPitch\"";
}
# parse options (possible are: -moveto, -outputvar, -timeout)
#
set matched 0;
foreach {name var type default} {
-moveto moveTo "" ""
-outputvar outputVar "" ""
-timeout timeout double 0
} {
if {![info exists $var]} {
set $var $default;
}
foreach {option value} $args {
if {![string match {-*} $option]} {
set matched 1;
break;
}
if {[string length $option] <= 2} {
error "bad option \"$option\": must be -moveto, or -outputvar";
}
if {[string equal -length [string length $option] $option $name]} {
if {($type == "") || [string is $type -strict $value]} {
set $var $value;
set matched 1;
set args [lreplace $args 0 1];
break;
} else {
error "expected $type value for $name, but got \"$value\"";
}
}
}
if {!$matched} {
error "bad option \"$option\": must be -moveto, or -outputvar";
}
}
if {[llength $args] != 4} {
error "wrong # args: should be \"calc ?options? scheme strokeRate xPitch yPitch\"";
}
# validating the given arguments
#
foreach {scheme strokeRate xPitch yPitch} $args {break;};
if {![string is double -strict $strokeRate]} {
error "expected valid double as strokes per minute, but got \"$strokeRate\"";
}
if {![string is double -strict $xPitch]} {
error "expected valid double as horizontal transfer pitch, but got \"$xPitch\"";
}
if {![string is double -strict $yPitch]} {
error "expected valid double as vertical transfer pitch, but got \"$yPitch\"";
}
# run the blackbox
#
variable blackboxDir;
if {$moveTo == ""} {
set moveTo [file join $blackboxDir $scheme];
}
return [runExe run \
[file join $blackboxDir bin blackbox] r \
1 [list ExecCB %m $scheme $strokeRate $xPitch $yPitch $moveTo] \
$timeout \
$outputVar \
];
}
proc ExecCB {mode scheme strokeRate xPitch yPitch moveTo args} {
switch -exact -- $mode {
prepare {
variable blackboxDir;
variable pwd;
# create the input data/file for the controller
# based on a scheme/template
#
Prepare $scheme $strokeRate $xPitch $yPitch;
# delete eventually existing output data/files,
# because the controller won't work if existent
#
Delete;
set pwd [pwd];
cd [file join $blackboxDir bin];
}
finished {
variable pwd;
cd $pwd;
# move the output data to the scheme directory
# or another given directory
#
Move $moveTo;
}
}
return;
}