A slightly better expect.pl

[Randal Schwartz]

Here it is... this is the version with an interface that is a little
friendlier... no more "HANDLE" on each command (ugh).  Instead, you
set and save "$expect'spawn_id" as needed (which is never, unless you
talk to multiple processes).  This makes it even more like Don Libes'
expect package.

Again... ALPHA VERSION... if you can't handle something with rough
edges or bad docs... don't use this yet.  But I'm already using it for
production code.  And as soon as pl41 comes out, I'll drop in the
"caller" stuff to make it even more correct.

Also, major apologies to both Larry and Don regarding the last posting
have already been handled in private mail.  I really blew that last
one.  Please ignore most of my original comments... Don's package is
very good at doing what he was addressing.  The purpose of expect.pl
is to give people another way of doing that, using Perl as a base
instead of TCL, but not to distract from Don's work.

Here it is... usual disclaimers abound...

#! /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 Tue Nov 13 14:44:32 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'\" \(9180 characters\)
sed "s/^X//" >'expect.pl' <<'END_OF_FILE'
X## expect.pl rev ALPHA.2.01 09-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
Xundef($spawn_id);
X$spawn_id_next = "expect'SPAWN00001";
X
X# &close()
X# Closes $spawn_id.  may eventually ensure that the process associated
X# with $spawn_id is gone, so call this instead of just close().
X
Xsub main'close {
X	close($spawn_id);
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(@case) = @_;
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($spawn_id),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($spawn_id),$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(@args) = @_;
X	print $spawn_id @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	local($spawn_id) = "STDERR";
X	&main'send(@_);
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	local($spawn_id) = "STDOUT";
X	&main'send(@_);
X}
X
X# $pty = &spawn(PROGRAM, at ARGS)
X# starts process PROGRAM with args @ARGS, associating it with a pty
X# opened on a new filehandle.  Returns the name of the pty, or undef
X# if not successful.
X
Xsub main'spawn {
X	local(@cmd) = @_;
X	$spawn_id = $spawn_id_next++;
X	local($TTY) = "__TTY" . time;
X	local($pty,$tty) = &_getpty($spawn_id,$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($spawn_id);
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 9180 -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

print "Just another Perl hacker,"
-- 
/=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'..."=========/