## expect.pl rev ALPHA.2.01 09-NOV-90
# Copyright (c) 1990, Randal L. Schwartz.  All Rights Reserved.
# Available for use by all under the GNU PUBLIC LICENSE

# Status: AN ALPHA RELEASE
#
# Missing some functionality provided by the Don Libes 'expect' program.
# The main stuff for babysitting an interactive process from a Perl program
# is here, though.
#
# Will fail if called from non-'main' package unless variables and
# filehandles are qualified (I don't have caller() yet).
#
# Missing better documentation. :-)  It helps if you have used the
# Libes stuff.
#
# Some of the stuff didn't map really well to Perl.  I was torn
# between making it useful and making it compatible.  I'm open to
# suggestions. :-)

# THANKS:
# Special thanks to Don Libes to provide the reason to write this package.
# Thanks also to Larry Wall for his infinite patience with me.

package expect;

undef($spawn_id);
$spawn_id_next = "expect'SPAWN00001";

# &close()
# Closes $spawn_id.  may eventually ensure that the process associated
# with $spawn_id is gone, so call this instead of just close().

sub main'close {
	close($spawn_id);
}

# &debug(...)

sub main'debug {
	die "debug NOT IMPLEMENTED";
}

# &exit(EXITVAL)
# Calls exit.

sub main'exit {
	exit(@_);
}

# $expect'match:
# contains the buffer (limited by $expect'match_max) of the most
# recent chars seen in the last &expect call.

$match = "";

# $expect'match_max:
# don't keep any more than this many characters when scanning for
# an &expect.

$match_max = 2000;

# $expect'timeout:
# number of seconds to wait before figuring that the process won't
# give you what you wanted.  (This should have been a parameter to
# expect, but for this round, it's a global for compatibility.)

$timeout = 30;

# $ret = &expect(HANDLE,PATLIST1,BODY1,PATLIST2,BODY2,...)
# waits until one of the PATLISTn elements matches the output from
# the process attached to HANDLE, then 'eval's the matching BODYn,
# in the context of the caller.
#
# Each PATLIST is a regular-expression (probably enclosed in single-quotes
# in the invocation).  ^ and $ will work, respecting the current value of $*.
# If PATLIST is 'timeout', the BODY is executed if $expect'timeout is
# exceeded.  If PATLIST is 'eof', the BODY is executed if the process
# exits before the other patterns are seen.
#
# PATLISTs are scanned in the order given, so later PATLISTs can contain
# general defaults that won't be examined unless the earlier PATLISTs
# have failed.
#
# The *scalar* result of eval'ing BODY is returned as the result of
# the invocation.  (If you need a list from the BODY, spin it off as
# a side-effect.)  Recursive invocations of &expect are not thought
# through, and may work only accidentally. :-)

sub main'expect {
	local(@case) = @_;
	local(@casec,$pattern,$action);
	local($rmask,$nfound,$buf,$ret,$nread);
	local($endtime) = time + $timeout;
	local(@incr);
	local($shortkey) = 9999;
	local($meta,$i);
	$match = "";
	@casec = @case;
	@incr[0..255] = ();
	while (@casec) {
		($pattern,$action) = splice(@casec,0,2);
		($buf = $pattern) =~ s/\\(\W)//g;
		$meta = $buf =~ /[][()|+*?]/;
		if ($pattern eq 'timeout') {
			next;
		} elsif ($pattern eq 'eof') {
			next;
		} elsif ($meta) {
			@incr = split(//, 1 x 256);
			$shortkey = 1;
		} else {
			$pattern = eval "<<UnLiKeLy\n$pattern\nUnLiKeLy\n"
			    if $pattern =~ m#\\#;
			$shortkey = length($pattern)
				if $shortkey > length($pattern);
			chop $pattern;
			$i = 1;
                        for (reverse split(//,$pattern)) {
                                $incr[ord] = $i unless $incr[ord];
                                $i++;
                        }
		}
		
	}
	$incr[0] = 1;
	for (@incr) {
	    $_ = $shortkey unless $_;
	}
	while (1) {
		$rmask = "";
		vec($rmask,fileno($spawn_id),1) = 1;
		$nread = 0;
		($nfound, $timeleft) =
		 	select($rmask,undef,undef,$endtime - time);
		if ($nfound) {
			$buf = ' ' x @incr[ord(substr($match,-1,1))];
			$nread = syscall(3,fileno($spawn_id),$buf,length($buf));
			# print STDOUT "<$nread " . length($buf) . ">";
			$nread = 0 if $nread < 0; # any I/O err is eof
			substr($buf,$nread,9999) = '';
			$match .= $buf;
			substr($match,0,
				length($match)-$match_max) = ''
				if length($match) > $match_max;
			print STDOUT $buf if $log_user;
		}
		@casec = @case;
		while (@casec) {
			($pattern,$action) = splice(@casec,0,2);
			if ($pattern eq 'timeout') {
				unless ($nfound) {
					$ret = eval "package main; $action";
					# add caller() when available
					die "$@\n" if $@;
					return $ret;
				}
			} elsif ($pattern eq 'eof') {
				unless ($nread) {
					$ret = eval "package main; $action";
					# add caller() when available
					die "$@\n" if $@;
					return $ret;
				}
			} elsif ($match =~ /$pattern/) {
				$ret = eval "package main; $action";
				# add caller() when available
				die "$@\n" if $@;
				return $ret;
			}
		}
		return undef unless $nread;
	}
}

# $ret = &expect_user(PATLIST1,BODY1,PATLIST2,BODY2...)
# invoke &expect on STDIN

sub main'expect_user {
	local(@case) = @_;
	local($log_user) = 0; # don't echo user input... let process do that
	&main'expect(STDIN,@case);
}

# &interact(...)

sub main'interact {
	die "interact NOT IMPLEMENTED"; # it's broke, so far
	local($esc,$spawnid) = @_;
	# hmm.. have to duplicate most of &select here.  not good
	local($imask,$omask) = "";
	local($buf,$nread) = ' ';
	for (STDIN,$spawnid) {
		vec($imask,fileno($_),1) = 1;
	}
	# need to fiddle with STDIN's stty bits now
	while (1) {
		select($omask = $imask, undef, undef, undef);
		if (vec($omask, fileno(STDIN), 1)) {
			# prefer stdin over process
			$nread = syscall(3,fileno(STDIN),$buf,1);
			die "read: $!" if $nread < 0;
			return undef if $nread == 0;
			return $esc if $buf eq $esc;
			&main'send($spawnid,$buf);
		} else {
			$nread = syscall(3,fileno($spawnid),$buf,1);
			die "read: $!" if $nread < 0;
			return undef if $nread == 0;
			&main'send(STDOUT,$buf);
		}
	}
}

# &log_file(...)

sub main'log_file {
	die "log_file NOT IMPLEMENTED";
}

# $expect'log_user:
# set to non-zero to echo the processes STDOUT to this process STDOUT
# while scanning via &expect.  Default is non-zero.

$log_user = 1;

# &log_user(NEWVAL)
# sets $expect'log_user to NEWVAL

sub main'log_user {
	($log_user) = @_;
}

# @handlelist = &select(HANDLE1,HANDLE2,HANDLE3...)
# returns a list of the HANDLEs that can do I/O, or () if none can
# do I/O before $expect'timeout seconds.

sub main'select {
	local($rmask) = "";
	local($nfound,$timeleft);
	local(@ret);
	for (@_) {
		s/^[^']+$/"main'".$&/e; # eventually caller()
		vec($rmask,fileno($_),1) = 1;
	}
	($nfound, $timeleft) =
	 	select($rmask,undef,undef,$timeout);
	grep(vec($rmask,fileno($_),1),@_);
}

# &send(HANDLE,@TEXT);
# sends @TEXT to HANDLE.  May log it too, but logging isn't done yet.

sub main'send {
	local(@args) = @_;
	print $spawn_id @args;
	# should this copy STDOUT if $log_user?  dunno yet.
}

# &send_error(HANDLE,@TEXT);
# sends @TEXT to STDERR.  May log it too, but logging isn't done yet.

sub main'send_error {
	local($spawn_id) = "STDERR";
	&main'send(@_);
}

# &send_error(HANDLE,@TEXT);
# sends @TEXT to STDOUT.  May log it too, but logging isn't done yet.

sub main'send_user {
	local($spawn_id) = "STDOUT";
	&main'send(@_);
}

# $pty = &spawn(PROGRAM,@ARGS)
# starts process PROGRAM with args @ARGS, associating it with a pty
# opened on a new filehandle.  Returns the name of the pty, or undef
# if not successful.

sub main'spawn {
	local(@cmd) = @_;
	$spawn_id = $spawn_id_next++;
	local($TTY) = "__TTY" . time;
	local($pty,$tty) = &_getpty($spawn_id,$TTY);
	return undef unless defined $pty;
	local($pid) = fork;
	return undef unless defined $pid;
	unless ($pid) {
		close STDIN; close STDOUT; close STDERR;
		setpgrp(0,$$);
		if (open(TTY, "/dev/tty")) {
		    ioctl(TTY,0x20007471,0);		# XXX s/b &TIOCNOTTY
		    close TTY;
		}
		open(STDIN,"<&$TTY");
		open(STDOUT,">&$TTY");
		open(STDERR,">&STDOUT");
		die "Oops" unless fileno(STDERR) == 2;	# sanity
		close($spawn_id);
		exec @cmd;
		die "cannot exec @cmd: $!";
	}
	close($TTY);
	$pty;
}

# &system(@ARGS)
# just like system(@ARGS)... for compatibility

sub main'system {
	system(@_);
}

# &trace(...)

sub main'trace {
	die "trace NOT IMPLEMENTED";
}

# &trap(...)

sub main'trap {
	local($cmd,@signals) = @_;
	die "trap NOT IMPLEMENTED";
}

# &wait;
# just like wait... for compatibility.

sub main'wait {
	wait; # (that's easy. :-)
}

# ($pty,$tty) = &expect'_getpty(PTY,TTY):
# internal procedure to get the next available pty.
# opens pty on handle PTY, and matching tty on handle TTY.
# returns undef if can't find a pty.

sub _getpty {
	local($PTY,$TTY) = @_;
	# don't adjust $PTY,$TTY with main', but use caller when available
	local($pty,$tty);
	for $bank (112..127) {
		next unless -e sprintf("/dev/pty%c0", $bank);
		for $unit (48..57) {
			$pty = sprintf("/dev/pty%c%c", $bank, $unit);
			# print "Trying $pty\n";
			open($PTY,"+>$pty") || next;
			select((select($PTY), $| = 1)[0]);
			($tty = $pty) =~ s/pty/tty/;
			open($TTY,"+>$tty") || next;
			select((select($TTY), $| = 1)[0]);
			system "stty nl >$tty";
			return ($pty,$tty);
		}
	}
	undef;
}

1;
