I had a need to control a serial device with a command-line interface from Windows. expect would be perfect for the job, but expect under Windows is, as of this writing, in an intermediate state of development. I did not want to use the cygwin version of expect. All the same, some kind of send-expect programming interface would make my task simpler.
Therefore, I used the expect man page to inspire the following "quickie" rendition of something expect-like in pure Tcl. It operates on a Tcl I/O channel and does the key part of expect, waiting for a response from the remote side, which may be embedded in stuff we don't care about. It does not do any of the very nice pseudo-tty stuff real expect does, nor does it include expect's send command. Use it with open and puts.
It works by converting its parameters into the parameters for switch, then reads the incoming channel a character at a time, testing the accumulated characters with switch each time.
Corrections, extensions, rewrites, or outright replacement with something better would be welcome. I've never had the pleasure of using genuine expect, so I apologize if I missed something important.
- SCT
#
# qexpect: "quasi-expect" or "quickie expect"
#
# Usage:
# qexpect channel [pat1 body1] ...
# qexpect channel { [pat1 body1] ... }
#
# Patterns use glob matching. The special pattern "eof" matches end of file.
# If a pattern starts with ^, it must match starting with the first character
# of the input. If a pattern ends with $, it must match ending with the last character
# received. If it neither begins with ^ nor ends with $, it may match at any point in
# the incoming character stream.
#
# Deficiencies:
# - no regexps
# - no timeout
# - does not use fileevent nor allow the Tcl event loop to run
#
# Originally written by Stephen Trier and placed in the public domain, March 2003.
#
proc qexpect {channel args} {
#
# Accept both a bracketed list and separate args
#
if {[llength $args] == 1} {
set args [lindex $args 0]
}
#
# Build the switch statement we will use for matching
#
set sw {}
set eofscript {}
foreach {match script} $args {
switch $match {
eof {
set eofscript $script
}
default {
if {[string index $match 0] eq {^}} {
set before {}
set match [string range $match 1 end]
} else {
set before *
}
if {[string index $match end] eq {$}} {
set after {}
set match [string range $match 0 end-1]
} else {
set after *
}
lappend sw ${before}${match}${after}
lappend sw "return \[uplevel 1 [list $script]\]"
}
}
}
#
# Gather characters from the stream and run them through our
# new switch statement.
#
set text {}
while 1 {
append text [read $channel 1]
switch -glob $text $sw
if {[eof $channel]} {
return [uplevel 1 $eofscript]
}
}
}JFL 2009-06-28: Here's an improved version adding support for timeouts, and functions like spawn and send.
JFL 2010-01-19 Added routine WaitForAll, to allow doing parallel waits on multiple commands.
Tested with both Windows and Linux programs.
It works very well with some programs, and not at all with others.
After much head scratching, I think the reasons are:
This is a major advantage of the real expect, which creates pseudo-ttys in Linux. This way, it works fine, even with programs that don't flush the prompt, or even worse programs that don't want to send a prompt when talking to another program.
#*****************************************************************************#
# #
# Namespace suspect #
# #
# Description Pure Tcl derivative of the expect program control procs. #
# #
# Usage # Example 1: Interact dynamically with one program #
# suspect::Import ; # Import commands into the global NS. #
# set channel [Spawn program args] ; # Open a cmd pipeline. #
# set pid [CVar $channel pid] ; # Get the pid of the prog. #
# Expect $channel ?options? switchBlock ; # Wait 4 strings. #
# set data [CVar $channel received] ; # Get all until match.#
# Send $channel "Do this\r" ; # Send a command. #
# ... ; # Repeat as many times as necessary. #
# Close $channel ; # Close the pipeline and free variables. #
# #
# # Example 2: Run several programs in parallel and wait #
# # for their completion (in any order) #
# proc OnProgramExit {channel} { # Callback run on pgm exit #
# set output [CVar $channel received] ; # Program output #
# set exitCode [CVar $channel exitCode] ; # Pgm exit code #
# Close $channel ; # Close the pipeline and free vars. #
# } #
# suspect::Import ; # Import commands into the global NS. #
# set channels {} ; # List of open command pipelines #
# lappend channels [Spawn program1 args] ; # Start program1 #
# ... #
# lappend channels [Spawn programN args] ; # Start programN #
# WaitForAll $channels -onEOF OnProgramExit ; # Wait 4 exit #
# #
# Notes The routines are not compatible with expect, in an #
# attempt to fix some of expect's shortcomings: #
# - expect uses global variables, which makes it difficult #
# to interact with several pipelines at the same time. #
# All suspect functions use a pipeline handle, and store #
# data in pipeline-specific namespace variables. #
# - I've been bitten by some powerful, but dangerous, #
# options of the expect routine. These were disabled #
# here. See the Expect routine header below for details. #
# #
# Known issues: #
# - Expect will fail (actually time-out) if the pipelined #
# program does not flush its prompt output. (Even if that #
# program does work fine when invoked in the shell.) #
# - It will also fail with programs that require a pseudo- #
# tty to send a prompt. (One of the big superiorities of #
# the real expect!) #
# #
# History #
# 2003/03 ST Sample code written by Stephen Trier and placed in the #
# public domain. See: https://wiki.tcl-lang.org/8531 #
# 2009/06/18 JFL Created these routines, loosely based on ST's sample code.#
# 2009/07/09 JFL Added routine WaitForAll, to do parallel waits. #
# #
#*****************************************************************************#
namespace eval suspect {
variable timeout 10 ; # Default timeout, in seconds. 0 = No timeout.
# Define a public procedure, exported from this namespace
proc xproc {name args body} {
namespace export $name
proc $name $args $body
variable xprocs ; # List of all procedures exported from this namespace.
lappend xprocs $name
}
# Import all public procedures from this namespace into the caller's namespace.
proc Import {{pattern *}} {
namespace eval [uplevel 1 namespace current] \
"namespace import -force [namespace current]::$pattern"
# Duplicate Tcl execution trace operations, if any.
variable xprocs ; # List of all procedures exported from this namespace.
catch { # This will fail in Tcl <= 8.3
foreach proc $xprocs {
foreach trace [trace info execution [namespace current]::$proc] {
foreach {ops cmd} $trace break
uplevel 1 [list trace add execution $proc $ops $cmd]
}
}
}
}
# Remove an argument from the head of a routine argument list.
proc PopArg {{name args}} {
upvar 1 $name args
set arg [lindex $args 0] ; # Extract the first list element.
set args [lrange $args 1 end] ; # Remove the first list element.
return $arg
}
# Get the error code returned by an external program
proc ErrorCode {{err -1}} { # err = The TCL error caught when executing the program
if {$err != 0} { # $::errorCode is only meaningful if we just had an error.
switch [lindex $::errorCode 0] {
NONE { # The exit code _was_ 0, only pollution on stderr.
return 0
}
CHILDSTATUS { # Non-0 exit code.
return [lindex $::errorCode 2]
}
POSIX { # Program failed to start, or was killed.
return -1
}
}
}
return $err
}
# Get/Set a channel-specific variable
xproc CVar {channel var args} {
variable $channel
if {$args eq {}} {
set ${channel}($var)
} else {
set ${channel}($var) [join $args {}]
}
}
proc CAppend {channel var args} {
variable $channel
append ${channel}($var) [join $args {}]
}
# Open a command pipeline
xproc Spawn args {
if {$args eq {}} {
error "Spawn: No command specified"
}
set channel [open "|$args" RDWR]
set msStart [clock clicks -milliseconds]
CVar $channel msStart $msStart ; # Record the startup time
CVar $channel msStop $msStart ; # Make sure it's defined (In case of timeout)
fconfigure $channel -blocking 0 -buffering none
set ns [namespace current]
fileevent $channel readable "${ns}::TriggerEvent $channel readable 1"
# fileevent $channel writable "${ns}::TriggerEvent $channel writable 1"
CVar $channel cmd $args ; # Record the command line for future diagnostics.
CVar $channel pid [pid $channel] ; # Record the pipeline pid
return $channel
}
# Send data to the command pipeline.
xproc Send {channel string} {
puts -nonewline $channel $string
# flush $channel ; # Useful only in buffering line mode
}
# Manage pipe I/O events
proc TriggerEvent {channel event {value 1}} {
CVar $channel $event $value ; # Set the channel-specific event variable
variable events
lappend events [list $channel $event $value] ; # Useful for parallel waits
}
proc WaitEvent {channel event} {
vwait [namespace current]::${channel}($event)
CVar $channel $event
}
# Read from channel, with an optional timeout. Event driven, using vwait.
proc Read {channel args} { # Usage: Read channel [N]
set readCmd [linsert $args 0 read $channel] ; # The read command
set readable [WaitEvent $channel readable]
if {!$readable} {
error TIMEOUT
}
if {[eof $channel]} {
CVar $channel msStop [clock clicks -milliseconds]
error EOF
}
set data [eval $readCmd] ; # Read the requested data.
return $data
}
#-----------------------------------------------------------------------------#
# #
# Function Expect #
# #
# Description Pure Tcl derivative of the expect command #
# #
# Parameters channel R/W channel to a command pipeline #
# OPTIONS See the options list below #
# switchBlock The various alternatives and action #
# #
# Options -exact Use exact strings matching (default) #
# -glob Use glob-style matching #
# -regexp Use regular expressions matching #
# -timeout N Timeout after N seconds. Default: 10 #
# -onTIMEOUT BLOCK What to do in case of timeout #
# -onEOF BLOCK What to do in case of End Of File #
# #
# Returns User defined. By default: Nothing if found, or errors out #
# in case of EOF or TIMEOUT. #
# #
# Notes This routine is incompatible with the real expect on #
# purpose, to fix some of its shortcomings: #
# - expect's ability to specify either one switch block, or #
# multiple block items (Like Tcl's own exec), is nice in #
# simple cases, but always backfires when the program #
# complexity grows. suspect::Expect requires one block. #
# - I've been bitten by expect's inability to expect the #
# word timeout. (I found the workaround, but too late.) #
# suspect::Expect handles EOF and TIMEOUT in options only.#
# - expect allows options within the switch block. Very #
# powerful to use distinct search criteria for distinct #
# strings. But at the cost of making these very options #
# difficult to be themselves expected. suspect::Expect #
# only allows options before the switch block. #
# #
# Things like exp_continue are not yet supported. #
# #
# History #
# 2009/06/18 JFL Created these routines, loosely based on ST's sample code.#
# #
#-----------------------------------------------------------------------------#
xproc Expect {channel args} { # Usage: Expect channel [options] switchBlock
# Namespace variables
variable timeout
# Local variables
set sMode -exact ; # Switch mode. One of: -exact -glob -regexp
set msTimeout [expr 1000 * $timeout] ; # Timeout, in milli-seconds
set onEof "error {Expect: EOF reading from command pipeline $channel :\
[CVar $channel cmd]}" ; # What to do in case of end of file
set onTimeout "error {Expect: TIMEOUT waiting for command pipeline $channel :\
[CVar $channel cmd]}" ; # What to do in case of timeout
# Separate the last switch block from the options
if {$args eq {}} {
error "Expect: No switch block defined."
}
set expectBlock [lindex $args end]
set args [lrange $args 0 end-1]
# Process the options
while {$args ne {}} {
set opt [PopArg]
switch $opt {
-exact - -glob - -regexp {
set sMode $opt
}
-onEOF - eof {
set onEof [PopArg]
}
-onTIMEOUT - timeout {
set onTimeout [PopArg]
}
-timeout {
set msTimeout [expr [PopArg] * 1000]
}
default {
error "Expect: Unsupported option $opt"
}
}
}
# Build the switch statement we will use for matching
set switchBlock {}
foreach {match script} $expectBlock {
set match0 $match
set before {}
set after {}
switch $sMode {
-exact {
set before {***=}
}
-glob {
if {[string index $match 0] eq "^"} {
set match [string range $match 1 end]
} else {
set before *
}
if {[string index $match end] eq "\$"} {
set match [string range $match 0 end-1]
} else {
set after *
}
}
}
lappend switchBlock $before$match$after
lappend switchBlock "
after cancel \$idTimeout
set channelVar(match) [list $match0] ;
return \[uplevel 1 [list $script]\]"
}
if {$sMode eq {-exact}} {
set sMode -regexp
}
# Manage optional timeouts
set idTimeout {} ; # "after cancel $idTimeout" will silently ignore this id.
set ns [namespace current]
if {$msTimeout} {
set idTimeout [after $msTimeout [list ${ns}::TriggerEvent $channel readable 0]]
}
# Gather characters from the channel and run them through our new switch statement.
CVar $channel received {}
while 1 {
if {[catch {set c [Read $channel 1]} errMsg]} {
switch $errMsg {
TIMEOUT {
return [uplevel 1 $onTimeout]
}
EOF {
after cancel $idTimeout
return [uplevel 1 $onEof]
}
default {
error "Error reading $channel: $errMsg"
}
}
}
CAppend $channel received $c
switch $sMode [CVar $channel received] $switchBlock
}
}
# Common case where we expect a single exact string
xproc ExpectString {channel string} {
Expect $channel [list $string]
}
# Close a command pipeline, and return the program exit code.
xproc CloseCommand channel {
variable $channel
if {[info exists ${channel}(exitCode)]} {
return [CVar $channel exitCode]
}
fconfigure $channel -blocking 1 ; # Make sure close checks for the exit code
set err [catch {close $channel} errMsg] ; # Get the Tcl error code
set err [ErrorCode $err] ; # Get the command exit code
CVar $channel exitCode $err
return $err
}
# Close a command pipeline, and free all local resources. Return the exit code.
xproc Close channel {
variable $channel
set err 0
if {[info exists $channel]} {
set err [CloseCommand $channel] ; # Get the command exit code
unset $channel
}
return $err
}
#-----------------------------------------------------------------------------#
# #
# Function WaitForAll #
# #
# Description Wait for the completion of several parallel programs #
# #
# Parameters channels List of spawned tasks #
# -onEOF proc Call $proc $channel after each EOF. #
# #
# Returns Nothing, or errors out in case of TIMEOUT. #
# #
# Notes Timeout out not implemented yet. #
# #
# History #
# 2009/07/09 JFL Created this routine. #
# 2009/09/28 JFL Added the -onEOF option. #
# #
#-----------------------------------------------------------------------------#
xproc WaitForAll {channels args} {
variable events
set onEOF ""
# Process the options
while {$args ne {}} {
set opt [PopArg]
switch $opt {
-onEOF - eof {
set onEOF [PopArg]
}
default {
error "WaitForAll: Unsupported option $opt"
}
}
}
# Wait for the EOF on all channels
set nLeft [llength $channels]
foreach channel $channels {
# fconfigure $channel -buffering full ; # Minimize the # of read events.
}
while {$nLeft} {
vwait [namespace current]::events
foreach event $events {
foreach {channel event value} $event break
if {($event ne {readable}) || ($value != 1)} continue
set input [read $channel]
CAppend $channel received $input
if {[eof $channel] && ([set ix [lsearch $channels $channel]] != -1)} {
CVar $channel msStop [clock clicks -milliseconds]
set channels [lreplace $channels $ix $ix]
incr nLeft -1
if {$onEOF ne {}} {
eval $onEOF $channel
}
}
}
set events {}
}
}
} ; # End of namespace suspectHere's the test program, written in C, that I used to show the need for a flush after sending the prompt.
/* Test the impact of C output buffering on Tcl's command pipe input.
Simulates an interactive program that outputs a prompt, and processes commands. */
#include <stdio.h>
#include <string.h>
#define BUFSIZE 1024
#define streq(s1,s2) (!strcmp(s1,s2))
char szUsage[] = "Usage: %s [options]\n\
\n\
Options:\n\
-f Enable flushing the prompt output. (default)\n\
-F Disable flushing the prompt output.\n\
-h|-? Display this help screen.\n\
";
int main(int argc, char*argv[]) {
char buf[BUFSIZE] = "";
int i, n;
int iFlush = 1;
for (i=1; i<argc; i++) {
char *arg = argv[i];
if (streq(arg,"-f")) { // Do flush the prompt
iFlush = 1;
continue;
}
if (streq(arg,"-F")) { // Don't flush the prompt
iFlush = 0;
continue;
}
if (streq(arg,"-h") ||
streq(arg,"-?") ||
streq(arg,"/?") ||
streq(arg,"--help")) { // Display help
printf(szUsage, argv[0]);
exit(0);
}
printf("Unexpected argument %s\n", arg);
exit(1);
}
puts("Type exit to end this program.");
while (strncmp(buf, "exit", 4)) {
fputs("prompt>",stdout);
if (iFlush) fflush(stdout);
fgets(buf, BUFSIZE, stdin);
n = strlen(buf);
printf("Got %d characters: ", n);
for (i=0; i<n; i++) {
char c = buf[i];
if (c >= ' ') {
printf("%c", c);
} else switch (c) {
case '\n':
printf("\\n");
break;
case '\r':
printf("\\r");
break;
default:
printf("\\x%02X", c);
break;
}
}
printf("\n");
if (iFlush) fflush(stdout);
}
return 0;
}MHo 2012-01-03: Cannot figure out how to drive passwd with this tool on solaris.
passwd and other programs like it issue their prompt and read the input from "/dev/tty", not stdout/stdin. You need expect which does the "real" thing by managing pseudo terminals.