if 0 {
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 seperate 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.
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:
#*****************************************************************************# # # # Namespace suspect # # # # Description Pure Tcl derivative of the expect program control procs. # # # # Usage 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. # # # # 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: http://wiki.tcl.tk/8531 # # 2009/06/18 JFL Created these routines, loosely based on ST's sample code.# # # #*****************************************************************************# 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/Set a channel-specific variable xproc CVar {channel var args} { variable $channel if {"$args" == ""} { 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" == ""} { error "Spawn: No command specified" } set channel open "|$args" RDWR 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 } 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 { 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" == ""} { error "Expect: No switch block defined." } set expectBlock lindex $args end set args lrange $args 0 end-1 # Process the options while {"$args" != ""} { 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" == "-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 "${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 free all local resources. xproc Close {channel} { close $channel variable $channel if info exists $channel { unset $channel } } } ; # End of namespace suspect
Here's the test program, written in C, that I used to show the need for a flush after sending the prompt.
Any explanation as to why that flush is necessary for Tcl to read the prompt, but not necessary for the shell to read that same prompt, is welcome!
/* 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 bufBUFSIZE = ""; int i, n; int iFlush = 1; for (i=1; i<argc; i++) { char *arg = argvi; 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, argv0); 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 = bufi; 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; }