Expect.pl, alpha release

[Randal Schwartz]

Well, here it is.  The motivation for writing this package is the fact
that Don Libes doesn't like Perl. :-)

Anyway, this is an ALPHA release of an 'expect' emulation written as a
Perl package.  There are still some things to add to this, but the
basics (spawning multiple interactive processes, then interacting with
them watching their output through regexps and timeouts) are all
there.  And useful too... I'm already writing code that uses these
subroutines, and it's slick.

The matchup of expect<->tcl and expect.pl<->Perl made for some weird
design tradeoffs.  I may start from mostly scratch and do everything
right.  That is probably why I hesitate to implement the rest of the
functions... they really don't fit in a Perl environment.

Many thanks to Larry Wall.  He wrote about 1/3 of the trickier code,
and egged me on to do this.  (He's tired of people remarking "Why
should I use Perl when it can't do what expect does?"  Now you can
have both in one interpreter. :-)

This code will be revised when I get a Perl that has "caller".  Stay
tuned to comp.lang.perl for details.

&spawn(CAT,"cat");&send(CAT,"Just another Perl hacker,");&close(CAT);

#! /bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#		"End of shell archive."
# Contents:  expect.pl
# Wrapped by merlyn at iwarpse on Thu Nov  1 16:25:12 1990
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'expect.pl' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'expect.pl'\"
else
echo shar: Extracting \"'expect.pl'\" \(9287 characters\)
sed "s/^X//" >'expect.pl' <<'END_OF_FILE'
X## expect.pl rev ALPHA.1.01 01-NOV-90
X# Copyright (c) 1990, Randal L. Schwartz.  All Rights Reserved.
X# Available for use by all under the GNU PUBLIC LICENSE
X
X# Status: AN ALPHA RELEASE
X#
X# Missing some functionality provided by the Don Libes 'expect' program.
X# The main stuff for babysitting an interactive process from a Perl program
X# is here, though.
X#
X# Will fail if called from non-'main' package unless variables and
X# filehandles are qualified (I don't have caller() yet).
X#
X# Missing better documentation. :-)  It helps if you have used the
X# Libes stuff.
X#
X# Some of the stuff didn't map really well to Perl.  I was torn
X# between making it useful and making it compatible.  I'm open to
X# suggestions. :-)
X
X# THANKS:
X# Special thanks to Don Libes to provide the reason to write this package.
X# Thanks also to Larry Wall for his infinite patience with me.
X
Xpackage expect;
X
X# &close(HANDLE)
X# Closes HANDLE.  may eventually ensure that the process associated
X# with HANDLE is gone, so call this instead of just close().
X
Xsub main'close {
X	local($handle) = @_;
X	$handle =~ s/^[^']+$/"main'".$&/e; # eventually caller()
X	close($handle);
X}
X
X# &debug(...)
X
Xsub main'debug {
X	die "debug NOT IMPLEMENTED";
X}
X
X# &exit(EXITVAL)
X# Calls exit.
X
Xsub main'exit {
X	exit(@_);
X}
X
X# $expect'match:
X# contains the buffer (limited by $expect'match_max) of the most
X# recent chars seen in the last &expect call.
X
X$match = "";
X
X# $expect'match_max:
X# don't keep any more than this many characters when scanning for
X# an &expect.
X
X$match_max = 2000;
X
X# $expect'timeout:
X# number of seconds to wait before figuring that the process won't
X# give you what you wanted.  (This should have been a parameter to
X# expect, but for this round, it's a global for compatibility.)
X
X$timeout = 30;
X
X# $ret = &expect(HANDLE,PATLIST1,BODY1,PATLIST2,BODY2,...)
X# waits until one of the PATLISTn elements matches the output from
X# the process attached to HANDLE, then 'eval's the matching BODYn,
X# in the context of the caller.
X#
X# Each PATLIST is a regular-expression (probably enclosed in single-quotes
X# in the invocation).  ^ and $ will work, respecting the current value of $*.
X# If PATLIST is 'timeout', the BODY is executed if $expect'timeout is
X# exceeded.  If PATLIST is 'eof', the BODY is executed if the process
X# exits before the other patterns are seen.
X#
X# PATLISTs are scanned in the order given, so later PATLISTs can contain
X# general defaults that won't be examined unless the earlier PATLISTs
X# have failed.
X#
X# The *scalar* result of eval'ing BODY is returned as the result of
X# the invocation.  (If you need a list from the BODY, spin it off as
X# a side-effect.)  Recursive invocations of &expect are not thought
X# through, and may work only accidentally. :-)
X
Xsub main'expect {
X	local($PTY, at case) = @_;
X	$PTY =~ s/^[^']+$/"main'".$&/e; # eventually caller()
X	local(@casec,$pattern,$action);
X	local($rmask,$nfound,$buf,$ret,$nread);
X	local($endtime) = time + $timeout;
X	local(@incr);
X	local($shortkey) = 9999;
X	local($meta,$i);
X	$match = "";
X	@casec = @case;
X	@incr[0..255] = ();
X	while (@casec) {
X		($pattern,$action) = splice(@casec,0,2);
X		($buf = $pattern) =~ s/\\(\W)//g;
X		$meta = $buf =~ /[][()|+*?]/;
X		if ($pattern eq 'timeout') {
X			next;
X		} elsif ($pattern eq 'eof') {
X			next;
X		} elsif ($meta) {
X			@incr = split(//, 1 x 256);
X			$shortkey = 1;
X		} else {
X			$pattern = eval "<<UnLiKeLy\n$pattern\nUnLiKeLy\n"
X			    if $pattern =~ m#\\#;
X			$shortkey = length($pattern)
X				if $shortkey > length($pattern);
X			chop $pattern;
X			$i = 1;
X                        for (reverse split(//,$pattern)) {
X                                $incr[ord] = $i unless $incr[ord];
X                                $i++;
X                        }
X		}
X		
X	}
X	$incr[0] = 1;
X	for (@incr) {
X	    $_ = $shortkey unless $_;
X	}
X	while (1) {
X		$rmask = "";
X		vec($rmask,fileno($PTY),1) = 1;
X		$nread = 0;
X		($nfound, $timeleft) =
X		 	select($rmask,undef,undef,$endtime - time);
X		if ($nfound) {
X			$buf = ' ' x @incr[ord(substr($match,-1,1))];
X			$nread = syscall(3,fileno($PTY),$buf,length($buf));
X			# print STDOUT "<$nread " . length($buf) . ">";
X			$nread = 0 if $nread < 0; # any I/O err is eof
X			substr($buf,$nread,9999) = '';
X			$match .= $buf;
X			substr($match,0,
X				length($match)-$match_max) = ''
X				if length($match) > $match_max;
X			print STDOUT $buf if $log_user;
X		}
X		@casec = @case;
X		while (@casec) {
X			($pattern,$action) = splice(@casec,0,2);
X			if ($pattern eq 'timeout') {
X				unless ($nfound) {
X					$ret = eval "package main; $action";
X					# add caller() when available
X					die "$@\n" if $@;
X					return $ret;
X				}
X			} elsif ($pattern eq 'eof') {
X				unless ($nread) {
X					$ret = eval "package main; $action";
X					# add caller() when available
X					die "$@\n" if $@;
X					return $ret;
X				}
X			} elsif ($match =~ /$pattern/) {
X				$ret = eval "package main; $action";
X				# add caller() when available
X				die "$@\n" if $@;
X				return $ret;
X			}
X		}
X		return undef unless $nread;
X	}
X}
X
X# $ret = &expect_user(PATLIST1,BODY1,PATLIST2,BODY2...)
X# invoke &expect on STDIN
X
Xsub main'expect_user {
X	local(@case) = @_;
X	local($log_user) = 0; # don't echo user input... let process do that
X	&main'expect(STDIN, at case);
X}
X
X# &interact(...)
X
Xsub main'interact {
X	die "interact NOT IMPLEMENTED"; # it's broke, so far
X	local($esc,$spawnid) = @_;
X	# hmm.. have to duplicate most of &select here.  not good
X	local($imask,$omask) = "";
X	local($buf,$nread) = ' ';
X	for (STDIN,$spawnid) {
X		vec($imask,fileno($_),1) = 1;
X	}
X	# need to fiddle with STDIN's stty bits now
X	while (1) {
X		select($omask = $imask, undef, undef, undef);
X		if (vec($omask, fileno(STDIN), 1)) {
X			# prefer stdin over process
X			$nread = syscall(3,fileno(STDIN),$buf,1);
X			die "read: $!" if $nread < 0;
X			return undef if $nread == 0;
X			return $esc if $buf eq $esc;
X			&main'send($spawnid,$buf);
X		} else {
X			$nread = syscall(3,fileno($spawnid),$buf,1);
X			die "read: $!" if $nread < 0;
X			return undef if $nread == 0;
X			&main'send(STDOUT,$buf);
X		}
X	}
X}
X
X# &log_file(...)
X
Xsub main'log_file {
X	die "log_file NOT IMPLEMENTED";
X}
X
X# $expect'log_user:
X# set to non-zero to echo the processes STDOUT to this process STDOUT
X# while scanning via &expect.  Default is non-zero.
X
X$log_user = 1;
X
X# &log_user(NEWVAL)
X# sets $expect'log_user to NEWVAL
X
Xsub main'log_user {
X	($log_user) = @_;
X}
X
X# @handlelist = &select(HANDLE1,HANDLE2,HANDLE3...)
X# returns a list of the HANDLEs that can do I/O, or () if none can
X# do I/O before $expect'timeout seconds.
X
Xsub main'select {
X	local($rmask) = "";
X	local($nfound,$timeleft);
X	local(@ret);
X	for (@_) {
X		s/^[^']+$/"main'".$&/e; # eventually caller()
X		vec($rmask,fileno($_),1) = 1;
X	}
X	($nfound, $timeleft) =
X	 	select($rmask,undef,undef,$timeout);
X	grep(vec($rmask,fileno($_),1), at _);
X}
X
X# &send(HANDLE, at TEXT);
X# sends @TEXT to HANDLE.  May log it too, but logging isn't done yet.
X
Xsub main'send {
X	local($PTY, at args) = @_;
X	$PTY =~ s/^[^']+$/"main'".$&/e; # eventually caller()
X	print $PTY @args;
X	# should this copy STDOUT if $log_user?  dunno yet.
X}
X
X# &send_error(HANDLE, at TEXT);
X# sends @TEXT to STDERR.  May log it too, but logging isn't done yet.
X
Xsub main'send_error {
X	&main'send(STDERR, at _);
X}
X
X# &send_error(HANDLE, at TEXT);
X# sends @TEXT to STDOUT.  May log it too, but logging isn't done yet.
X
Xsub main'send_user {
X	&main'send(STDOUT, at _);
X}
X
X# $pty = &spawn(HANDLE,PROGRAM, at ARGS)
X# starts process PROGRAM with args @ARGS, associating it with a pty
X# opened on filehandle HANDLE.  Returns the name of the pty, or undef
X# if not successful.
X
Xsub main'spawn {
X	local($PTY, at cmd) = @_;
X	$PTY =~ s/^[^']+$/"main'".$&/e; # eventually caller()
X	local($TTY) = "__TTY" . time;
X	local($pty,$tty) = &_getpty($PTY,$TTY);
X	return undef unless defined $pty;
X	local($pid) = fork;
X	return undef unless defined $pid;
X	unless ($pid) {
X		close STDIN; close STDOUT; close STDERR;
X		setpgrp(0,$$);
X		if (open(TTY, "/dev/tty")) {
X		    ioctl(TTY,0x20007471,0);		# XXX s/b &TIOCNOTTY
X		    close TTY;
X		}
X		open(STDIN,"<&$TTY");
X		open(STDOUT,">&$TTY");
X		open(STDERR,">&STDOUT");
X		die "Oops" unless fileno(STDERR) == 2;	# sanity
X		close($PTY);
X		exec @cmd;
X		die "cannot exec @cmd: $!";
X	}
X	close($TTY);
X	$pty;
X}
X
X# &system(@ARGS)
X# just like system(@ARGS)... for compatibility
X
Xsub main'system {
X	system(@_);
X}
X
X# &trace(...)
X
Xsub main'trace {
X	die "trace NOT IMPLEMENTED";
X}
X
X# &trap(...)
X
Xsub main'trap {
X	local($cmd, at signals) = @_;
X	die "trap NOT IMPLEMENTED";
X}
X
X# &wait;
X# just like wait... for compatibility.
X
Xsub main'wait {
X	wait; # (that's easy. :-)
X}
X
X# ($pty,$tty) = &expect'_getpty(PTY,TTY):
X# internal procedure to get the next available pty.
X# opens pty on handle PTY, and matching tty on handle TTY.
X# returns undef if can't find a pty.
X
Xsub _getpty {
X	local($PTY,$TTY) = @_;
X	# don't adjust $PTY,$TTY with main', but use caller when available
X	local($pty,$tty);
X	for $bank (112..127) {
X		next unless -e sprintf("/dev/pty%c0", $bank);
X		for $unit (48..57) {
X			$pty = sprintf("/dev/pty%c%c", $bank, $unit);
X			# print "Trying $pty\n";
X			open($PTY,"+>$pty") || next;
X			select((select($PTY), $| = 1)[0]);
X			($tty = $pty) =~ s/pty/tty/;
X			open($TTY,"+>$tty") || next;
X			select((select($TTY), $| = 1)[0]);
X			system "stty nl >$tty";
X			return ($pty,$tty);
X		}
X	}
X	undef;
X}
X
X1;
END_OF_FILE
if test 9287 -ne `wc -c <'expect.pl'`; then
    echo shar: \"'expect.pl'\" unpacked with wrong size!
fi
# end of 'expect.pl'
fi
echo shar: End of shell archive.
exit 0
-- 
/=Randal L. Schwartz, Stonehenge Consulting Services (503)777-0095 ==========\
| on contract to Intel's iWarp project, Beaverton, Oregon, USA, Sol III      |
| merlyn at iwarp.intel.com ...!any-MX-mailer-like-uunet!iwarp.intel.com!merlyn |
\=Cute Quote: "Intel put the 'backward' in 'backward compatible'..."=========/