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:

   * The spawned program must flush its prompt. If not, Tcl will fail to read anything. Even if that prompt gets displayed properly when the said program is invoked directly at the shell prompt. Why???
   * The spawned program must not require a Linux TTY to send a prompt. (This is a major advantage of the real expect, which creates pseudo-ttys in Linux.)

===
#*****************************************************************************#
#                                                                             #
#   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 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;
}
===

----

[Category Expect]