Expect-1.36/0000755000175000017500000000000014566210227007620 5ustar Expect-1.36/examples/0000755000175000017500000000000014566210226011435 5ustar Expect-1.36/examples/calc.pl0000755000175000017500000000021514566144303012677 0ustar use strict; use warnings; while (my $row = <>) { chomp $row; print "Input: '$row' = "; my $res = eval $row; print "'$res' :Output\n"; } Expect-1.36/examples/expect_calc.pl0000755000175000017500000000072614566144303014256 0ustar use strict; use warnings; use Expect; my $e = Expect->new; $e->spawn($^X, "examples/calc.pl") or die; $e->log_stdout(0); $e->raw_pty(1); $e->send("19+23\n"); $e->expect(1, "19+23"); print 'Match: <', $e->match, ">\n"; print 'Before: <', $e->before, ">\n"; print 'After: <', $e->after, ">\n"; $e->clear_accum; $e->expect(1, '-re' => qr/'\d+'/); print 'Match: <', $e->match, ">\n"; print 'Before: <', $e->before, ">\n"; print 'After: <', $e->after, ">\n"; $e->close; Expect-1.36/examples/kibitz/0000755000175000017500000000000014566210226012731 5ustar Expect-1.36/examples/kibitz/kibitz.man0000755000175000017500000001442414566144303014734 0ustar .TH KIBITZ 1 "28 January 2001" .SH NAME kibitz \- allow two people to interact with one shell .SH SYNOPSIS .B kibitz [ .I kibitz-args ] .I user [ .I program program-args... ] .br .B kibitz [ .I kibitz-args ] .I user@host [ .I program program-args... ] .SH INTRODUCTION .B kibitz allows two (or more) people to interact with one shell (or any arbitrary program). Uses include: .RS .TP 4 \(bu A novice user can ask an expert user for help. Using .BR kibitz , the expert can see what the user is doing, and offer advice or show how to do it right. .TP \(bu By running .B kibitz and then starting a full-screen editor, people may carry out a conversation, retaining the ability to scroll backwards, save the entire conversation, or even edit it while in progress. .TP \(bu People can team up on games, document editing, or other cooperative tasks where each person has strengths and weaknesses that complement one another. .SH USAGE To start .BR kibitz , user1 runs kibitz with the argument of the user to kibitz. For example: kibitz user2 .B kibitz starts a new shell (or another program, if given on the command line), while prompting user2 to run .BR kibitz . If user2 runs .B kibitz as directed, the keystrokes of both users become the input of the shell. Similarly, both users receive the output from the shell. To terminate .B kibitz it suffices to terminate the shell itself. For example, if either user types ^D (and the shell accepts this to be EOF), the shell terminates followed by .BR kibitz . Normally, all characters are passed uninterpreted. However, if the escape character (described when .B kibitz starts) is issued, the user may talk directly to the .B kibitz interpreter. Currently the only option is to exit the program. Also, job control may be used while in the interpreter, to, for example, suspend or restart .BR kibitz . Various processes can provide various effects. For example, you can emulate a two-way write(1) session with the command: kibitz user2 sleep 1000000 .SH ARGUMENTS .B kibitz takes arguments, these should also be separated by whitespace. The .B \-noproc flag runs .B kibitz with no process underneath. Characters are passed to the other .BR kibitz . This is particularly useful for connecting multiple interactive processes together. In this mode, characters are not echoed back to the typist. .B \-noescape disables the escape character. .BI \-escape " char" sets the escape character. The default escape character is ^]. .B \-silent turns off informational messages describing what kibitz is doing to initiate a connection. .BI \-tty " ttyname" defines the tty to which the invitation should be sent. If you start .B kibitz to user2 on a remote computer, .B kibitz performs a .B rlogin to the remote computer with your current username. The flag .BI \-proxy " username" causes .B rlogin to use .I username for the remote login (e.g. if your account on the remote computer has a different username). If the .B -proxy flag is not given, .B kibitz tries to determine your current username by (in that order) inspecting the environment variables USER and LOGNAME, then by using the commands .B whoami and .BR logname . The arguments .B -noescape and .B -escape can also be given by user2 when prompted to run .BR kibitz . .SH MORE THAN TWO USERS The current implementation of kibitz explicitly understands only two users, however, it is nonetheless possible to have a three (or more) -way kibitz, by kibitzing another .BR kibitz . For example, the following command runs .B kibitz with the current user, user2, and user3: % kibitz user2 kibitz user3 Additional users may be added by simply appending more "kibitz user" commands. .SH CAVEATS .B kibitz assumes the 2nd user has the same terminal type and size as the 1st user. If this assumption is incorrect, graphical programs may display oddly. .B kibitz handles character graphics, but cannot handle bitmapped graphics. Thus, .nf % xterm -e kibitz will work % kibitz xterm will not work .fi .B kibitz uses the same permissions as used by rlogin, rsh, etc. Thus, you can only .B kibitz to users at hosts for which you can rlogin. Similarly, .B kibitz will prompt for a password on the remote host if rlogin would. If you .B kibitz to users at remote hosts, .B kibitz needs to distinguish your prompt from other things that may precede it during login. (Ideally, the end of it is preferred but any part should suffice.) If you have an unusual prompt, set the environment variable EXPECT_PROMPT to an egrep(1)-style regular expression. Brackets should be preceded with one backslash in ranges, and three backslashes for literal brackets. The default prompt r.e. is "(%|#|\\$)\\s". .B kibitz requires the .B kibitz program on both hosts. .B kibitz requires .BR expect (1). This version "should be" but is not compatible with the original program (yet). .SH BUGS An early version of Sun's tmpfs had a bug in it that causes .B kibitz to blow up. If .B kibitz reports "error flushing ...: Is a directory" ask Sun for patch #100174. If your Expect is not compiled with multiple-process support (i.e., you do not have a working select or poll), you will not be able to run kibitz. .SH ENVIRONMENT The environment variable SHELL is used to determine the shell to start, if no other program is given on the command line. If the environment variable EXPECT_PROMPT exists, it is taken as a regular expression which matches the end of your login prompt (but does not otherwise occur while logging in). See also CAVEATS above. If the environment variables USER or LOGNAME are defined, they are used to determine the current user name for a .B kibitz to a remote computer. See description of the .B -proxy option in ARGUMENTS above. .SH SEE ALSO .BR Perl (1), .BR Expect (3), .BR Tcl (3), .BR libexpect (3), .br .I "Exploring Expect: A Tcl-Based Toolkit for Automating Interactive Programs" \fRby Don Libes, O'Reilly and Associates, January 1995. .br .I "Kibitz \- Connecting Multiple Interactive Programs Together", \fRby Don Libes, Software \- Practice & Experience, John Wiley & Sons, West Sussex, England, Vol. 23, No. 5, May, 1993. .SH AUTHOR Don Libes, National Institute of Standards and Technology .B kibitz is in the public domain. NIST and I would appreciate credit if this program or parts of it are used. Ported to .B Perl .B Expect module by Lee Eakin, Texas Instruments Inc. Expect-1.36/examples/kibitz/kibitz0000755000175000017500000001554214566144303014164 0ustar #!/usr/local/bin/perl # Original author: Author: Don Libes, NIST (tcl/expect) # Date written: December 5, 1991 # Date last editted: October 19, 1994 # Version: 2.11 # # Ported to Perl Expect module by: Lee Eakin, # Date first ported: January 28, 2001 # require 5.004; my ($pgm)=$0=~m|([^/]*)$|; $DEBUG=0; use strict; use Expect; use Getopt::Long; use vars qw($opt_noproc $opt_catu $opt_tty $opt_noescape $opt_escape $opt_silent $opt_proxy $opt_r); $|=1; my $prompt= $ENV{EXPECT_PROMPT} || '(?:%|#|\$)\s'; Getopt::Long::Configure('auto_abbrev','pass_through'); &GetOptions(qw(noproc catu tty=s noescape escape=s silent proxy=s r)) or &usage; &usage unless @ARGV or $opt_noproc; $opt_escape="\035" unless $opt_escape or $opt_noescape; my @flags; push @flags,'-tty',$opt_tty if $opt_tty; push @flags,'-silent' if $opt_silent; $Expect::Log_Stdout=0; my $stdin=Expect->exp_init(\*STDIN); my $stdout=Expect->exp_init(\*STDOUT); my $pid; my $user=shift; my $usernum; if ($opt_r) { print "KRUN"; $usernum=3; } else { $usernum=$user=~/^-\d+/ ? 2 : 1 } # User who originated kibitz session has $usernum == 1 on local machine. # User who is responding to kibitz has $usernum == 2. # User who originated kibitz session has $usernum == 3 on remote machine. # user 1 invokes kibitz as "kibitz user[@host]" # user 2 invokes kibitz as "kibitz -####" (some pid). # user 3 invokes kibitz as "kibitz -r user". my $sh; my $rhost; my $remsh; if ($usernum == 1) { unless ($opt_noproc) { if (@ARGV) { $sh=Expect->spawn("@ARGV") or die "$pgm: \"@ARGV\" spawn failed"; } else { $sh=Expect->spawn($ENV{SHELL} || '/bin/sh') or die "$pgm: shell spawn failed"; } } if ($user=~/([^@]+)@(.+)/) { $user=$1; $rhost=$2; } if ($rhost) { print "connecting to $rhost\n" unless $opt_silent; $opt_proxy||=$ENV{USER} || $ENV{LOGNAME} || `whoami` || `logname`; my $rcmd="rlogin $rhost -l $opt_proxy -8"; $remsh=Expect->spawn($rcmd); while (1) { $remsh->expect(60, -re => 'word:\s*$', -re => '\s+incorrect.*', -re => $prompt) or die "$pgm: connection to $rhost timed out\n"; if ($remsh->exp_match_number == 1) { print "password (for $opt_proxy) on $rhost: "; $stdin->exp_stty('-echo'); my $pswd=; $stdin->exp_stty('echo'); print "\n"; chomp $pswd; print $remsh "$pswd\r"; } elsif ($remsh->exp_match_number == 2) { die "$pgm: invalid password or account\n"; } elsif ($remsh->exp_match_number == 3) { last; } } print "starting $pgm on $rhost\n" unless $opt_silent; print $remsh "$pgm @flags -r $user;kill -9 $$\r"; $remsh->expect(120, -re => "$pgm @flags -r $user.*KRUN", -re => "$pgm @flags -r $user.*$pgm"."[^\r\n]*\r") or die "$pgm: unable to run $pgm on $rhost: timed out\n"; if ($remsh->exp_match_number == 2) { die "$pgm: unable to run $pgm on $rhost\n". "try rlogin by hand followed by \"$pgm $user\"\n"; } while (1) { $remsh->expect(120, -re => ".*\n",'KABORT','KDATA'); print $remsh->exp_match if $remsh->exp_match_number == 1; exit if $remsh->exp_match_number == 2; last if $remsh->exp_match_number == 3; } } } elsif ($usernum == 2) { ($pid)=$user=~/^-(\d+)/; } my $localio=(($usernum == 3) or not $rhost); my $inf; my $outf; my $exin; my $exout; if ($localio) { $pid||=$$; if ($usernum == 2) { $inf="/tmp/exp1.$pid"; $outf="/tmp/exp0.$pid"; } else { $inf="/tmp/exp0.$pid"; $outf="/tmp/exp1.$pid"; } } else { $exin=$remsh; $exout=$remsh; } if ($usernum == 2) { die "$pgm: Huh? No one is asking you to $pgm.\n" unless -r $inf; open OUT,">$outf" or die "$pgm: write pipe open failed: $!\n"; select((select(OUT),$|=1)[0]); open IN,$inf or die "$pgm: read pipe open failed: $!\n"; select((select(IN),$|=1)[0]); $stdin->exp_stty('-echo raw'); $exin=Expect->exp_init(\*IN); $exout=Expect->exp_init(\*OUT); if ($opt_escape) { &vprint("Escape sequence is $opt_escape"); print "\r\n"; $stdin->set_seq($opt_escape,\&local_esc); } unlink $inf; $exin->set_group($stdout); $stdin->set_group($exout); Expect::interconnect($exin,$stdin); exit; } if ($localio) { $SIG{'INT'}=$SIG{'QUIT'}=$SIG{'TERM'}=eval "sub {unlink '$inf','$outf';exit}"; my $fifocmd; foreach (qw(/usr/bin /usr/sbin /usr/local/bin /usr/local/sbin /bin /sbin)) { $fifocmd="$_/mkfifo %s",last if -x "$_/mkfifo"; } unless ($fifocmd) { foreach (qw(/usr/bin /usr/sbin /usr/local/bin /usr/local/sbin /bin /sbin /usr/etc /etc)) { $fifocmd="$_/mknod %s p",last if -x "$_/mknod"; } } die "$pgm: could not determine how to make a fifo - where is mknod?\n" unless $fifocmd; system(sprintf $fifocmd,$inf) == 0 or die "$pgm: could not make fifo \"$inf\": $?\n"; system(sprintf $fifocmd,$outf) == 0 or unlink($inf), die "$pgm: could not make fifo \"$outf\": $?\n"; chmod 0666,$inf,$outf; print "asking $user to type: $pgm -$pid\n" unless $opt_silent; open WQ,"|/usr/bin/write $user $opt_tty" or unlink($inf,$outf), die "$pgm: write command failed: $!\n"; print WQ "Can we talk? Run: $pgm -$pid\n"; close WQ; open IN,$inf or die "$pgm: read pipe open failed: $!\n"; select((select(IN),$|=1)[0]); open OUT,">$outf" or die "$pgm: write pipe open failed: $!\n"; select((select(OUT),$|=1)[0]); $stdin->exp_stty('-echo raw'); $exin=Expect->exp_init(\*IN); $exout=Expect->exp_init(\*OUT); unlink $inf; } if ($usernum==3) { print "KDATA"; $exin->set_group($stdout); $stdin->set_group($exout); Expect::interconnect($exin,$stdin); } else { if ($opt_escape) { &vprint("Escape sequence is $opt_escape"); print "\r\n"; $stdin->set_seq($opt_escape,\&local_esc); } if ($opt_noproc) { $exin->set_group($stdout); $stdin->set_group($exout); Expect::interconnect($exin,$stdin); } else { $exin->set_group($sh); $stdin->set_group($sh); $sh->set_group($stdout,$exout); Expect::interconnect($exin,$stdin,$sh); } $sh->hard_close; } unlink $inf,$outf; exit; sub local_esc { print "\r\n$pgm:\r\n E) Exit program\r\n any other key to return to program\r\n"; my $ans=getc; print "\r\n"; exit if $ans eq 'E'; print "returning to $pgm\r\n"; } sub vprint { my @keys=@_; foreach (@keys) { s/([\200-\277])/'M-'.chr(ord($1)^128)/eg; s/([\000-\011\013-\037\177])/"^".chr(ord($1)^ord('@'))/eg; } print @keys; } sub usage { print STDERR "Usage: $pgm [options] user [program ...]\n"; print STDERR " or: $pgm [options] user\@host [program ...]\n"; exit 1; } Expect-1.36/examples/kibitz/Changelog0000755000175000017500000000050214566144303014545 0ustar Fri Feb 9 11:02:44 CST 2001 Lee Eakin removed double quotes from write message (easier to cut-n-paste) fixed non-functional escape char changed pipe names to match those used in the original kibitz added man page (hacked from original tcl-kibitz man page) added README file Expect-1.36/examples/kibitz/README0000755000175000017500000000160214566144303013615 0ustar This is a port of the tcl/expect script 'kibitz' to the perl Expect module. I have always found it useful to debug user problems and in training new admins. Since the wonderful Expect module has come into existance I've had no need to install tcl/expect except to get the kibitz program on my system. I finally got around to converting it for my own use and thought the rest of the world might find a similar use for it. It "should be", but is not quite compatible with the original. I'm working on that. I also plan to port xkibitz unless someone beats me to it. The man page is hacked from the original kibitz man page. This version also takes a shortcut when deciding if the connection should use rlogin. If user@host is specified it assumes remote. If only user is given it assumes local. All options valid for the original program are accepted, but some are ignored (-catu). -Lee Expect-1.36/examples/ssh.pl0000755000175000017500000000361414566144303012600 0ustar #!/usr/bin/perl # # A Simple Terminal Resizing Example # (C) 2006 Jeff Carr # This script can be used under the same terms as Perl. # # This script is a simple example of how handle terminal # window resize events (transmitted via the WINCH signal) # -- Jeff Carr # # NOTE: I (the Expect maintainer) strongly object against using Expect # to automate ssh login. There are better methods, see ssh-keygen. # If you use this example as a stub to control a remote application, # please remove the password-part and use public-key authentication # instead. # -- Roland Giersig # if( ! defined $ARGV[0] ) { print "Usage: ssh.pl [ [ ] ]\n"; exit; } my ($host, $username, $password) = @ARGV; $username = $ENV{USER} if $username eq ""; use Expect; use IO::Pty; my $spawn = new Expect; $spawn->raw_pty(1); # This gets the size of your terminal window $spawn->slave->clone_winsize_from(\*STDIN); my $PROMPT; # This function traps WINCH signals and passes them on sub winch { my $signame = shift; my $pid = $spawn->pid; $shucks++; print "count $shucks,pid $pid, SIG$signame\n"; $spawn->slave->clone_winsize_from(\*STDIN); kill WINCH => $spawn->pid if $spawn->pid; } $SIG{WINCH} = \&winch; # best strategy $spawn=Expect->spawn("ssh $username\@$host"); # log everything if you want # $spawn->log_file("/tmp/autossh.log.$$"); my $PROMPT = '[\]\$\>\#]\s$'; my $ret = $spawn->expect(10, [ qr/\(yes\/no\)\?\s*$/ => sub { $spawn->send("yes\n"); exp_continue; } ], [ qr/assword:\s*$/ => sub { $spawn->send("$password\n") if defined $password; } ], [ qr/ogin:\s*$/ => sub { $spawn->send("$username\n"); exp_continue; } ], [ qr/REMOTE HOST IDEN/ => sub { print "FIX: .ssh/known_hosts\n"; exp_continue; } ], [ qr/$PROMPT/ => sub { $spawn->send("echo Now try window resizing\n"); } ], ); # Hand over control $spawn->interact(); exit; Expect-1.36/t/0000755000175000017500000000000014566210226010062 5ustar Expect-1.36/t/02-bc.t0000755000175000017500000000447614566144303011072 0ustar use strict; use warnings; use Test::More; use Expect; plan skip_all => 'See https://rt.cpan.org/Ticket/Display.html?id=98495'; my $bc = '/usr/bin/bc'; if ( not -x $bc ) { diag "Could not find bc in $bc"; my $which = `which bc`; diag "which bc: '$which'"; plan skip_all => "Need to have $bc installed to run this test"; } plan tests => 2; if ($^O !~ /^(openbsd|solaris|midnightbsd|dragonfly)$/) { my $bc_version = `$bc -v`; diag "--------- bc version on $^O"; diag $bc_version; diag '---------'; # just some notes: # on the systems with the above 'osname', bc does not have any banner (the warranty stuff) # and the also don't have a -v flag } subtest raw_pty_bc => sub { if ($^O =~ /^(openbsd|netbsd|freebsd|solaris|darwin|midnightbsd|dragonfly)$/) { plan skip_all => "This test fails on \$^O == \$Config{'osname'} == '$^O'"; } #if ($^O =~ /^(darwin)$/) { # diag "This test will almost certainly fail on \$^O == \$Config{'osname'} == '$^O'. You can install the module skipping this test, but please report the failure."; # #plan skip_all => "This test fails on $^O"; #} plan tests => 3; my $e = Expect->new; $e->raw_pty(1); $e->spawn($bc) or die "Cannot run bc\n"; my $warranty; $e->expect( 1, [qr/warranty'\./ => sub { $warranty = 1 } ] ); ok $warranty, 'warranty found' or do { diag $e->before; return; }; $e->send("23+7\n"); my $num; $e->expect( 1, [qr/\d+/ => sub { $num = 1 }] ); ok $num, 'number found' or do { diag $e->before; return; }; my $match = $e->match; is $match, 30, 'the number'; $e->send("quit\n"); }; subtest pty_bc => sub { plan tests => 6; my $e = Expect->new; $e->spawn($bc) or die "Cannot run bc\n"; my $warranty; $e->expect( 1, [qr/warranty'\./ => sub { $warranty = 1 } ] ); SKIP: { skip "No banner on $^O ", 1 if $^O =~ /^(openbsd|freebsd|netbsd|solaris|midnightbsd|dragonfly)$/; ok $warranty, 'warranty found' or do { diag $e->before; return; }; } $e->send("23+7\n"); my $expr; $e->expect( 1, [qr/23\+7/ => sub { $expr = 1 }] ); ok $expr, 'echo input'; my $num; $e->expect( 1, [qr/\d+/ => sub { $num = 1 }] ); ok $num, 'number found' or do { diag $e->before; return; }; my $match = $e->match; is $match, 30, 'the number'; my $EMPTY = qr/^[\r\n]*$/; like $e->before, $EMPTY, 'before'; like $e->after, $EMPTY, 'after'; $e->send("quit\n"); }; Expect-1.36/t/04-multiline.t0000755000175000017500000000637014566144303012505 0ustar use strict; use warnings; use Test::More tests => 33; use Expect; my $e = Expect->new; $e->raw_pty(1); $e->log_stdout(0); $e->spawn($^X . q{ -ne 'chomp; print "My\nHello\n"; print scalar reverse; print "\nWorld\nAnd\nMore\n"' }); { my $reply; $e->send("abc\n"); $e->expect(1, ['^cba$' => sub { $reply = $e->match } ]); is $reply, 'cba', 'reply'; is $e->before, "My\nHello\n"; is $e->after, "\nWorld\nAnd\nMore\n"; } my $wam = "\nWorld\nAnd\nMore\n"; { $e->send("def\n"); $e->expect(1, ['^fed$']); is $e->match, 'fed', 'match'; is $e->clear_accum, $wam; } { $e->send("dnAX\n"); $e->expect(1, '-re', '(?:^X(.*d))'); is $e->match, 'XAnd', 'match'; is_deeply [$e->matchlist], ['And'], 'matchlist'; is $e->clear_accum, $wam; #[ qr/(?m:^uc:\s*(\w+))/, } { $e->send("dnAX\n"); $e->expect(1, '-re', '^X.*d$'); is $e->match, 'XAnd', 'match'; is $e->clear_accum, $wam; } { $e->send("eroM\n"); $e->expect(1, '-re', '^M(..)e$'); is $e->match, 'More', 'match'; is $e->clear_accum, $wam; } { $e->send("dnAX\n"); $e->expect(1, '-re', '^X(?s:.*)d$'); is $e->match, "XAnd\nWorld\nAnd", 'match'; is $e->clear_accum, "\nMore\n"; } { $e->send("ghi\n"); $e->expect(1, '-re', '^ihg$'); is $e->match, 'ihg', 'match'; is $e->clear_accum, $wam; } { local $Expect::Multiline_Matching = 0; my $reply; $e->send("abc\n"); $e->expect(1, ['^cba$' => sub { $reply = $e->match } ]); is $reply, undef, 'reply'; } { local $Expect::Multiline_Matching = 0; is $e->clear_accum, "My\nHello\ncba$wam"; $e->send("def\n"); $e->expect(1, ['^fed$']); #diag $e->before; is $e->match, undef, 'match'; is $e->match, undef; } { local $Expect::Multiline_Matching = 0; $e->send("mno\n"); $e->expect(1, '-re', '^onm$'); is $e->match, undef, 'match'; is $e->match, undef; } { local $Expect::Multiline_Matching = 0; $e->send("dnAX\n"); $e->expect(1, '-re', '^X.*d$'); is $e->match, undef; is $e->clear_accum, "My\nHello\nfed${wam}My\nHello\nonm${wam}My\nHello\nXAnd${wam}"; } { local $Expect::Multiline_Matching = 0; $e->send("dnAX\n"); $e->expect(1, '-re', '^X(?s:.*)d$'); is $e->match, undef; is $e->clear_accum, "My\nHello\nXAnd$wam"; } { local $Expect::Multiline_Matching = 0; $e->send("dnAX\n"); $e->expect(1, '-re', 'X.*d'); # no ^ and $ is $e->match, 'XAnd', 'match'; is $e->clear_accum, $wam; } { local $Expect::Multiline_Matching = 0; $e->send("dnAX\n"); $e->expect(1, '-re', 'X(?s:.*)d'); # no ^ and $ is $e->match, "XAnd\nWorld\nAnd", 'match'; is $e->clear_accum, "\nMore\n"; } { #diag 'localized $Expect::Multiline_Matching = 0; has no effect after the block:'; $e->send("abc\n"); $e->expect(1, ['^cba$']); is $e->match, 'cba', 'match'; } TODO: { local $TODO = 'Multiline_Maching does not work when qr// is passed. (Should it work?)' if $] >= 5.010; # see the regex subtest checking this thing and see http://www.perlmonks.org/?node_id=1097316 my $reply; $e->send("zorg\n"); $e->expect(1, [qr/^groz$/ => sub { $reply = $e->match } ]); is $reply, 'groz'; } subtest regex => sub { plan tests => 4; my $str = "x\nab\ny"; my $re = '^ab$'; ok $str !~ /$re/, 're'; ok $str =~ /$re/m, 're/m'; my $qre = qr/^ab$/; unlike $str, qr/$qre/, 'qre'; unlike $str, qr/$qre/m, 'qre/m bug in perl 5.8.x'; # see http://www.perlmonks.org/?node_id=1097316 }; Expect-1.36/t/01-test.t0000755000175000017500000003124514566206371011462 0ustar use strict; use warnings; use Test::More tests => 15; use File::Temp qw(tempdir); use Expect; use Config; #$Expect::Exp_Internal = 1; #$Expect::Debug = 1; my $tempdir = tempdir( CLEANUP => 1 ); my $Perl = $^X; subtest perl => sub { diag "Basic tests..."; plan tests => 4; my $exp = Expect->spawn("$Perl -v"); ok( defined $exp ); $exp->log_user(0); is( $exp->expect( 10, "krzlbrtz", "Copyright" ), 2 ); is( $exp->expect( 10, "Larry Wall", "krzlbrtz" ), 1 ); ok( not $exp->expect( 3, "Copyright" ) ); }; subtest exec_failure => sub { diag "Testing exec failure..."; plan tests => 6; my $exp = Expect->new; ok( defined $exp ); $exp->log_stdout(0); $! = 0; ok( not defined $exp->spawn("Ignore_This_Error_Its_A_Test__efluna3w6868tn8") ); ok($!); my $val = ''; my $res = $exp->expect( 20, [ "Cannot exec" => sub { $val = 'cannot_exec'; } ], [ eof => sub { $val = 'eof'; } ], [ timeout => sub { $val = 'timeout'; } ], ); is $val, 'cannot_exec'; ok( defined $res ); is( $res, 1 ); }; subtest exp_continue => sub { diag "Testing exp_continue..."; plan tests => 1; my $exp = Expect->new( $Perl . q{ -e 'foreach (qw(A B C D End)) { print "$_\n"; }' } ); my $state = "A"; my @val; $exp->expect( 2, [ "[ABCD]" => sub { my $self = shift; push @val, $self->match; exp_continue; } ], [ "End" => sub { push @val, 'End'; } ], [ eof => sub { push @val, 'eof'; } ], [ timeout => sub { push @val, 'timeout'; } ], ); is_deeply \@val, [qw(A B C D End)], '5 states of exp_continue'; $exp->hard_close(); }; subtest exp_continue_sleep => sub { plan tests => 5; my $exp = Expect->new( $Perl . q{ -e 'print "Begin\n"; sleep (5); print "End\n";' } ); my $cnt = 0; my ( $begin, $end, $eof ); $exp->expect( 1, [ "Begin" => sub { $begin = 1; exp_continue; } ], [ "End" => sub { $end = 1; } ], [ eof => sub { $eof = 1; } ], [ timeout => sub { $cnt++; ( $cnt < 7 ) ? exp_continue : 0; } ], ); ok $begin; ok $end; ok !$eof; diag "number of timeout calls in 5 sec: $cnt"; cmp_ok( $cnt, '>', 2 ); cmp_ok( $cnt, '<', 7 ); $exp->hard_close(); }; subtest timeout => sub { diag "timeout shouldn't destroy accum contents"; plan tests => 3; my $exp = Expect->new( $Perl . q{ -e 'print "some string\n"; sleep (5);' } ); ok( not defined $exp->expect( 1, "NoMaTcH" ) ); my $i = $exp->expect( 1, '-re', 'some\s' ); ok( defined $i ); is $i, 1; $exp->hard_close(); }; subtest notransfer => sub { diag "Testing -notransfer..."; plan tests => 8; my $exp = Expect->new( $Perl . q{ -e 'print "X some other\n"; sleep 5;'} ); $exp->notransfer(1); my @expected = ( 'some', 'some', 'other' ); foreach my $e (@expected) { my $val = ''; $exp->expect( 3, [ $e => sub { $val = $e; } ], [ eof => sub { $val = 'eof'; } ], [ timeout => sub { $val = 'timeout'; } ], ); is $val, $e; } sleep(6); my $val1 = ''; my $acc1 = ''; $exp->expect( 3, [ 'some' => sub { my $self = shift; $val1 = 'some'; $acc1 = $self->set_accum( $self->after() ); } ], [ eof => sub { $val1 = 'eof'; } ], [ timeout => sub { $val1 = 'timeout'; } ], ); like $acc1, qr/^X some other[\r\n]*$/, 'accumulator'; is $val1, 'some'; my $val2 = ''; my $acc2 = ''; $exp->expect( 3, [ 'some' => sub { $val2 = 'some'; } ], [ 'other' => sub { $val2 = 'other'; my $self = shift; my $acc2 = $self->set_accum( $self->after() ); } ], [ eof => sub { $val2 = 'eof'; } ], [ timeout => sub { $val2 = 'timeout'; } ], ); is $acc2, '', 'accumulator'; is $val2, 'other'; my $val3 = ''; $exp->expect( 3, [ "some" => sub { $val3 = 'some'; } ], [ "other" => sub { $val3 = 'other'; } ], [ eof => sub { $val3 = 'eof'; } ], [ timeout => sub { $val3 = 'timeout'; } ], ); is $val3, 'eof'; }; subtest raw_reversing => sub { diag "Testing raw reversing..."; plan tests => 11; my @Strings = ( "The quick brown fox jumped over the lazy dog.", "Ein Neger mit Gazelle zagt im Regen nie", "Was ich brauche ist ein Lagertonnennotregal", ); my $exp = Expect->new; # my $exp = Expect->new("$Perl -MIO::File -ne 'BEGIN {\$|=1; \$in = IO::File->new( \">reverse.in\" ) or die; \$in->autoflush(1); \$out = IO::File->new( \">reverse.out\" ) or die; \$out->autoflush(1); } chomp; print \$in \"\$_\\n\"; \$_ = scalar reverse; print \"\$_\\n\"; print \$out \"\$_\\n\"; '"); diag "isatty(\$exp): " . (POSIX::isatty($exp) ? "YES" : "NO"); $exp->raw_pty(1); $exp->spawn(qq{$Perl -ne 'chomp; sleep 0; print scalar reverse, "\\n"'}) or die "Cannot spawn $Perl: $!\n"; my $called = 0; $exp->log_file( sub { $called++; } ); foreach my $s (@Strings) { my $val = ''; my $rev = scalar reverse $s; $exp->send("$s\n"); $exp->expect( 10, [ quotemeta($rev) => sub { $val = 'match'; } ], [ timeout => sub { $val = 'timeout' } ], # was die! [ eof => sub { $val = 'eof'; } ], # was die! ); is $val, 'match', $s; } diag "Called: $called"; cmp_ok $called, '>=', @Strings; $exp->log_file(undef); # now with send_slow $called = 0; $exp->log_file( sub { $called++; } ); my $delay = 0.1; foreach my $s (@Strings) { my $rev = scalar reverse $s; my $now = time; $exp->send_slow( $delay, "$s\n" ); my $val = ''; $exp->expect( 10, [ quotemeta($rev) => sub { $val = 'match'; } ], [ timeout => sub { $val = 'timeout'; } ], # was die! [ eof => sub { $val = 'eof'; } ], # was die! ); is $val, 'match', $s; my $dur = time + 1 - $now; my $delay_by_expect = length($s) * $delay; diag "Elapsed time: $dur delay by expect: $delay_by_expect"; # TODO: Without that +1 this test has randomly failed. (Is this a bug in Expect.pm or a bad expectation?) cmp_ok $dur, '>', $delay_by_expect; } diag "Called: $called"; cmp_ok $called, '>=', @Strings; $exp->log_file(undef); }; subtest system_dependent => sub { diag 'Check if the raw pty can handle large chunks of text at once'; plan tests => 1; my $randstring = 'fakjdf ijj845jtirg8e 4jy8 gfuoyhjgt8h gues9845th guoaeh gt98hae 45t8u ha8rhg ue4ht 8eh tgo8he4 t8 gfj aoingf9a8hgf uain dgkjadshftuehgfusand987vgh afugh 8h 98H 978H 7HG zG 86G (&g (O/g &(GF(/EG F78G F87SG F(/G F(/a sldjkf hajksdhf jkahsd fjkh asdHJKGDSGFKLZSTRJKSGOSJDFKGHSHGDFJGDSFJKHGSDFHJGSDKFJGSDGFSHJDGFljkhf lakjsdh fkjahs djfk hasjkdh fjklahs dfkjhasdjkf hajksdh fkjah sdjfk hasjkdh fkjashd fjkha sdjkfhehurthuerhtuwe htui eruth ZI AHD BIZA Di7GH )/g98 9 97 86tr(& TA&(t 6t &T 75r 5$R%/4r76 5&/% R79 5 )/&'; my $exp = Expect->new; $exp->raw_pty(1); test_reverse($exp, $randstring, 160, 'raw'); }; # Now test for the max. line length. Some systems are limited to ~255 # chars per line, after which they start loosing characters. As Cygwin # then hangs and cannot be freed via alarm, we only test up to 160 characters # to avoid that. subtest max_line_length => sub { diag 'Check if the default pty can handle large chunks of text at once'; plan tests => 1; my $randstring = 'Fakjdf ijj845jtirg8 gfuoyhjgt8h gues9845th guoaeh gt9vgh afugh 8h 98H 97BH 7HG zG 86G (&g (O/g &(GF(/EG F78G F87SG F(/G F(/a slkf ksdheq@f jkahsd fjkh%&/"§ä#üßw'; my $exp = Expect->new; test_reverse($exp, $randstring, 100, 'default'); }; sub test_reverse { my ($exp, $randstring, $min, $type) = @_; diag <<_EOT_; ------------------------------------------------------------------------------ The following tests check system-dependend behaviour, so even if some fail, Expect might still be perfectly usable for you! ------------------------------------------------------------------------------ _EOT_ $exp->spawn(qq{$Perl -ne 'chomp; sleep 0; print scalar reverse, "\\n"'}) or die "Cannot spawn $Perl: $!\n"; $SIG{ALRM} = sub { die "TIMEOUT on send" }; $exp->log_stdout(0); $exp->log_file("$tempdir/test.log"); diag 'Length: ' . length($randstring); my $status = ''; my $maxlen = 0; my $exitloop; foreach my $len ( 1 .. length($randstring) ) { #print "$len\r"; my $s = substr( $randstring, 0, $len ); my $rev = scalar reverse $s; eval { alarm(10); $exp->send("$s\n"); alarm(0); }; if ($@) { #ok( $maxlen > 80 ); diag "Warning: your default pty blocks when sending more than $maxlen bytes per line!"; $status = 'block'; $exitloop = 1; last; } $exp->expect( 10, [ quotemeta($rev) => sub { $maxlen = $len; $status = 'match' } ], [ timeout => sub { diag "Warning: your $type pty can only handle $maxlen bytes at a time!\n"; $status = 'limit'; $exitloop = 1; } ], [ eof => sub { $status = 'eof';} ], ); last if $exitloop; } diag "Good, your $type pty can handle lines of at least " . length($randstring) . " bytes at a time." if not $exitloop; diag "Status: $status"; cmp_ok $maxlen, '>', $min; $SIG{ALRM} = 'DEFAULT'; } subtest controlling_termnal => sub { diag "Testing controlling terminal..."; plan tests => 3; my $exp = Expect->new( $Perl . q{ -MIO::Handle -e 'open(TTY, "+>/dev/tty") or die "no controlling terminal"; autoflush TTY 1; print TTY "Expect_test_prompt: "; $s = ; chomp $s; print "uc: \U$s\n"; close TTY; exit 0;'} ); my $pwd = "pAsswOrd"; $exp->log_file("$tempdir/test_dev_tty.log"); my $val = ''; $exp->expect( 10, [ qr/Expect_test_prompt:/, sub { my $self = shift; $self->send("$pwd\n"); $exp->log_file(undef); exp_continue; } ], [ qr/(?m:^uc:\s*(\w+))/, sub { my $self = shift; my ($s) = $self->matchlist; chomp $s; $val = $s; } ], [ eof => sub { $val = 'eof'; } ], [ timeout => sub { $val = 'timeout'; } ], ); my $before = $exp->before; $before =~ s/[\r\n]*$//; is $before, " pAsswOrd", 'before'; my $after = $exp->after; $after =~ s/[\r\n]*$//; is $after, "", 'after'; is $val, uc($pwd), 'uc'; }; subtest exit_status => sub { diag "Checking if exit status is returned correctly..."; plan tests => 3; my $exp = Expect->new( $Perl . q{ -e 'print "Expect_test_pid: $$\n"; sleep 2; exit(42);'} ); my $val = ''; $exp->expect( 10, [ qr/Expect_test_pid:/, sub { my $self = shift; $val = 'test_pid'; } ], [ eof => sub { $val = "eof"; } ], [ timeout => sub { $val = "timeout"; } ], ); is $val, 'test_pid'; my $status = $exp->soft_close(); diag sprintf "soft_close: 0x%04X\n", $status; is $exp->exitstatus(), $status; is( ( ( $status >> 8 ) & 0x7F ), 42); }; subtest signal => sub { diag "Checking if signal exit status is returned correctly..."; plan tests => 3; my $exp = Expect->new( $Perl . q{ -e 'print "Expect_test_pid: $$\n"; sleep 2; kill 15, $$;'} ); my $val = ''; $exp->expect( 10, [ qr/Expect_test_pid:/, sub { my $self = shift; $val = 'test_pid'; } ], [ eof => sub { $val = "eof"; } ], [ timeout => sub { $val = "timeout"; } ], ); is $val, 'test_pid'; my $status = $exp->soft_close(); diag sprintf "soft_close: 0x%04X", $status; ok( $exp->exitstatus() == $status ); my ( $hi, $lo ) = ( ( $status >> 8 ) & 0x7F, $status & 0x7F ); ok( $hi == 15 or $lo == 15 ); }; diag <<__EOT__; Checking if EOF on pty slave is correctly reported to master... (this fails on about 50% of the supported systems, so don't panic! Expect will work anyway!) __EOT__ subtest eof_on_pty => sub { plan tests => 1; my $exp = Expect->new( $Perl . q{ -e 'close STDIN; close STDOUT; close STDERR; sleep 4;'} ); my $res; $exp->expect( 2, [ eof => sub { $res = 'eof' } ], [ timeout => sub { $res = 'timeout' } ], ); # on OSX it seems that when $Config{osvers} < 13 it returns eof and when osvers is >= 13 then we get timeout # http://www.cpantesters.org/distro/E/Expect.html?oncpan=1&distmat=1&version=1.29 # at least when we sleep 3 and wait for 2 # When we sleep 4 the above is still true, except that one of 12.2.1 machines returned 'timeout': # http://www.cpantesters.org/cpan/report/6dba0d70-2d3d-11e4-8483-fe44e5e3eb0b my $expected = 'timeout'; if ($Config{osname} =~ /^(freebsd|midnightbsd|dragonfly)$/) { $expected = 'eof'; } if ($Config{osname} eq 'darwin' and $Config{osvers} lt '13') { $expected = 'eof'; } if ($Config{osname} eq 'linux') { $expected = '(eof|timeout)'; } like $res, qr/^$expected$/, "Sorry, you may not notice if the spawned process closes the pty. ($expected)"; $exp->hard_close(); }; subtest respawn => sub { plan tests => 1; my $exp = Expect->new; $exp->spawn( $Perl . q{ -e 'print "42\n"'} ); eval { $exp->spawn( $Perl . q{ -e 'print "23\n"'} ) }; like $@, qr/^Cannot reuse an object with an already spawned command/; }; subtest "regexp ref" => sub { plan tests => 1; my $exp = Expect->spawn("$Perl -v"); $exp->log_user(0); is( $exp->expect( 10, qr/L.*[WH]all/ ), 1 ); }; use Test::Builder; my $Test = Test::Builder->new; diag <<__EOT__ if ( not $Test->is_passing ); Please scroll back and check which test(s) failed and what comments were given. Expect probably is still completely usable!! __EOT__ exit(0); Expect-1.36/t/10-internal.t0000755000175000017500000000204214566144303012304 0ustar use strict; use warnings; use Test::More tests => 17; use Expect; my $e = Expect->new; eval { $e->_trim_length }; like $@, qr/^No string passed/; is $e->_trim_length('a' x 999), 'a' x 999; is $e->_trim_length('a' x 1021), 'a' x 1021; is $e->_trim_length('a' x 1023), '...' . 'a' x 1021; is $e->_trim_length('a' x 1024), '...' . 'a' x 1021; is $e->_trim_length('a' x 1025), '...' . 'a' x 1021; is $e->_trim_length('a' x 1025, 2000), 'a' x 1025; is $e->_trim_length('a' x 2001, 2000), 'a' x 2000; eval { Expect::_trim_length() }; like $@, qr/^No string passed/; is Expect::_trim_length(undef, "z" x 1020), 'z' x 1020; is Expect::_trim_length(undef, "z" x 1021), 'z' x 1021; is Expect::_trim_length(undef, "z" x 1022), '...' . 'z' x 1021; is Expect::_trim_length(undef, "z" x 1024), '...' . 'z' x 1021; is Expect::_trim_length(undef, "z" x 2000), '...' . 'z' x 1021; is Expect::_trim_length(undef, "z" x 2000, 2000), 'z' x 2000; is Expect::_trim_length(undef, "z" x 2000, 1999), 'z' x 1999; is Expect::_trim_length(undef, "z" x 2000, 2001), 'z' x 2000; Expect-1.36/t/03-log.t0000755000175000017500000000475014566144303011263 0ustar use strict; use warnings; use Test::More tests => 11; use File::Temp qw(tempdir); use Expect; my $tempdir = tempdir( CLEANUP => 1 ); my $logfile = "$tempdir/expect_output_file"; my $e = Expect->new; $e->raw_pty(1); $e->log_stdout(0); $e->spawn($^X . q{ -ne 'sleep 1; chomp; print scalar reverse; print "\n"' }); my @reply; diag "Test created for https://rt.cpan.org/Ticket/Display.html?id=62359 related to clear_accum"; { $e->send("abc\n"); $e->expect(3, [qr/cba/ => sub { push @reply, 'cba' } ]); } { $e->log_file($logfile, "w"); $e->send("hello\n"); $e->expect(3, [qr/olleh/ => sub { push @reply, 'olleh' } ]); my $log_before = slurp($logfile); is $log_before, "olleh\n", 'logfile'; # I am not sure if we can really expect this to be already written (buffering?) $e->log_file(undef); my $log = slurp($logfile); is $log, "olleh\n", 'logfile'; } { $e->send("world\n"); $e->expect(3, [qr/dlrow/ => sub { push @reply, 'dlrow' } ]); #$e->log_file(undef); my $log = slurp($logfile); is $log, "olleh\n", 'logfile'; } { $e->log_file($logfile, "w"); $e->send("zorg\n"); $e->expect(3, [qr/groz/ => sub { push @reply, 'groz' } ]); $e->log_file(undef); my $log = slurp($logfile); is $log, "groz\n", 'logfile'; } # code example from https://rt.cpan.org/Ticket/Display.html?id=62359 { $e->send("first\n"); is $e->clear_accum(), "\n", 'nothing to clear yet'; $e->log_file(undef); $e->log_file($logfile, "w"); $e->send("second\n"); $e->expect(3, "other"); my $log = slurp($logfile); is $log, "tsrif\ndnoces\n", 'logfile'; } # accum will only have data *after* we called ->expect. { $e->send("one\n"); $e->expect(2, "other"); # added call - wait 2 is $e->clear_accum(), "tsrif\ndnoces\neno\n"; $e->log_file(undef); $e->log_file($logfile, "w"); $e->send("two\n"); $e->expect(3, "other"); my $log = slurp($logfile); is $log, "owt\n", 'logfile'; } # but even calling ->expect is not enough. Stuff the AUT sends after # that first call to ->expect times out will not be in the accumulator # and thus clear_accum wont remove it. { $e->send("first\n"); $e->expect(0, "other"); # added call wait 0 is $e->clear_accum(), "owt\n"; # from the previous block $e->log_file(undef); $e->log_file($logfile, "w"); $e->send("second\n"); $e->expect(3, "other"); my $log = slurp($logfile); is $log, "tsrif\ndnoces\n", 'logfile'; } is_deeply \@reply, ['cba', 'olleh', 'dlrow', 'groz'], 'reply'; sub slurp { my ($filename) = @_; open my $fh, '<', $filename or die; local $/; return scalar <$fh>; } Expect-1.36/t/11-calc.t0000755000175000017500000000421214566144303011374 0ustar use strict; use warnings; use Test::More; plan tests => 22; use Expect; my $e = Expect->new; $e->spawn($^X, "examples/calc.pl") or die; $e->log_stdout(0); #$e->raw_pty(1); is $e->match, undef, 'match'; is $e->before, undef, 'before'; is $e->after, undef, 'after'; is $e->get_accum, '', 'get_accum'; my $space; { $e->send("19+23\n"); my $exp = $e->expect(1, "19+23"); is $exp, 1, 'expect'; is $e->match, '19+23', 'match'; is $e->before, '', 'before'; my $SPACE = qr/\s*/; my $OUTPUT = qr/\s*Input: '19\+23' = '42' :Output\s*/; # This is very strange. It seems that the same system sometimes will have an almost empty 'after' # and in other cases thet will have an 'after' containing the the string returned by the AUT. # See for example the Travis reports of the Github repository. # https://travis-ci.org/szabgab/expect.pm/builds # between build 11 and 19 # The same strange behaviour is also encountered on the CPAN Testers. like $e->after, qr/^($SPACE|$OUTPUT)$/, 'after'; $space = $e->after =~ /^$SPACE$/; diag $space ? 'SPACE' : 'OUTPUT'; my $ACCUM = $space ? $SPACE : $OUTPUT; like $e->clear_accum, qr/^$ACCUM$/, 'clear_accum'; } SKIP: { skip 'Strange behavior on some of the systems', 4 if not $space; my $exp = $e->expect(1, '-re' => qr/'\d+'/); is $exp, 1, 'expect'; is $e->match, q{'42'}, 'match'; is $e->before, q{Input: '19+23' = }, 'before'; like $e->after, qr/^ :Output\s*$/, 'after'; } { my $exp = $e->expect(1, 'abc'); is $exp, undef, 'expect'; is $e->match, undef, 'match'; my $BEFORE = $space ? qr/^ :Output\s*$/ : qr/^$/; like $e->before, $BEFORE, 'before'; is $e->after, undef, 'after'; like $e->clear_accum, $BEFORE, 'clear_accum'; } { my $exp = $e->expect(1, 'xyz'); is $exp, undef, 'expect'; is $e->match, undef, 'match'; is $e->before, '', 'before'; #?? is $e->after, undef, 'after'; } $e->close; # These tests faled on midnightbsd, and on almost all cases of gnukfreebsd # http://www.cpantesters.org/cpan/report/fb542c9a-3253-11e4-a396-829772410e08 # one was successful though. # On netbased failed on all except this one: # http://www.cpantesters.org/cpan/report/fd895392-2bbd-11e4-b698-db7a2867dcfa Expect-1.36/Changes0000755000175000017500000003130414566207257011130 0ustar Revision history for CPAN module Expect 1.36 2024-02-23 - Made timeouts optional and added qr// regex support 1.35 2017-05-18 - Added AUTHOR key, listing all maintainers 1.34 2017-05-18 Official maintainer JACOBY (Dave Jacoby) - Added a MANIFEST so that "make dist" will work 1.33 2016-06-08 Remove dependency on Test::Exception 1.32 2014-10-26 Skip bc tests. https://rt.cpan.org/Ticket/Display.html?id=98495 1.31 2014-09-02 Eliminate the requirement for ExtUtils::MakeMaker 1.70. Now any ExtUtils::MakeMaker should work on the client side. In the tests, add special treatment for $^O=midnightbsd and dragonfly. and for $^O=linux as well. Test t/11-calc.t also got some special treatment. 1.30 2014-08-22 RT #47834 After a failed call to ->expect the ->match, and ->after will return undef and ->before will return the content of the accumulator. Earlier they retained the values obtained during the last successful match. ->before will return undef at the first time but later, if we call ->clear_accum, it will start returning the empty string. CONFIGURE_REQUIRES ExtUtils::MakeMaker 6.70 Some test updates. 1.29 2014-08-14 Official co-maintainer SZABGAB (Gabor Szabo) Update documentation according to RT #60722 1.28 2014-08-14 Croak if undef passed to _trim_length Fix double planning on skipped test 1.27 2014-08-13 Remove $& and $` fixing the rest of RT #61395 Add more test cases. Various code refactoring declaring loop variables; parameter passing; return undef; etc. 1.26 2014-08-12 Skip the bc test on OS-es where it has been failing. Stop inheriting from Exporter. Eliminate $` and $' from the code. part of (RT #61395) This fix might break some existing code n some extreme cases when the regex being matched has a lookbehind or a lookahead at the edges. 1.25 2014-08-05 Fix test count. 1.24 2014-08-04 More test diagnostics. Tests added for RT #62359 1.23 2014-07-29 Refactoring test script. Eliminate indirect calls in the code and in the docs. Use Perl::Tidy to unify layout. Add use warnings; IO::Tty prerequisite version 1.03 => 1.11 1.22 2014-07-27 New unofficial mainainer (Gabor Szabo) Merge .pod and .pm and move them to lib/ Move the test and the code to standard location /t in the distribution. Eliminate indirect calls in tests. Use Test::More instead of home-brew testing. Typos fixed in pod RT #86852. Changes file re-ordered and standardized. 1.21 2007-08-13 1.20 2006-07-21 + added early return to send and send_slow if filehandle was closed + added test for send_slow ! fixed bug in expect() param handling (exact pattern "0" was ignored) ! fixed bug in _make_readable() + now included example ssh.pl in MANIFEST so it gets packaged :-( 1.19 2006-07-17 ! fixed non-localized usage of $_ + added new example ssh.pl 1.18 2006-07-11 ! added another pipe to synchronize spawning. Closing the slave in the parent can lead to a hang if the child already wrote something into it... ! fixed REs in test to deal with shell prompts 1.17 2006-05-31 ! fixed param check for expect() to allow expect(undef) et al 1.16 2006-05-05 ! fixed hangup with pipe sync upon spawn by adding close-on-exec to pipe handle ! fixed log_file(undef) when logging to CODE ref ! fixed $? mangling in DESTROY by saving & restoring status ! fixed hangup in send_slow ! fixed ugly solaris hack by disabling it for raw ptys + added param check for expect() 1.15 2002-03-19 ! fixed bug in _multi_expect, pattern weren't tried against accum due to exp_New_Data not set. 1.14 2002-03-13 same as 1.13_10 ! fixed select in interconnect, may return -1 if interrupted by signal. 1.13_08 2002-02-28 ! fixed bug in log_file, parameter now gets set to undef. 1.13_07 2002-02-28 + added and corrected test for exit status; got rid of Test.pm ! use 'set_raw' instead of stty("raw"); IO::Stty now optional + updated docs & FAQs; explained how terminal sizes and SIGWINCH should be propagated 1.13_06 2002-01-31 ! spawn is back again + rearranged and changed tests to better suit the various systems + added rudimentary 'notransfer' option; global only, not on per-pattern-basis; workaround available in FAQ + timeout handlers now also can exp_continue + added 'raw_pty' option, also setting master to raw if isatty() 1.13_04 2002-01-18 1.13_02 2001-11-30 1.13_01 2001-11-26 1.13 ! changed tests to check out pty behaviour (max. string length) + added various FAQ entries + added autoflush(1) to log_file + split 'new' and 'spawn' to be able to set slave pty params via stty before actually spawning the program + added slave_pty() + added print_log_file(), send() now no longer prints to log file or stdout. + added alarm to test.pl to avoid blocking on cygwin. ! spawn() now uses IO::Pty spawn, thus exec errors are reported and ssh should work too! 1.12 2001-09-06 ! exp_Max_Accum didn't work for interact. - removed soft_close() from DESTROY. Being overly nice to a doomed process doesn't pay off. Old behaviour is available via $Expect::Do_Soft_Close = 1; ! cleanup of log and exp_internal output + added various aliases for functions starting with 'exp_' ! moved FAQ and intro into the main pod as I got the impression that many users didn't bother to read all the documentation or didn't know that it was there. + added a hook for log_file: can be set to a code ref. 1.11 2001-02-20 Bugs fixed: ! max_accum (match_max) finally really restricts the match-buffer-size. ! expect() didn't return the correct error state upon EOF ! soft_close() was re-reading the filehandle even when an EOF had already been detected, resulting in a very long delay. ! exp_continue() returned a value that got truncated with certain perl versions (5.6 :-( ) on certain systems. Features added: + Lee Eakin contributed a perl version of the kibitz script which might be of common interest. See the examples/kibitz subdir. Thanks Lee! + Expect got it's own print() so we can show what's getting sent to the spawned program when exp_internal is set. (suggested by horos@earth.he.net) + a session can now be logged to a file by setting log_file(). Thanks to Marcel Widjaja for suggesting this. + I added some aliases for certain methods to help Tcl/Expect users to a WLIE experience (Work Like I Expect). 'exp_pid', 'match_max', 'log_file', 'log_user', even 'send' (which is an alias for 'print') are all there now. But I won't make 'send_user' an alias for 'print STDOUT', you have to draw a line somewhere. + some diagnosis messages now use cluck to print a stacktrace (suggested by horos@earth.he.net) + there is a new option 'restart_timeout_upon_receive', that, when set to 1, will restart the timeout within the expect call. This is useful when supervising an application that produces periodic, but not well-defined output and you still want to react to certain patterns. Just say $exp->restart_timeout_upon_receive(1); $exp->expect($timeout, [ timeout => \&report_timeout ], [ qr/pattern/ => \&handle_pattern ]); (suggested by horos@earth.he.net) 1.10 2000-11-22 I cannot believe it: a syntax error in Expect.pm slipped through (probably when I changed the version number after testing the patches), forcing me to do anouther release. >:-( 1.09 2000-11-21 Various small bugfixes: exp_before didn't get set on timeout, the expect call didn't return on matching EOF, spawn didn't die when exec failed, Expect crashed in certain cases. 1.08 2000-09-20 Added multi-match functionality (see docu) --Roland 1.07 1998-07-12 Changed the ver by .01 so I could get it up on CPAN :P 1.06 Added exp_before(), exp_after(), exp_match(), exp_match_number(), exp_error(). 1.05 Added debug level '3'. Fixed/added to tutorial, fixed a couple of minor bugs. 1.04 1998-03-12 Made all handles exp_inited autoflush. IO::Pty does the spawned processes for us. All regexp patterns passed to expect() are now multiline matched-- this makes matching ^ work for the beginning of lines. Unfortunately due to limitations in perl matching $ as the end of a line doesn't work if you are being returned \r\n instead of just \n. In this case you can use \r?$ to match the end of a line. exp_stty now checks to make sure the FH is a tty. 1.03 Reworked expect() to make the code more fluid. Removed ~50 lines of cruft. Added soft_close() and hard_close() (see Expect.pod for details). 1.02 Killed the $Expect::Use_Regexps stuff. Changed expect to look for '-re' strings indicating the subsequent pattern is to be matched as a regular expression. 1.01 1997-12-15 Dropped process still alive during expect. Sometimes the process dies before the handle finishes getting read. Fixed a typo that caused a response of 'child process died' if a successfull pattern had a null value. Added the ability to do expect() literals instead of regular expressions. see $process->use_regexps and the package global $Expect::Use_Regexps. Fixed internals to work with the documented fashion for using file ojects. everything is internally represented as ${*$process}{exp_variable} instead of ${*$process}{variable}. Pids should be checked with $process->pid() now, since $process->{Pid} no longer exists. exp_kill() is obsolete. Use kill($signal,$process->pid()). 1.00 exp_close no longer sends an exp_kill() to the process. This was kind of a dumb thing to do in the first place. Processes should go away after they are close()d. In fact, there really isn't any point in using exp_close. Just use $process->close();. -This isn't true as of 1.03, where soft and hard close were added to help deal with buffering issues. 0.99 Changed expect() to return the index of the matched pattern + 1. This enables the 'quick and dirty' $process->expect($timeout,'patern') || die; sort of behavior. 0.98 Changed everything. Now requires IO::Tty and uses IO::Stty. This should make it work on any posix-supporting platform that includes a method of obtaining a pty. Got rid of the 'detach' stuff, as it cluttered stuff up too much. Do your own forking. Default settings are now done by directly setting Expect::Values, such as $Expect::Debug and $Expect::Log_Stdout. Things now use 'spawn ids' and 'handle ids' instead of handle numbers. This makes debugging a little more sensible. Though there may be more bugs in the ver. I'm hopeful it should prove to be much more stable, reliable, intuitive and portable than previously. 0.972 Fixed setpgrp to be setsid. Oops. Processes opening /dev/tty should be much happier now. 0.97 Forced baud rate to get set at startup to make sure it wasn't set to 0 and sending EOFs. Linux now hangs consistently. It will probably not work until I get to the stty module. Sigh. Time to stop being lazy :) Also forced complete handle flushing after handles are opened. Probably a bit anal but I'd rather err on the side of safety. After the stty problem gets fixed I'll probably change over eveything to use the IO::Pty module. 0.96 Fixed a couple of idiot mistakes concerning DEBUG mode and printing debug info to STDERR. Changed some debugging spots so debugging info will always be printed in readable escaped format rather than raw input. 0.95 Linux had this bizarre problem of stty occasionally not returning when setting raw -echo. My solution was to run it twice, once for raw and once for echo. The real solution is of course to write an stty function using the POSIX module.. any volunteers? :-) 0.94 Think I fixed the problem of opening /dev/tty. Should work now. Also fixed a typo which caused the initial value of Log_Stdout to be set wrong. 0.92 Finally figured out how to generate an EOF on a terminal (stty 0 but you knew that already ;). Whole module needs a spring cleaning but seems to be pretty functional. After the (later) introduction of a POSIX stty function the code involving stty should get a little cleaner. Interact, interconnect and expect should all benefit from the EOF fix. interconnect also looks for FH exceptions, which it treats as EOFs. Expect-1.36/LICENSE0000755000175000017500000000254314566144303010635 0ustar (c) 1997 Austin Schutz EFE (retired) expect() interface & functionality enhancements (c) 1999-2006 Roland Giersig. This module is now maintained by Dave Jacoby EFE LICENSE This module can be used under the same terms as Perl. DISCLAIMER THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. In other words: Use at your own risk. Provided as is. Your mileage may vary. Read the source, Luke! And finally, just to be sure: Any Use of This Product, in Any Manner Whatsoever, Will Increase the Amount of Disorder in the Universe. Although No Liability Is Implied Herein, the Consumer Is Warned That This Process Will Ultimately Lead to the Heat Death of the Universe. Expect-1.36/META.json0000755000175000017500000000306314566210227011246 0ustar { "abstract" : "automate interactions with command line programs that expose a text terminal interface.", "author" : [ "Austin Schutz ", "Roland Giersig ", "Dave Jacoby " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.62, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Expect", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : {} }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "6.64" } }, "runtime" : { "requires" : { "Carp" : "0", "Errno" : "0", "Exporter" : "0", "Fcntl" : "0", "IO::Handle" : "0", "IO::Pty" : "1.11", "IO::Tty" : "1.11", "POSIX" : "0", "perl" : "5.006000" } }, "test" : { "requires" : { "File::Temp" : "0", "Test::More" : "1.00" } } }, "release_status" : "stable", "resources" : { "repository" : { "type" : "git", "url" : "http://github.com/jacoby/expect.pm.git", "web" : "http://github.com/jacoby/expect.pm" } }, "version" : "1.36", "x_serialization_backend" : "JSON::PP version 4.06" } Expect-1.36/MANIFEST0000755000175000017500000000124714566210227010760 0ustar Changes examples/calc.pl examples/expect_calc.pl examples/kibitz/Changelog examples/kibitz/kibitz examples/kibitz/kibitz.man examples/kibitz/README examples/ssh.pl lib/Expect.pm LICENSE Makefile.PL MANIFEST This list of files README.md t/01-test.t t/02-bc.t t/03-log.t t/04-multiline.t t/10-internal.t t/11-calc.t tutorial/1.A.Intro tutorial/2.A.ftp tutorial/2.B.rlogin tutorial/3.A.debugging tutorial/4.A.top tutorial/5.A.top tutorial/5.B.top tutorial/6.A.smtp-verify tutorial/6.B.modem-init tutorial/README META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Expect-1.36/tutorial/0000755000175000017500000000000014566210226011462 5ustar Expect-1.36/tutorial/2.A.ftp0000755000175000017500000000602314566144303012523 0ustar #!/usr/local/bin/perl # This example demonstrates how to spawn an ftp process, have it #log in to a host, and grab a file off the host. This should give you a #general idea of how to spawn processes and talk to them. # The first thing I do when attempting to automate a process is do it #by hand, so you know what interaction with the process should look like. # I highly recommend you read the information on debugging in chapter #3 before actually trying this yourself. # # Usage: script ftphost file1 [file2 file3.. ] use Expect; # Optional debugging, explained later. # $Expect::Debug=1 # $Expect::Exp_Internal=1; # $Expect::Log_Stdout=0; # On by default. $host = shift @ARGV; # Let the host be the first argument we are given. @files = @ARGV; # Let the names of the files be the remaining arguments. # Make sure we're trying to get something. unless ($host ne '' && @files > 0) { print STDERR <spawn("ftp $hostname")) || die "Couldn't spawn ftp, $!"; # Look for a username prompt. On my box this looks like: # "Name (ftp.cdrom.com:tex): " # So, let's see what our username is. $username = $ENV{'USER'}; # Time out if we don't get it within 30 seconds. unless ($ftp->expect(30,"Name ($hostname:$username): ")) { die "Never got username prompt on $hostname, ".$ftp->exp_error()."\n"; } # Ok, so we have the username prompt. Let's send it "anonymous". # Note how I follow with a \r. print $ftp "anonymous\r"; # And we want a password prompt now. # On my box this looks like: # 331 Guest login ok, send your complete e-mail address as password. # Password: # Where there are no spaces after the password. This is important to note # since, if there were a space, we might try sending a password before # the ftp server finished giving us a prompt or if we were looking for a space # and there wasn't one we might end up not matching. # To save time I cut and pasted most of the line above where we grabbed the # username prompt. unless ($ftp->expect(30,"Password:")) { die "Never got password prompt on $hostname, ".$ftp->exp_error()."\n"; } # Grabbing our actual domain would be the better thing to do here but is # outside the scope of this example. print $ftp "$username\@mycompany.com\r"; # Now we look for a prompt, having (we hope) successfully logged in. unless ($ftp->expect(30,"ftp> ")) { die "Never got ftp prompt after sending username, ".$ftp->exp_error()."\n"; } # Ok. We have a prompt on the foreign machine, so let's get the files. # Notice that at the end of each loop we are at an ftp> prompt. foreach $file (@files) { print $ftp "get $file\r"; unless ($ftp->expect(30,"ftp> ")) { die "Never got ftp prompt after attempting to get $file, ".$ftp->exp_error()."\n"; } } # We should have all the files. If this is the end of the script we can # quit without bothering to close the process. Perl will take care of it # for us. Later examples will demonstrate the differences between # close(), soft_close(), and hard_close(). Expect-1.36/tutorial/3.A.debugging0000755000175000017500000000367314566144303013676 0ustar #!/usr/local/bin/perl # This example demonstrates how to use the debugging features in #expect. They're reasonably straghtforward. # # There are 3 basic ways you can debug a script: # # 1. Log_Stdout # # By setting $Expect::Log_Stdout you control whether or not processes #will echo to the screen or not. Having it turned on can be helpful so you #can watch what a process is doing. Alternately, for a process that is already #running you can do $process->log_stdout(1); which will turn on process #output for the process from that instant on. $process->log_stdout(0) will #turn it off. # By default $Expect::Log_Stdout == 1. Initialized handles (discussed #later) may also echo to STDOUT, but they don't do so by default. You have #to manually tell them to echo. You wouldn't want your log file jabbering at #you would you? Anyway, that will make sense later. # # 2. Exp_Internal # # Setting $Exp_Internal=1 (or $process->exp_internal(1)) will output #pattern matching information for expect() calls to STDERR. You can trap #this by doing "perl expect_script.pl 2>debug.out" if you are using any of #the bourne-ish shells. For people who use csh, don't. "exec bash" will take #care of that straightaway. This is handy so program output and debugging output #don't go to the same place. # # 3. Debug # # Setting $Expect::Debug = debug level(or $process->debug(debug level)) #will show other stuff, such as pids, output during interaction, and other #miscellaneous output not covered by the above two items. In combination with #Exp_Internal you can capture a lot of good information about what your script #is doing. Debugging info also goes to STDERR. # # # This example will show (lots) of debugging info. use Expect; $Expect::Log_Stdout=1; $Expect::Debug=3; $Expect::Exp_Internal=1; # lpc is a bsd printer control program. It's included in every Unix I # deal with. $lpc = Expect->spawn("lpc"); $lpc->expect(30,"lpc> ") && print $lpc "stat\r"; $lpc->hard_close(); Expect-1.36/tutorial/2.B.rlogin0000755000175000017500000000772114566144303013233 0ustar #!/usr/local/bin/perl # There are three new things in this example. First is the concept #of closing the process, second is the concept of using regular #expressions in match patterns, and third is the concept of grabbing #stuff that is in the process's buffer. This last part is like when you #telnet to a host, do ls, and want to know the name of the files returned: # # #somehost$ ls #thing #thing.gz #core #Mail #mail #somehost$ # # When you use the expect() function it is possible to grab the #data before the next patter looked for. in this case if you were #looking for "somehost$ " you could get the names of the files returned #in the ls. In the example below the output of the 'id' command is grabbed #for use by the program. # # What this example tries to do is log in to foreign hosts and #grab the user id on each host. # use Expect; # Optional debugging, explained later. # $Expect::Debug=1 # $Expect::Exp_Internal=1; # $Expect::Log_Stdout=0; # On by default. die "Usage: $0 host1 host2... hostn\n" unless defined $ARGV[0]; @hosts = @ARGV; # Ssh would be better, rlogin is used here because it is more familiar. foreach $host (@hosts) { $rlogin=Expect->spawn("rlogin $host"); $rlogin->expect(30,"ssword: ") || die "Never got password prompt on $host, ".$rlogin->exp_error()."\n"; # We got the prompt, so send a password. print $rlogin "H4yB3vis\r"; # Now we look for a shell prompt. Notice the use of the regular expression. # To use a regexp make the previous argument '-re'. # expect will match on the hostname followed by a %, >, or $ followed by # whitespace. Notice that the regular expression part is in single quotes. # This is so that perl won't interpret control characters such as # whitespace (\s) for us until it gets in to the pattern matching engine. # my prompt is "darkwing$ ". Yours is probably different. # The below expect() call will return 1 if it matches the closed by foreign # host string or 2 if it matches the regular expression. # undef is returned if nothing matches. $match=$rlogin->expect(30,"closed by foreign host","-re",$host.'[%>$]\s'); die "Dumped by server\n" if $match == 1; die "Never got shell prompt on $host, ".$rlogin->exp_error()."\n" unless $match; # Ok, so we have a shell prompt. let's give it the 'id' command. print $rlogin "id\r"; # Now, we know that because ther terminal will echo "id\r" back to us # we should grab it so it won't muck with our final output. # Also, on most terminals if you send a carriage return it will respond # with a carriage return-newline combination. So we do: $rlogin->expect(30,"id\r\n"); # which clears id out of the buffer. Note that I used \r\n in double # quotes instead of single quotes because I want perl to look for # a carriage return instead of the literal \r\n. If I had instead done # $rlogin->expect(30,'-re','id\r\n'); it would work because it gets # tossed in to a regular expression where \r and \n get evaluated. # Now when we use expect() to find the next prompt the output of the last # command will be in the buffer that holds output between expect() calls. # this output should be 'before' we match. # I'm going to define what prompt we're looking for ahead of time to # make the call to expect more readable. $prompt = $host.'[%>$]\s'; $rlogin->expect(30,'-re',$prompt); # Yet another way to find out if we had a successful match is to test for # an error. die "Never got prompt after sending 'id' command\n" if $rlogin->exp_error(); # And the output of id: print "id on $host: $rlogin->exp_before()"; # Now, we do a hard close here. We are positively done with rlogin and we # know that it won't be ending by itself. This would be unlike, say, # a command like "tail /etc/passwd" which will exit as soon as it is finished # sending us its output. For that sort of a command soft_close() would # suffice. # It is important that you close rlogin so that processes don't # pile up eating your system resources during further loops through # hosts. $rlogin->hard_close(); # next host } Expect-1.36/tutorial/6.B.modem-init0000755000175000017500000000345114566144303014003 0ustar #!/usr/bin/perl # This is a very brief script that demonstrates send_slow(). This #command is chiefly for talking to modems and the like where if you send #it stuff too fast it can get mad at you. # Also demonstrated is how to talk to a bidirectional device #handle. # # This example has been changed in 1.05 so that it actually works. :-) use Expect; $device="/dev/modem" unless $device = shift(@ARGV); # open the device open(DEVICE,"+>$device") || die "Couldn't open $device, $!\n"; # Expectize it. note the \* which we do because we didn't use the OO # method of opening the device. $modem=Expect->exp_init(\*DEVICE); # Let's watch the output. Once again, output isn't automatically # watched since it was an initialized handlde and not a process. $modem->log_stdout(1); # Put it in raw mode w/ no echoing so it will operate as expected. $modem->exp_stty('raw','-echo'); # Send it an ATZH0\r to reset its state. print "Initializing modem\n"; $modem->send_slow(.5,"ATZH0\r"); # How about we look for an OK? $modem->expect(30,'-re','^OK\r?$')|| warn "Never got OK from modem\n"; print "Modem initialized.\n"; # Now let's interact with it so the user can talk to it, dial it out, # whatever. This is basically a poor man's term program. # When you interact() with a handle it puts STDIN in raw mode so # you are assured of interacting cleanly, no escape chars, etc. # This is usually what you want. Here however it's nice to be able to # escape from the session without doing any extra work. So let's make # an escape character of ^W. print "Beginning interaction, escape character is ^W.\n"; $modem->interact(\*STDIN,"\027"); # Done? Reset the modem, close the handle. print $modem "+++"; sleep 3; print $modem "ATZH0\r"; sleep 1; # Grab any output ready on the handle, toss it. $modem->expect(0); $modem->hard_close(); Expect-1.36/tutorial/5.A.top0000755000175000017500000000217114566144303012537 0ustar #!/usr/local/bin/perl # Here we are doing this again only this time we'll do it #without Echoing the password. $RSH='/usr/bin/ssh'; $host_to_login_to=shift(@ARGV); use Expect; print "Enter password: "; # First we have to initialize STDIN in to an expect object. $stdin=Expect->exp_init(\*STDIN); # Now turn off echoing $stdin->exp_stty('-echo'); # The easy way to do this is: #$password=; #chop $password; # The somewhat harder way is to use $stdin->expect. This would look like: # ($match_num,$error,$match,$before,$after)=$stdin->expect(undef,"\r"); $password = $before; # Turn echo back on $stdin->exp_stty('echo'); # print that newline that wasn't echoed print "\n"; $rsh=Expect->spawn($RSH,$host_to_login_to); # Look for a password prompt. $rsh->expect(30,'-re','word:\s$')||(die"Never got password prompt\n"); print $rsh "$password\r"; # Look for a prompt. Prompt can be # $ > or ] followed by a whitespace. $prompt = '[\]\$\>\#]\s$'; # Note the use of -re $rsh->expect(30,'-re',$prompt)||(die "Never got prompt on host\n"); # Start top print $rsh "exec top\r"; # OK, now return control to user. $rsh->interact(); Expect-1.36/tutorial/5.B.top0000755000175000017500000000463014566144303012542 0ustar #!/usr/local/bin/perl # Here we set manual_stty on the process so we can do things like #hit ^Z to stop it instead of the ^Z going to the process on the other machine. # This is to say, normally when you interact with a process STDIN is #put in raw mode so everything you type talks to the process at the other end. # Picture this. When you telnet somewhere and start a process (top #for example) you are talking to telnet in raw mode. If you press ^Z it #goes through telnet to the shell on the remote machine and the process #at the other end is stopped. Here we're going to make it so raw mode is #never set and when you press ^Z or ^C it will stop/interrupt Expect. # Also briefly demonstrated is the use of Expect::interconnect(), #a more general/versatile alternative to interact. use Expect; # Debugging anyone? # $Expect::Log_Stdout=1; # $Expect::Exp_Internal=1; # $Expect::Debug=1; $RSH='/usr/bin/ssh'; $host_to_login_to=shift(@ARGV); print "Enter password: "; $|=1; # First we have to initialize STDIN in to an expect object. $stdin=Expect->exp_init(\*STDIN); # Now turn off echoing $stdin->exp_stty('-echo'); # The easy way to do this is: #$password=; #chop $password; # The somewhat harder way is to use $stdin->expect. This would look like: # ($match_num,$error,$match,$before,$after)=$stdin->expect(undef,"\n"); $password = $before; # Turn echo back on $stdin->exp_stty('echo'); # print that newline that wasn't echoed print "\n"; #$Expect::Exp_Internal=1; $rsh=Expect->spawn($RSH,$host_to_login_to); # Look for a password prompt. $rsh->expect(30,'-re','word:\s$')||(die"Never got password prompt\n"); print $rsh "$password\r"; # Look for a prompt. Prompt can be # $ > or ] followed by a whitespace. $prompt = '[\]\$\>\#]\s$'; # Note the use of -re $rsh->expect(30,'-re',$prompt)||(die "Never got prompt on host\n"); # Start top print $rsh "exec top\r"; # We already have an inited handle for STDIN above which we can use. # We don't just do $rsh->interact because it will go monkeying # with tty settings by default (set it raw). $stdin->manual_stty(1); # Instead we use interconnect directly. # The trick here is to make sure: # 1. Everything listening to a handle is added to its # listen group. # 2. Only what you want is jabbering at STDOUT. # # In this case only $rsh will talk to STDOUT so we don't have to # change any log_stdout() settings. $stdin->set_group($rsh); Expect::interconnect($stdin,$rsh); Expect-1.36/tutorial/4.A.top0000755000175000017500000000164614566144303012544 0ustar #!/usr/local/bin/perl # This example is a replay of sorts of the rlogin example #before except in this example we turn control of the process back #to the user through use of interact(). use Expect; # $Expect::Debug=2; $Expect::Exp_Internal=1; $RSH='/usr/local/bin/ssh'; $host_to_login_to=shift(@ARGV); # Get the password. We will show how to do this without printing the # password to the screen later. print "Enter password: "; $password=; chomp $password; $rsh=Expect->spawn($RSH,$host_to_login_to); # Look for a password prompt. $rsh->expect(30,'-re','word:\s$')||(die"Never got password prompt\n"); print $rsh "$password\r"; # Look for a prompt. Prompt can be # $ > or ] followed by a whitespace. $prompt = '[\]\$\>\#]\s$'; # Note the use of -re $rsh->expect(30,'-re',$prompt)||(die "Never got prompt on host\n"); # Start top print $rsh "exec top\r"; # OK, now return control to user. $rsh->interact(); Expect-1.36/tutorial/6.A.smtp-verify0000755000175000017500000000627414566144303014233 0ustar #!/usr/bin/perl -w # Here's something that is of actual use, and should be relatively #portable. # Given an email address and a mail server name check to see if #the address is deliverable on that box. This can be used for address #verification or spam relay checking. # # The point of this is to show how you can take a generic handle #and interact with it. In this example a socket is used. use Expect; use IO::Socket; # $Expect::Debug=1 # $Expect::Exp_Internal=1; # $Expect::Log_Stdout=0; # On by default. This does not affect Expect # objects created with Expect->exp_init() however. By default the output of # those handles will not be output to the screen. use $handle->log_stdout(1) # to turn that on after you initialize the handle. # Arg. 0 hostname of mail server $mail_server=shift(@ARGV); # Remaining args will be email addresses. @addresses=@ARGV; die "Usage: $0 mail_server address1 [address2 address3.. addressN]\n" unless @addresses; # Connect to mail server. This is right out of perldoc IO::Socket. $smtp_sock = IO::Socket::INET->new(PeerAddr => "$mail_server:smtp(25)"); die "Couldn't connect to $mail_server, $!" unless defined $smtp_sock; # Turn the socket in to an expect object. $smtp_session=Expect->exp_init($smtp_sock); # By default Expect doesn't print out the output of an exp_inited item. # Generally you don't want handles jabbering at you. In this case # we might turn it on so we can watch what happens. #$smtp_session->log_stdout(1); # Watch debugging? #$smtp_session->exp_internal(1); # Ok, now let's see if the mail server wants to talk to us: $smtp_session->expect(30,'-re','^220.*\n')||die "Bad response from server\n"; # Cool. Now let's introduce ourselves to the server. # There are many other ways to gain the FQDN of this box. This is mine, # and it's easy. This of course assumes you have uname and that -n returns # your hostname. $my_hostname = `uname -n`; chomp $my_hostname; print $smtp_session "HELO $my_hostname\n"; # My server responds with a 250 + stuff. Presumably that's RFC compliant. # Feel free to go look :-) $smtp_session->expect(30,'-re','^250.*\n')||die "Bad response after HELO\n"; # Try sending mail.. I should probably use my username rather than user@ # but I'm too lazy. print $smtp_session "MAIL FROM:\n"; $smtp_session->expect(30,'-re','^250.*\n')||die "Bad response after FROM\n"; # Now to check each address... foreach $address (@addresses) { print $smtp_session "RCPT TO:<$address>\n"; # Now check the status... ($match_num,$error,$match)=$smtp_session->expect(30,'-re','^\d\d\d'); die "Never got response back after trying RCPT to $address\n" if $error; $status = $match; # Read to the newline so the server will be ready for the next address. # If the server spit back something other than 250 we'll display the # Whole error. ($match_num,$error,$match)=$smtp_session->expect(30,'-re','.*\n'); die "Server seems to have hung after trying address $address\n" if $error; if ($status == 250) { $status = "ok\n"; } else { $status.=$match; } print "Status of address $address: $status"; } # Be good citizens, send a quit. print $smtp_session "QUIT\n"; # At which point it should die nicely. $smtp_session->soft_close(); Expect-1.36/tutorial/README0000755000175000017500000000120414566144303012344 0ustar NOTE: This tutorial is completely outdated and needs a major overhaul. I still leave it in because it provides some additional info, but don't expect to be able to learn anything from it... The tutorial is in order of how I would want to learn to use this tool. very briefly, here's an index: 1. Introduction, how/why one would want to use this tool. 2. Spawn, expect- how to talk to a process. 3. Debugging. 4. Interacting with a spawned process. 5. Monkeying with tty settings. Good for grabbing passwords, among other things. 6. Miscellaneous extra functions. Let me know if there's something you'd like to see that isn't here. Expect-1.36/tutorial/1.A.Intro0000755000175000017500000000457414566144303013035 0ustar Why is this tool useful? Chances are if you are reading this you probably have already used the fine Expect for tcl, and possibly even read Exploring Expect. You are interested in learning how to accomplish the same things you've done in tcl using perl, or perhaps are just totally irritated at tcl. Expect is a generic tool for talking to processes that normally require user interaction. This might be running an ftp client to grab a file, telnetting to a router to grab statistics or reset an interface. Or, as in the case of a place I recently administered, to start up a secure webserver without having to be physically at the machine to enter the super secret password. Expect talks to processes through ptys. To it, a process is mostly just a bidirectional file handle, much the same as a socket. In fact, it is possible to take a filehandle you've already used and pass it off to expect to interact with. Now, something you might say at this point is "well, but there are tools that I can use to do that with for more common protocols like telnet and ftp already, such as Net::Ftp and Net::Telnet. Why would I want to use your tool?". This is true. You might never want to use it. However, there are a few advantages Expect has over similar modules: 1. A consistent interface. You don't have to remember the syntax for the other tools. 2. It is more intuitive (my opinion, of course) because you already know how to use the clients you are familiar with. Once you learn how to talk to a process using Expect you will have an easy time automating your other tasks. 3. It is more versatile. With Expect you can connect multiple processes together, write to log files, talk to sockets, etc. 4. Consistent debugging. Debugging, IMHO, is much easier in Expect than in other tools because you have the ability to watch the interaction take place, and it's really pretty easy to use. One serious disadvantage of Expect is that scripts generated using it are generally non-portable. The way a client 'looks' is important to building a script to talk to it. Interacting with a client on DG-UX may be very different than the equivalent client on SunOS. Or, and ncftp would be a good example of this, a client may be different between versions. Similarly, if an administrator changes versions of a server it might send back different prompts than what you are looking for. These are things you should be aware of. Expect-1.36/README.md0000755000175000017500000000363014566144303011105 0ustar [![Build Status](https://travis-ci.org/jacoby/expect.pm.png)](https://travis-ci.org/jacoby/expect.pm) Expect.pm ========= Expect requires the latest version of IO::Tty, also available from CPAN. IO::Stty has become optional but I'd suggest you also install it. If you use the highly recommended CPAN module, there is a Bundle::Expect available that installs everything for you. If you prefer manual installation, the usual perl Makefile.PL make make test make install should work. Note that IO::Tty is very system-dependend. It has been extensively reworked and tested, but there still may be systems that have problems. Please be sure to read the FAQ section in the Expect pod manpage, especially the section about using Expect to control telnet/ssh etc. There are other ways to work around password entry, you definitely don't need Expect for ssh automatisation! The Perl Expect module was inspired more by the functionality of Tcl/Expect than any previous Expect-like tool such as Comm.pl or chat2.pl. The Tcl version of Expect is a creation of Don Libes (libes@nist.gov) and can be found at http://expect.nist.gov/. Don has written an excellent in-depth tutorial of Tcl/Expect, which is _Exploring Expect_. It is the O'Reilly book with the monkey on the front. Don has several references to other articles on the Expect web page. I try to stay as close to Tcl/Expect in interface and semantics as possible (so I can refer questions to the Tcl/Expect docu). Suggestions for improvement are always welcome. There are two mailing lists available, expectperl-announce and expectperl-discuss, at http://lists.sourceforge.net/lists/listinfo/expectperl-announce and http://lists.sourceforge.net/lists/listinfo/expectperl-discuss Thanks to everybody who wrote to me, either with bug reports, enhancement suggestions or especially fixes! Dave Jacoby (maintaner of Expect.pm) jacoby@cpan.org 2015-10-31 Expect-1.36/Makefile.PL0000755000175000017500000000346614566144303011607 0ustar use strict; use warnings; use ExtUtils::MakeMaker; my %conf = ( NAME => 'Expect', VERSION_FROM => 'lib/Expect.pm', PREREQ_PM => { 'IO::Tty' => 1.11, 'IO::Pty' => 1.11, # standard modules: 'POSIX' => 0, 'Fcntl' => 0, 'Carp' => 0, 'IO::Handle' => 0, 'Exporter' => 0, 'Errno' => 0, }, AUTHOR => [ 'Austin Schutz ', 'Roland Giersig ', 'Dave Jacoby ', ], ABSTRACT_FROM => 'lib/Expect.pm', MIN_PERL_VERSION => '5.006000', clean => { 'FILES' => '*.log Expect-*' }, dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz' }, ); if (eval { ExtUtils::MakeMaker->VERSION(6.3002) }) { $conf{LICENSE} = 'perl'; } if (eval { ExtUtils::MakeMaker->VERSION(6.46) }) { $conf{META_MERGE} = { 'meta-spec' => { version => 2 }, resources => { repository => { type => 'git', url => 'http://github.com/jacoby/expect.pm.git', web => 'http://github.com/jacoby/expect.pm', } } }; } my %configure_requires = ( 'ExtUtils::MakeMaker' => '6.64', ); my %build_requires = (); my %test_requires = ( 'Test::More' => '1.00', # standard modules: 'File::Temp' => 0, ); ### merging data "standard code" if (eval { ExtUtils::MakeMaker->VERSION(6.52) }) { $conf{CONFIGURE_REQUIRES} = \%configure_requires; } else { %{ $conf{PREREQ_PM} } = (%{ $conf{PREREQ_PM} }, %configure_requires); } if (eval { ExtUtils::MakeMaker->VERSION(6.5503) }) { $conf{BUILD_REQUIRES} = \%build_requires; } else { %{ $conf{PREREQ_PM} } = (%{ $conf{PREREQ_PM} }, %build_requires); } if (eval { ExtUtils::MakeMaker->VERSION(6.64) }) { $conf{TEST_REQUIRES} = \%test_requires; } else { %{ $conf{PREREQ_PM} } = (%{ $conf{PREREQ_PM} }, %test_requires); } WriteMakefile(%conf); Expect-1.36/lib/0000755000175000017500000000000014566210226010365 5ustar Expect-1.36/lib/Expect.pm0000755000175000017500000030547514566210167012200 0ustar # -*-cperl-*- # This module is copyrighted as per the usual perl legalese: # Copyright (c) 1997 Austin Schutz. # expect() interface & functionality enhancements (c) 1999 Roland Giersig. # # All rights reserved. This program is free software; you can # redistribute it and/or modify it under the same terms as Perl # itself. # # Don't blame/flame me if you bust your stuff. # Austin Schutz # # This module now is maintained by # Dave Jacoby # use 5.006; package Expect; use strict; use warnings; use IO::Pty 1.11; # We need make_slave_controlling_terminal() use IO::Tty; use POSIX qw(:sys_wait_h :unistd_h); # For WNOHANG and isatty use Fcntl qw(:DEFAULT); # For checking file handle settings. use Carp qw(cluck croak carp confess); use IO::Handle (); use Exporter qw(import); use Errno; use Scalar::Util qw/ looks_like_number /; # This is necessary to make routines within Expect work. @Expect::ISA = qw(IO::Pty); @Expect::EXPORT = qw(expect exp_continue exp_continue_timeout); BEGIN { $Expect::VERSION = '1.36'; # These are defaults which may be changed per object, or set as # the user wishes. # This will be unset, since the default behavior differs between # spawned processes and initialized filehandles. # $Expect::Log_Stdout = 1; $Expect::Log_Group = 1; $Expect::Debug = 0; $Expect::Exp_Max_Accum = 0; # unlimited $Expect::Exp_Internal = 0; $Expect::IgnoreEintr = 0; $Expect::Manual_Stty = 0; $Expect::Multiline_Matching = 1; $Expect::Do_Soft_Close = 0; @Expect::Before_List = (); @Expect::After_List = (); %Expect::Spawned_PIDs = (); } sub version { my ($version) = @_; warn "Version $version is later than $Expect::VERSION. It may not be supported" if ( defined($version) && ( $version > $Expect::VERSION ) ); die "Versions before 1.03 are not supported in this release" if ( ( defined($version) ) && ( $version < 1.03 ) ); return $Expect::VERSION; } sub new { my ($class, @args) = @_; $class = ref($class) if ref($class); # so we can be called as $exp->new() # Create the pty which we will use to pass process info. my ($self) = IO::Pty->new; die "$class: Could not assign a pty" unless $self; bless $self => $class; $self->autoflush(1); # This is defined here since the default is different for # initialized handles as opposed to spawned processes. ${*$self}{exp_Log_Stdout} = 1; $self->_init_vars(); if (@args) { # we got add'l parms, so pass them to spawn return $self->spawn(@args); } return $self; } sub timeout { my $self = shift; ${*$self}{expect_timeout} = shift if @_; return ${*$self}{expect_timeout}; } sub spawn { my ($class, @cmd) = @_; # spawn is passed command line args. my $self; if ( ref($class) ) { $self = $class; } else { $self = $class->new(); } croak "Cannot reuse an object with an already spawned command" if exists ${*$self}{"exp_Command"}; ${*$self}{"exp_Command"} = \@cmd; # set up pipe to detect childs exec error pipe( FROM_CHILD, TO_PARENT ) or die "Cannot open pipe: $!"; pipe( FROM_PARENT, TO_CHILD ) or die "Cannot open pipe: $!"; TO_PARENT->autoflush(1); TO_CHILD->autoflush(1); eval { fcntl( TO_PARENT, Fcntl::F_SETFD, Fcntl::FD_CLOEXEC ); }; my $pid = fork; unless ( defined($pid) ) { warn "Cannot fork: $!" if $^W; return; } if ($pid) { # parent my $errno; ${*$self}{exp_Pid} = $pid; close TO_PARENT; close FROM_PARENT; $self->close_slave(); $self->set_raw() if $self->raw_pty and isatty($self); close TO_CHILD; # so child gets EOF and can go ahead # now wait for child exec (eof due to close-on-exit) or exec error my $errstatus = sysread( FROM_CHILD, $errno, 256 ); die "Cannot sync with child: $!" if not defined $errstatus; close FROM_CHILD; if ($errstatus) { $! = $errno + 0; warn "Cannot exec(@cmd): $!\n" if $^W; return; } } else { # child close FROM_CHILD; close TO_CHILD; $self->make_slave_controlling_terminal(); my $slv = $self->slave() or die "Cannot get slave: $!"; $slv->set_raw() if $self->raw_pty; close($self); # wait for parent before we detach my $buffer; my $errstatus = sysread( FROM_PARENT, $buffer, 256 ); die "Cannot sync with parent: $!" if not defined $errstatus; close FROM_PARENT; close(STDIN); open( STDIN, "<&" . $slv->fileno() ) or die "Couldn't reopen STDIN for reading, $!\n"; close(STDOUT); open( STDOUT, ">&" . $slv->fileno() ) or die "Couldn't reopen STDOUT for writing, $!\n"; close(STDERR); open( STDERR, ">&" . $slv->fileno() ) or die "Couldn't reopen STDERR for writing, $!\n"; { exec(@cmd) }; print TO_PARENT $! + 0; die "Cannot exec(@cmd): $!\n"; } # This is sort of for code compatibility, and to make debugging a little # easier. By code compatibility I mean that previously the process's # handle was referenced by $process{Pty_Handle} instead of just $process. # This is almost like 'naming' the handle to the process. # I think this also reflects Tcl Expect-like behavior. ${*$self}{exp_Pty_Handle} = "spawn id(" . $self->fileno() . ")"; if ( ( ${*$self}{"exp_Debug"} ) or ( ${*$self}{"exp_Exp_Internal"} ) ) { cluck( "Spawned '@cmd'\r\n", "\t${*$self}{exp_Pty_Handle}\r\n", "\tPid: ${*$self}{exp_Pid}\r\n", "\tTty: " . $self->SUPER::ttyname() . "\r\n", ); } $Expect::Spawned_PIDs{ ${*$self}{exp_Pid} } = undef; return $self; } sub exp_init { my ($class, $self) = @_; # take a filehandle, for use later with expect() or interconnect() . # All the functions are written for reading from a tty, so if the naming # scheme looks odd, that's why. bless $self, $class; croak "exp_init not passed a file object, stopped" unless defined( $self->fileno() ); $self->autoflush(1); # Define standard variables.. debug states, etc. $self->_init_vars(); # Turn of logging. By default we don't want crap from a file to get spewed # on screen as we read it. ${*$self}{exp_Log_Stdout} = 0; ${*$self}{exp_Pty_Handle} = "handle id(" . $self->fileno() . ")"; ${*$self}{exp_Pty_Handle} = "STDIN" if $self->fileno() == fileno(STDIN); print STDERR "Initialized ${*$self}{exp_Pty_Handle}.'\r\n" if ${*$self}{"exp_Debug"}; return $self; } # make an alias *init = \&exp_init; ###################################################################### # We're happy OOP people. No direct access to stuff. # For standard read-writeable parameters, we define some autoload magic... my %Writeable_Vars = ( debug => 'exp_Debug', exp_internal => 'exp_Exp_Internal', do_soft_close => 'exp_Do_Soft_Close', max_accum => 'exp_Max_Accum', match_max => 'exp_Max_Accum', notransfer => 'exp_NoTransfer', log_stdout => 'exp_Log_Stdout', log_user => 'exp_Log_Stdout', log_group => 'exp_Log_Group', manual_stty => 'exp_Manual_Stty', restart_timeout_upon_receive => 'exp_Continue', raw_pty => 'exp_Raw_Pty', ); my %Readable_Vars = ( pid => 'exp_Pid', exp_pid => 'exp_Pid', exp_match_number => 'exp_Match_Number', match_number => 'exp_Match_Number', exp_error => 'exp_Error', error => 'exp_Error', exp_command => 'exp_Command', command => 'exp_Command', exp_match => 'exp_Match', match => 'exp_Match', exp_matchlist => 'exp_Matchlist', matchlist => 'exp_Matchlist', exp_before => 'exp_Before', before => 'exp_Before', exp_after => 'exp_After', after => 'exp_After', exp_exitstatus => 'exp_Exit', exitstatus => 'exp_Exit', exp_pty_handle => 'exp_Pty_Handle', pty_handle => 'exp_Pty_Handle', exp_logfile => 'exp_Log_File', logfile => 'exp_Log_File', %Writeable_Vars, ); sub AUTOLOAD { my ($self, @args) = @_; my $type = ref($self) or croak "$self is not an object"; use vars qw($AUTOLOAD); my $name = $AUTOLOAD; $name =~ s/.*:://; # strip fully-qualified portion unless ( exists $Readable_Vars{$name} ) { croak "ERROR: cannot find method `$name' in class $type"; } my $varname = $Readable_Vars{$name}; my $tmp; $tmp = ${*$self}{$varname} if exists ${*$self}{$varname}; if (@args) { if ( exists $Writeable_Vars{$name} ) { my $ref = ref($tmp); if ( $ref eq 'ARRAY' ) { ${*$self}{$varname} = [@args]; } elsif ( $ref eq 'HASH' ) { ${*$self}{$varname} = {@args}; } else { ${*$self}{$varname} = shift @args; } } else { carp "Trying to set read-only variable `$name'" if $^W; } } my $ref = ref($tmp); return ( wantarray ? @{$tmp} : $tmp ) if ( $ref eq 'ARRAY' ); return ( wantarray ? %{$tmp} : $tmp ) if ( $ref eq 'HASH' ); return $tmp; } ###################################################################### sub set_seq { my ( $self, $escape_sequence, $function, $params, @args ) = @_; # Set an escape sequence/function combo for a read handle for interconnect. # Ex: $read_handle->set_seq('',\&function,\@parameters); ${ ${*$self}{exp_Function} }{$escape_sequence} = $function; if ( ( !defined($function) ) || ( $function eq 'undef' ) ) { ${ ${*$self}{exp_Function} }{$escape_sequence} = \&_undef; } ${ ${*$self}{exp_Parameters} }{$escape_sequence} = $params; # This'll be a joy to execute. :) if ( ${*$self}{"exp_Debug"} ) { print STDERR "Escape seq. '" . $escape_sequence; print STDERR "' function for ${*$self}{exp_Pty_Handle} set to '"; print STDERR ${ ${*$self}{exp_Function} }{$escape_sequence}; print STDERR "(" . join( ',', @args ) . ")'\r\n"; } } sub set_group { my ($self, @args) = @_; # Make sure we can read from the read handle if ( !defined( $args[0] ) ) { if ( defined( ${*$self}{exp_Listen_Group} ) ) { return @{ ${*$self}{exp_Listen_Group} }; } else { # Refrain from referencing an undef return; } } @{ ${*$self}{exp_Listen_Group} } = (); if ( $self->_get_mode() !~ 'r' ) { warn( "Attempting to set a handle group on ${*$self}{exp_Pty_Handle}, ", "a non-readable handle!\r\n" ); } while ( my $write_handle = shift @args ) { if ( $write_handle->_get_mode() !~ 'w' ) { warn( "Attempting to set a non-writeable listen handle ", "${*$write_handle}{exp_Pty_handle} for ", "${*$self}{exp_Pty_Handle}!\r\n" ); } push( @{ ${*$self}{exp_Listen_Group} }, $write_handle ); } } sub log_file { my ($self, $file, $mode) = @_; $mode ||= "a"; return ( ${*$self}{exp_Log_File} ) if @_ < 2; # we got no param, return filehandle # $e->log_file(undef) is an acceptable call hence we need to check the number of parameters here if ( ${*$self}{exp_Log_File} and ref( ${*$self}{exp_Log_File} ) ne 'CODE' ) { close( ${*$self}{exp_Log_File} ); } ${*$self}{exp_Log_File} = undef; return if ( not $file ); my $fh = $file; if ( not ref($file) ) { # it's a filename $fh = IO::File->new( $file, $mode ) or croak "Cannot open logfile $file: $!"; } if ( ref($file) ne 'CODE' ) { croak "Given logfile doesn't have a 'print' method" if not $fh->can("print"); $fh->autoflush(1); # so logfile is up to date } ${*$self}{exp_Log_File} = $fh; return $fh; } # I'm going to leave this here in case I might need to change something. # Previously this was calling `stty`, in a most bastardized manner. sub exp_stty { my ($self) = shift; my ($mode) = "@_"; return unless defined $mode; if ( not defined $INC{"IO/Stty.pm"} ) { carp "IO::Stty not installed, cannot change mode"; return; } if ( ${*$self}{"exp_Debug"} ) { print STDERR "Setting ${*$self}{exp_Pty_Handle} to tty mode '$mode'\r\n"; } unless ( POSIX::isatty($self) ) { if ( ${*$self}{"exp_Debug"} or $^W ) { warn "${*$self}{exp_Pty_Handle} is not a tty. Not changing mode"; } return ''; # No undef to avoid warnings elsewhere. } IO::Stty::stty( $self, split( /\s/, $mode ) ); } *stty = \&exp_stty; # If we want to clear the buffer. Otherwise Accum will grow during send_slow # etc. and contain the remainder after matches. sub clear_accum { my ($self) = @_; return $self->set_accum(''); } sub set_accum { my ($self, $accum) = @_; my $old_accum = ${*$self}{exp_Accum}; ${*$self}{exp_Accum} = $accum; # return the contents of the accumulator. return $old_accum; } sub get_accum { my ($self) = @_; return ${*$self}{exp_Accum}; } ###################################################################### # define constants for pattern subs sub exp_continue {"exp_continue"} sub exp_continue_timeout {"exp_continue_timeout"} ###################################################################### # Expect on multiple objects at once. # # Call as Expect::expect($timeout, -i => \@exp_list, @patternlist, # -i => $exp, @pattern_list, ...); # or $exp->expect($timeout, @patternlist, -i => \@exp_list, @patternlist, # -i => $exp, @pattern_list, ...); # # Patterns are arrays that consist of # [ $pattern_type, $pattern, $sub, @subparms ] # # Optional $pattern_type is '-re' (RegExp, default) or '-ex' (exact); # # $sub is optional CODE ref, which is called as &{$sub}($exp, @subparms) # if pattern matched; may return exp_continue or exp_continue_timeout. # # Old-style syntax (pure pattern strings with optional type) also supported. # sub expect { my $self; print STDERR ("expect(@_) called...\n") if $Expect::Debug; if ( defined( $_[0] ) ) { if ( ref( $_[0] ) and $_[0]->isa('Expect') ) { $self = shift; } elsif ( $_[0] eq 'Expect' ) { shift; # or as Expect->expect } } croak "expect(): not enough arguments, should be expect(timeout, [patterns...])" if @_ < 1; my $timeout = looks_like_number($_[0]) ? shift : $self->timeout; my $timeout_hook = undef; my @object_list; my %patterns; my @pattern_list; my @timeout_list; my $curr_list; if ($self) { $curr_list = [$self]; } else { # called directly, so first parameter must be '-i' to establish # object list. $curr_list = []; croak "expect(): ERROR: if called directly (not as \$obj->expect(...), but as Expect::expect(...), first parameter MUST be '-i' to set an object (list) for the patterns to work on." if ( $_[0] ne '-i' ); } # Let's make a list of patterns wanting to be evaled as regexps. my $parm; my $parm_nr = 1; while ( defined( $parm = shift ) ) { print STDERR ("expect(): handling param '$parm'...\n") if $Expect::Debug; if ( ref($parm) ) { if ( ref($parm) eq 'Regexp' ) { push @pattern_list, [ $parm_nr, '-re', $parm, undef ]; } elsif ( ref($parm) eq 'ARRAY' ) { my $err = _add_patterns_to_list( \@pattern_list, \@timeout_list, $parm_nr, $parm ); carp( "expect(): Warning: multiple `timeout' patterns (", scalar(@timeout_list), ").\r\n" ) if @timeout_list > 1; $timeout_hook = $timeout_list[-1] if $timeout_list[-1]; croak $err if $err; $parm_nr++; } else { croak("expect(): Unknown pattern ref $parm"); } } else { # not a ref, is an option or raw pattern if ( substr( $parm, 0, 1 ) eq '-' ) { # it's an option print STDERR ("expect(): handling option '$parm'...\n") if $Expect::Debug; if ( $parm eq '-i' ) { # first add collected patterns to object list if ( scalar(@$curr_list) ) { push @object_list, $curr_list if not exists $patterns{"$curr_list"}; push @{ $patterns{"$curr_list"} }, @pattern_list; @pattern_list = (); } # now put parm(s) into current object list if ( ref( $_[0] ) eq 'ARRAY' ) { $curr_list = shift; } else { $curr_list = [shift]; } } elsif ( $parm eq '-re' or $parm eq '-ex' ) { if ( ref( $_[1] ) eq 'CODE' ) { push @pattern_list, [ $parm_nr, $parm, shift, shift ]; } else { push @pattern_list, [ $parm_nr, $parm, shift, undef ]; } $parm_nr++; } else { croak("Unknown option $parm"); } } else { # a plain pattern, check if it is followed by a CODE ref if ( ref( $_[0] ) eq 'CODE' ) { if ( $parm eq 'timeout' ) { push @timeout_list, shift; carp( "expect(): Warning: multiple `timeout' patterns (", scalar(@timeout_list), ").\r\n" ) if @timeout_list > 1; $timeout_hook = $timeout_list[-1] if $timeout_list[-1]; } elsif ( $parm eq 'eof' ) { push @pattern_list, [ $parm_nr, "-$parm", undef, shift ]; } else { push @pattern_list, [ $parm_nr, '-ex', $parm, shift ]; } } else { print STDERR ("expect(): exact match '$parm'...\n") if $Expect::Debug; push @pattern_list, [ $parm_nr, '-ex', $parm, undef ]; } $parm_nr++; } } } # add rest of collected patterns to object list carp "expect(): Empty object list" unless $curr_list; push @object_list, $curr_list if not exists $patterns{"$curr_list"}; push @{ $patterns{"$curr_list"} }, @pattern_list; my $debug = $self ? ${*$self}{exp_Debug} : $Expect::Debug; my $internal = $self ? ${*$self}{exp_Exp_Internal} : $Expect::Exp_Internal; # now start matching... if (@Expect::Before_List) { print STDERR ("Starting BEFORE pattern matching...\r\n") if ( $debug or $internal ); _multi_expect( 0, undef, @Expect::Before_List ); } cluck("Starting EXPECT pattern matching...\r\n") if ( $debug or $internal ); my @ret; @ret = _multi_expect( $timeout, $timeout_hook, map { [ $_, @{ $patterns{"$_"} } ] } @object_list ); if (@Expect::After_List) { print STDERR ("Starting AFTER pattern matching...\r\n") if ( $debug or $internal ); _multi_expect( 0, undef, @Expect::After_List ); } return wantarray ? @ret : $ret[0]; } ###################################################################### # the real workhorse # sub _multi_expect { my ($timeout, $timeout_hook, @params) = @_; if ($timeout_hook) { croak "Unknown timeout_hook type $timeout_hook" unless ( ref($timeout_hook) eq 'CODE' or ref($timeout_hook) eq 'ARRAY' ); } foreach my $pat (@params) { my @patterns = @{$pat}[ 1 .. $#{$pat} ]; foreach my $exp ( @{ $pat->[0] } ) { ${*$exp}{exp_New_Data} = 1; # first round we always try to match if ( exists ${*$exp}{"exp_Max_Accum"} and ${*$exp}{"exp_Max_Accum"} ) { ${*$exp}{exp_Accum} = $exp->_trim_length( ${*$exp}{exp_Accum}, ${*$exp}{exp_Max_Accum} ); } print STDERR ( "${*$exp}{exp_Pty_Handle}: beginning expect.\r\n", "\tTimeout: ", ( defined($timeout) ? $timeout : "unlimited" ), " seconds.\r\n", "\tCurrent time: " . localtime() . "\r\n", ) if $Expect::Debug; # What are we expecting? What do you expect? :-) if ( ${*$exp}{exp_Exp_Internal} ) { print STDERR "${*$exp}{exp_Pty_Handle}: list of patterns:\r\n"; foreach my $pattern (@patterns) { print STDERR ( ' ', defined( $pattern->[0] ) ? '#' . $pattern->[0] . ': ' : '', $pattern->[1], " `", _make_readable( $pattern->[2] ), "'\r\n" ); } print STDERR "\r\n"; } } } my $successful_pattern; my $exp_matched; my $err; my $before; my $after; my $match; my @matchlist; # Set the last loop time to now for time comparisons at end of loop. my $start_loop_time = time(); my $exp_cont = 1; READLOOP: while ($exp_cont) { $exp_cont = 1; $err = ""; my $rmask = ''; my $time_left = undef; if ( defined $timeout ) { $time_left = $timeout - ( time() - $start_loop_time ); $time_left = 0 if $time_left < 0; } $exp_matched = undef; # Test for a match first so we can test the current Accum w/out # worrying about an EOF. foreach my $pat (@params) { my @patterns = @{$pat}[ 1 .. $#{$pat} ]; foreach my $exp ( @{ $pat->[0] } ) { # build mask for select in next section... my $fn = $exp->fileno(); vec( $rmask, $fn, 1 ) = 1 if defined $fn; next unless ${*$exp}{exp_New_Data}; # clear error status ${*$exp}{exp_Error} = undef; ${*$exp}{exp_After} = undef; ${*$exp}{exp_Match_Number} = undef; ${*$exp}{exp_Match} = undef; # This could be huge. We should attempt to do something # about this. Because the output is used for debugging # I'm of the opinion that showing smaller amounts if the # total is huge should be ok. # Thus the 'trim_length' print STDERR ( "\r\n${*$exp}{exp_Pty_Handle}: Does `", $exp->_trim_length( _make_readable( ${*$exp}{exp_Accum} ) ), "'\r\nmatch:\r\n" ) if ${*$exp}{exp_Exp_Internal}; # we don't keep the parameter number anymore # (clashes with before & after), instead the parameter number is # stored inside the pattern; we keep the pattern ref # and look up the number later. foreach my $pattern (@patterns) { print STDERR ( " pattern", defined( $pattern->[0] ) ? ' #' . $pattern->[0] : '', ": ", $pattern->[1], " `", _make_readable( $pattern->[2] ), "'? " ) if ( ${*$exp}{exp_Exp_Internal} ); # Matching exactly if ( $pattern->[1] eq '-ex' ) { my $match_index = index( ${*$exp}{exp_Accum}, $pattern->[2] ); # We matched if $match_index > -1 if ( $match_index > -1 ) { $before = substr( ${*$exp}{exp_Accum}, 0, $match_index ); $match = substr( ${*$exp}{exp_Accum}, $match_index, length( $pattern->[2] ) ); $after = substr( ${*$exp}{exp_Accum}, $match_index + length( $pattern->[2] ) ); ${*$exp}{exp_Before} = $before; ${*$exp}{exp_Match} = $match; ${*$exp}{exp_After} = $after; ${*$exp}{exp_Match_Number} = $pattern->[0]; $exp_matched = $exp; } } elsif ( $pattern->[1] eq '-re' ) { if ($Expect::Multiline_Matching) { @matchlist = ( ${*$exp}{exp_Accum} =~ m/($pattern->[2])/m); } else { @matchlist = ( ${*$exp}{exp_Accum} =~ m/($pattern->[2])/); } if (@matchlist) { # Matching regexp $match = shift @matchlist; my $start = index ${*$exp}{exp_Accum}, $match; die 'The match could not be found' if $start == -1; $before = substr ${*$exp}{exp_Accum}, 0, $start; $after = substr ${*$exp}{exp_Accum}, $start + length($match); ${*$exp}{exp_Before} = $before; ${*$exp}{exp_Match} = $match; ${*$exp}{exp_After} = $after; #pop @matchlist; # remove kludged empty bracket from end @{ ${*$exp}{exp_Matchlist} } = @matchlist; ${*$exp}{exp_Match_Number} = $pattern->[0]; $exp_matched = $exp; } } else { # 'timeout' or 'eof' } if ($exp_matched) { ${*$exp}{exp_Accum} = $after unless ${*$exp}{exp_NoTransfer}; print STDERR "YES!!\r\n" if ${*$exp}{exp_Exp_Internal}; print STDERR ( " Before match string: `", $exp->_trim_length( _make_readable( ($before) ) ), "'\r\n", " Match string: `", _make_readable($match), "'\r\n", " After match string: `", $exp->_trim_length( _make_readable( ($after) ) ), "'\r\n", " Matchlist: (", join( ", ", map { "`" . $exp->_trim_length( _make_readable( ($_) ) ) . "'" } @matchlist, ), ")\r\n", ) if ( ${*$exp}{exp_Exp_Internal} ); # call hook function if defined if ( $pattern->[3] ) { print STDERR ( "Calling hook $pattern->[3]...\r\n", ) if ( ${*$exp}{exp_Exp_Internal} or $Expect::Debug ); if ( $#{$pattern} > 3 ) { # call with parameters if given $exp_cont = &{ $pattern->[3] }( $exp, @{$pattern}[ 4 .. $#{$pattern} ] ); } else { $exp_cont = &{ $pattern->[3] }($exp); } } if ( $exp_cont and $exp_cont eq exp_continue ) { print STDERR ("Continuing expect, restarting timeout...\r\n") if ( ${*$exp}{exp_Exp_Internal} or $Expect::Debug ); $start_loop_time = time(); # restart timeout count next READLOOP; } elsif ( $exp_cont and $exp_cont eq exp_continue_timeout ) { print STDERR ("Continuing expect...\r\n") if ( ${*$exp}{exp_Exp_Internal} or $Expect::Debug ); next READLOOP; } last READLOOP; } print STDERR "No.\r\n" if ${*$exp}{exp_Exp_Internal}; } print STDERR "\r\n" if ${*$exp}{exp_Exp_Internal}; # don't have to match again until we get new data ${*$exp}{exp_New_Data} = 0; } } # End of matching section # No match, let's see what is pending on the filehandles... print STDERR ( "Waiting for new data (", defined($time_left) ? $time_left : 'unlimited', " seconds)...\r\n", ) if ( $Expect::Exp_Internal or $Expect::Debug ); my $nfound; SELECT: { $nfound = select( $rmask, undef, undef, $time_left ); if ( $nfound < 0 ) { if ( $!{EINTR} and $Expect::IgnoreEintr ) { print STDERR ("ignoring EINTR, restarting select()...\r\n") if ( $Expect::Exp_Internal or $Expect::Debug ); next SELECT; } print STDERR ("select() returned error code '$!'\r\n") if ( $Expect::Exp_Internal or $Expect::Debug ); # returned error $err = "4:$!"; last READLOOP; } } # go until we don't find something (== timeout). if ( $nfound == 0 ) { # No pattern, no EOF. Did we time out? $err = "1:TIMEOUT"; foreach my $pat (@params) { foreach my $exp ( @{ $pat->[0] } ) { $before = ${*$exp}{exp_Before} = ${*$exp}{exp_Accum}; next if not defined $exp->fileno(); # skip already closed ${*$exp}{exp_Error} = $err unless ${*$exp}{exp_Error}; } } print STDERR ("TIMEOUT\r\n") if ( $Expect::Debug or $Expect::Exp_Internal ); if ($timeout_hook) { my $ret; print STDERR ("Calling timeout function $timeout_hook...\r\n") if ( $Expect::Debug or $Expect::Exp_Internal ); if ( ref($timeout_hook) eq 'CODE' ) { $ret = &{$timeout_hook}( $params[0]->[0] ); } else { if ( $#{$timeout_hook} > 3 ) { $ret = &{ $timeout_hook->[3] }( $params[0]->[0], @{$timeout_hook}[ 4 .. $#{$timeout_hook} ] ); } else { $ret = &{ $timeout_hook->[3] }( $params[0]->[0] ); } } if ( $ret and $ret eq exp_continue ) { $start_loop_time = time(); # restart timeout count next READLOOP; } } last READLOOP; } my @bits = split( //, unpack( 'b*', $rmask ) ); foreach my $pat (@params) { foreach my $exp ( @{ $pat->[0] } ) { next if not defined $exp->fileno(); # skip already closed if ( $bits[ $exp->fileno() ] ) { print STDERR ("${*$exp}{exp_Pty_Handle}: new data.\r\n") if $Expect::Debug; # read in what we found. my $buffer; my $nread = sysread( $exp, $buffer, 2048 ); # Make errors (nread undef) show up as EOF. $nread = 0 unless defined($nread); if ( $nread == 0 ) { print STDERR ("${*$exp}{exp_Pty_Handle}: EOF\r\n") if ($Expect::Debug); $before = ${*$exp}{exp_Before} = $exp->clear_accum(); $err = "2:EOF"; ${*$exp}{exp_Error} = $err; ${*$exp}{exp_Has_EOF} = 1; $exp_cont = undef; foreach my $eof_pat ( grep { $_->[1] eq '-eof' } @{$pat}[ 1 .. $#{$pat} ] ) { my $ret; print STDERR ( "Calling EOF hook $eof_pat->[3]...\r\n", ) if ($Expect::Debug); if ( $#{$eof_pat} > 3 ) { # call with parameters if given $ret = &{ $eof_pat->[3] }( $exp, @{$eof_pat}[ 4 .. $#{$eof_pat} ] ); } else { $ret = &{ $eof_pat->[3] }($exp); } if ($ret and ( $ret eq exp_continue or $ret eq exp_continue_timeout ) ) { $exp_cont = $ret; } } # is it dead? if ( defined( ${*$exp}{exp_Pid} ) ) { my $ret = waitpid( ${*$exp}{exp_Pid}, POSIX::WNOHANG ); if ( $ret == ${*$exp}{exp_Pid} ) { printf STDERR ( "%s: exit(0x%02X)\r\n", ${*$exp}{exp_Pty_Handle}, $? ) if ($Expect::Debug); $err = "3:Child PID ${*$exp}{exp_Pid} exited with status $?"; ${*$exp}{exp_Error} = $err; ${*$exp}{exp_Exit} = $?; delete $Expect::Spawned_PIDs{ ${*$exp}{exp_Pid} }; ${*$exp}{exp_Pid} = undef; } } print STDERR ("${*$exp}{exp_Pty_Handle}: closing...\r\n") if ($Expect::Debug); $exp->hard_close(); next; } print STDERR ("${*$exp}{exp_Pty_Handle}: read $nread byte(s).\r\n") if ($Expect::Debug); # ugly hack for broken solaris ttys that spew # into our pretty output $buffer =~ s/ \cH//g if not ${*$exp}{exp_Raw_Pty}; # Append it to the accumulator. ${*$exp}{exp_Accum} .= $buffer; if ( exists ${*$exp}{exp_Max_Accum} and ${*$exp}{exp_Max_Accum} ) { ${*$exp}{exp_Accum} = $exp->_trim_length( ${*$exp}{exp_Accum}, ${*$exp}{exp_Max_Accum} ); } ${*$exp}{exp_New_Data} = 1; # next round we try to match again $exp_cont = exp_continue if ( exists ${*$exp}{exp_Continue} and ${*$exp}{exp_Continue} ); # Now propagate what we have read to other listeners... $exp->_print_handles($buffer); # End handle reading section. } } } # end read loop $start_loop_time = time() # restart timeout count if ( $exp_cont and $exp_cont eq exp_continue ); } # End READLOOP # Post loop. Do we have anything? # Tell us status if ( $Expect::Debug or $Expect::Exp_Internal ) { if ($exp_matched) { print STDERR ( "Returning from expect ", ${*$exp_matched}{exp_Error} ? 'un' : '', "successfully.", ${*$exp_matched}{exp_Error} ? "\r\n Error: ${*$exp_matched}{exp_Error}." : '', "\r\n" ); } else { print STDERR ("Returning from expect with TIMEOUT or EOF\r\n"); } if ( $Expect::Debug and $exp_matched ) { print STDERR " ${*$exp_matched}{exp_Pty_Handle}: accumulator: `"; if ( ${*$exp_matched}{exp_Error} ) { print STDERR ( $exp_matched->_trim_length( _make_readable( ${*$exp_matched}{exp_Before} ) ), "'\r\n" ); } else { print STDERR ( $exp_matched->_trim_length( _make_readable( ${*$exp_matched}{exp_Accum} ) ), "'\r\n" ); } } } if ($exp_matched) { return wantarray ? ( ${*$exp_matched}{exp_Match_Number}, ${*$exp_matched}{exp_Error}, ${*$exp_matched}{exp_Match}, ${*$exp_matched}{exp_Before}, ${*$exp_matched}{exp_After}, $exp_matched, ) : ${*$exp_matched}{exp_Match_Number}; } return wantarray ? ( undef, $err, undef, $before, undef, undef ) : undef; } # Patterns are arrays that consist of # [ $pattern_type, $pattern, $sub, @subparms ] # optional $pattern_type is '-re' (RegExp, default) or '-ex' (exact); # $sub is optional CODE ref, which is called as &{$sub}($exp, @subparms) # if pattern matched; # the $parm_nr gets unshifted onto the array for reporting purposes. sub _add_patterns_to_list { my ($listref, $timeoutlistref,$store_parm_nr, @params) = @_; # $timeoutlistref gets timeout patterns my $parm_nr = $store_parm_nr || 1; foreach my $parm (@params) { if ( not ref($parm) eq 'ARRAY' ) { return "Parameter #$parm_nr is not an ARRAY ref."; } $parm = [@$parm]; # make copy if ( $parm->[0] =~ m/\A-/ ) { # it's an option if ( $parm->[0] ne '-re' and $parm->[0] ne '-ex' ) { return "Unknown option $parm->[0] in pattern #$parm_nr"; } } else { if ( $parm->[0] eq 'timeout' ) { if ( defined $timeoutlistref ) { splice @$parm, 0, 1, ( "-$parm->[0]", undef ); unshift @$parm, $store_parm_nr ? $parm_nr : undef; push @$timeoutlistref, $parm; } next; } elsif ( $parm->[0] eq 'eof' ) { splice @$parm, 0, 1, ( "-$parm->[0]", undef ); } else { unshift @$parm, '-re'; # defaults to RegExp } } if ( @$parm > 2 ) { if ( ref( $parm->[2] ) ne 'CODE' ) { croak( "Pattern #$parm_nr doesn't have a CODE reference", "after the pattern." ); } } else { push @$parm, undef; # make sure we have three elements } unshift @$parm, $store_parm_nr ? $parm_nr : undef; push @$listref, $parm; $parm_nr++; } return; } ###################################################################### # $process->interact([$in_handle],[$escape sequence]) # If you don't specify in_handle STDIN will be used. sub interact { my ($self, $infile, $escape_sequence) = @_; my $outfile; my @old_group = $self->set_group(); # If the handle is STDIN we'll # $infile->fileno == 0 should be stdin.. follow stdin rules. no strict 'subs'; # Allow bare word 'STDIN' unless ( defined($infile) ) { # We need a handle object Associated with STDIN. $infile = IO::File->new; $infile->IO::File::fdopen( STDIN, 'r' ); $outfile = IO::File->new; $outfile->IO::File::fdopen( STDOUT, 'w' ); } elsif ( fileno($infile) == fileno(STDIN) ) { # With STDIN we want output to go to stdout. $outfile = IO::File->new; $outfile->IO::File::fdopen( STDOUT, 'w' ); } else { undef($outfile); } # Here we assure ourselves we have an Expect object. my $in_object = Expect->exp_init($infile); if ( defined($outfile) ) { # as above.. we want output to go to stdout if we're given stdin. my $out_object = Expect->exp_init($outfile); $out_object->manual_stty(1); $self->set_group($out_object); } else { $self->set_group($in_object); } $in_object->set_group($self); $in_object->set_seq( $escape_sequence, undef ) if defined($escape_sequence); # interconnect normally sets stty -echo raw. Interact really sort # of implies we don't do that by default. If anyone wanted to they could # set it before calling interact, of use interconnect directly. my $old_manual_stty_val = $self->manual_stty(); $self->manual_stty(1); # I think this is right. Don't send stuff from in_obj to stdout by default. # in theory whatever 'self' is should echo what's going on. my $old_log_stdout_val = $self->log_stdout(); $self->log_stdout(0); $in_object->log_stdout(0); # Allow for the setting of an optional EOF escape function. # $in_object->set_seq('EOF',undef); # $self->set_seq('EOF',undef); Expect::interconnect( $self, $in_object ); $self->log_stdout($old_log_stdout_val); $self->set_group(@old_group); # If old_group was undef, make sure that occurs. This is a slight hack since # it modifies the value directly. # Normally an undef passed to set_group will return the current groups. # It is possible that it may be of worth to make it possible to undef # The current group without doing this. unless (@old_group) { @{ ${*$self}{exp_Listen_Group} } = (); } $self->manual_stty($old_manual_stty_val); return; } sub interconnect { my (@handles) = @_; # my ($handle)=(shift); call as Expect::interconnect($spawn1,$spawn2,...) my ( $nread ); my ( $rout, $emask, $eout ); my ( $escape_character_buffer ); my ( $read_mask, $temp_mask ) = ( '', '' ); # Get read/write handles foreach my $handle (@handles) { $temp_mask = ''; vec( $temp_mask, $handle->fileno(), 1 ) = 1; # Under Linux w/ 5.001 the next line comes up w/ 'Uninit var.'. # It appears to be impossible to make the warning go away. # doing something like $temp_mask='' unless defined ($temp_mask) # has no effect whatsoever. This may be a bug in 5.001. $read_mask = $read_mask | $temp_mask; } if ($Expect::Debug) { print STDERR "Read handles:\r\n"; foreach my $handle (@handles) { print STDERR "\tRead handle: "; print STDERR "'${*$handle}{exp_Pty_Handle}'\r\n"; print STDERR "\t\tListen Handles:"; foreach my $write_handle ( @{ ${*$handle}{exp_Listen_Group} } ) { print STDERR " '${*$write_handle}{exp_Pty_Handle}'"; } print STDERR ".\r\n"; } } # I think if we don't set raw/-echo here we may have trouble. We don't # want a bunch of echoing crap making all the handles jabber at each other. foreach my $handle (@handles) { unless ( ${*$handle}{"exp_Manual_Stty"} ) { # This is probably O/S specific. ${*$handle}{exp_Stored_Stty} = $handle->exp_stty('-g'); print STDERR "Setting tty for ${*$handle}{exp_Pty_Handle} to 'raw -echo'.\r\n" if ${*$handle}{"exp_Debug"}; $handle->exp_stty("raw -echo"); } foreach my $write_handle ( @{ ${*$handle}{exp_Listen_Group} } ) { unless ( ${*$write_handle}{"exp_Manual_Stty"} ) { ${*$write_handle}{exp_Stored_Stty} = $write_handle->exp_stty('-g'); print STDERR "Setting ${*$write_handle}{exp_Pty_Handle} to 'raw -echo'.\r\n" if ${*$handle}{"exp_Debug"}; $write_handle->exp_stty("raw -echo"); } } } print STDERR "Attempting interconnection\r\n" if $Expect::Debug; # Wait until the process dies or we get EOF # In the case of !${*$handle}{exp_Pid} it means # the handle was exp_inited instead of spawned. CONNECT_LOOP: # Go until we have a reason to stop while (1) { # test each handle to see if it's still alive. foreach my $read_handle (@handles) { waitpid( ${*$read_handle}{exp_Pid}, WNOHANG ) if ( exists( ${*$read_handle}{exp_Pid} ) and ${*$read_handle}{exp_Pid} ); if ( exists( ${*$read_handle}{exp_Pid} ) and ( ${*$read_handle}{exp_Pid} ) and ( !kill( 0, ${*$read_handle}{exp_Pid} ) ) ) { print STDERR "Got EOF (${*$read_handle}{exp_Pty_Handle} died) reading ${*$read_handle}{exp_Pty_Handle}\r\n" if ${*$read_handle}{"exp_Debug"}; last CONNECT_LOOP unless defined( ${ ${*$read_handle}{exp_Function} }{"EOF"} ); last CONNECT_LOOP unless &{ ${ ${*$read_handle}{exp_Function} }{"EOF"} } ( @{ ${ ${*$read_handle}{exp_Parameters} }{"EOF"} } ); } } # Every second? No, go until we get something from someone. my $nfound = select( $rout = $read_mask, undef, $eout = $emask, undef ); # Is there anything to share? May be -1 if interrupted by a signal... next CONNECT_LOOP if not defined $nfound or $nfound < 1; # Which handles have stuff? my @bits = split( //, unpack( 'b*', $rout ) ); $eout = 0 unless defined($eout); my @ebits = split( //, unpack( 'b*', $eout ) ); # print "Ebits: $eout\r\n"; foreach my $read_handle (@handles) { if ( $bits[ $read_handle->fileno() ] ) { $nread = sysread( $read_handle, ${*$read_handle}{exp_Pty_Buffer}, 1024 ); # Appease perl -w $nread = 0 unless defined($nread); print STDERR "interconnect: read $nread byte(s) from ${*$read_handle}{exp_Pty_Handle}.\r\n" if ${*$read_handle}{"exp_Debug"} > 1; # Test for escape seq. before printing. # Appease perl -w $escape_character_buffer = '' unless defined($escape_character_buffer); $escape_character_buffer .= ${*$read_handle}{exp_Pty_Buffer}; foreach my $escape_sequence ( keys( %{ ${*$read_handle}{exp_Function} } ) ) { print STDERR "Tested escape sequence $escape_sequence from ${*$read_handle}{exp_Pty_Handle}" if ${*$read_handle}{"exp_Debug"} > 1; # Make sure it doesn't grow out of bounds. $escape_character_buffer = $read_handle->_trim_length( $escape_character_buffer, ${*$read_handle}{"exp_Max_Accum"} ) if ( ${*$read_handle}{"exp_Max_Accum"} ); if ( $escape_character_buffer =~ /($escape_sequence)/ ) { my $match = $1; if ( ${*$read_handle}{"exp_Debug"} ) { print STDERR "\r\ninterconnect got escape sequence from ${*$read_handle}{exp_Pty_Handle}.\r\n"; # I'm going to make the esc. seq. pretty because it will # probably contain unprintable characters. print STDERR "\tEscape Sequence: '" . _trim_length( undef, _make_readable($escape_sequence) ) . "'\r\n"; print STDERR "\tMatched by string: '" . _trim_length( undef, _make_readable($match) ) . "'\r\n"; } # Print out stuff before the escape. # Keep in mind that the sequence may have been split up # over several reads. # Let's get rid of it from this read. If part of it was # in the last read there's not a lot we can do about it now. if ( ${*$read_handle}{exp_Pty_Buffer} =~ /([\w\W]*)($escape_sequence)/ ) { $read_handle->_print_handles($1); } else { $read_handle->_print_handles( ${*$read_handle}{exp_Pty_Buffer} ); } # Clear the buffer so no more matches can be made and it will # only be printed one time. ${*$read_handle}{exp_Pty_Buffer} = ''; $escape_character_buffer = ''; # Do the function here. Must return non-zero to continue. # More cool syntax. Maybe I should turn these in to objects. last CONNECT_LOOP unless &{ ${ ${*$read_handle}{exp_Function} }{$escape_sequence} } ( @{ ${ ${*$read_handle}{exp_Parameters} }{$escape_sequence} } ); } } $nread = 0 unless defined($nread); # Appease perl -w? waitpid( ${*$read_handle}{exp_Pid}, WNOHANG ) if ( defined( ${*$read_handle}{exp_Pid} ) && ${*$read_handle}{exp_Pid} ); if ( $nread == 0 ) { print STDERR "Got EOF reading ${*$read_handle}{exp_Pty_Handle}\r\n" if ${*$read_handle}{"exp_Debug"}; last CONNECT_LOOP unless defined( ${ ${*$read_handle}{exp_Function} }{"EOF"} ); last CONNECT_LOOP unless &{ ${ ${*$read_handle}{exp_Function} }{"EOF"} } ( @{ ${ ${*$read_handle}{exp_Parameters} }{"EOF"} } ); } last CONNECT_LOOP if ( $nread < 0 ); # This would be an error $read_handle->_print_handles( ${*$read_handle}{exp_Pty_Buffer} ); } # I'm removing this because I haven't determined what causes exceptions # consistently. if (0) #$ebits[$read_handle->fileno()]) { print STDERR "Got Exception reading ${*$read_handle}{exp_Pty_Handle}\r\n" if ${*$read_handle}{"exp_Debug"}; last CONNECT_LOOP unless defined( ${ ${*$read_handle}{exp_Function} }{"EOF"} ); last CONNECT_LOOP unless &{ ${ ${*$read_handle}{exp_Function} }{"EOF"} } ( @{ ${ ${*$read_handle}{exp_Parameters} }{"EOF"} } ); } } } foreach my $handle (@handles) { unless ( ${*$handle}{"exp_Manual_Stty"} ) { $handle->exp_stty( ${*$handle}{exp_Stored_Stty} ); } foreach my $write_handle ( @{ ${*$handle}{exp_Listen_Group} } ) { unless ( ${*$write_handle}{"exp_Manual_Stty"} ) { $write_handle->exp_stty( ${*$write_handle}{exp_Stored_Stty} ); } } } return; } # user can decide if log output gets also sent to logfile sub print_log_file { my ($self, @params) = @_; if ( ${*$self}{exp_Log_File} ) { if ( ref( ${*$self}{exp_Log_File} ) eq 'CODE' ) { ${*$self}{exp_Log_File}->(@params); } else { ${*$self}{exp_Log_File}->print(@params); } } return; } # we provide our own print so we can debug what gets sent to the # processes... sub print { my ( $self, @args ) = @_; return if not defined $self->fileno(); # skip if closed if ( ${*$self}{exp_Exp_Internal} ) { my $args = _make_readable( join( '', @args ) ); cluck "Sending '$args' to ${*$self}{exp_Pty_Handle}\r\n"; } foreach my $arg (@args) { while ( length($arg) > 80 ) { $self->SUPER::print( substr( $arg, 0, 80 ) ); $arg = substr( $arg, 80 ); } $self->SUPER::print($arg); } return; } # make an alias for Tcl/Expect users for a DWIM experience... *send = \&print; # This is an Expect standard. It's nice for talking to modems and the like # where from time to time they get unhappy if you send items too quickly. sub send_slow { my ($self, $sleep_time, @chunks) = @_; return if not defined $self->fileno(); # skip if closed # Flushing makes it so each character can be seen separately. my $chunk; while ( $chunk = shift @chunks ) { my @linechars = split( '', $chunk ); foreach my $char (@linechars) { # How slow? select( undef, undef, undef, $sleep_time ); print $self $char; print STDERR "Printed character \'" . _make_readable($char) . "\' to ${*$self}{exp_Pty_Handle}.\r\n" if ${*$self}{"exp_Debug"} > 1; # I think I can get away with this if I save it in accum if ( ${*$self}{"exp_Log_Stdout"} || ${*$self}{exp_Log_Group} ) { my $rmask = ""; vec( $rmask, $self->fileno(), 1 ) = 1; # .01 sec granularity should work. If we miss something it will # probably get flushed later, maybe in an expect call. while ( select( $rmask, undef, undef, .01 ) ) { my $ret = sysread( $self, ${*$self}{exp_Pty_Buffer}, 1024 ); last if not defined $ret or $ret == 0; # Is this necessary to keep? Probably.. # # if you need to expect it later. ${*$self}{exp_Accum} .= ${*$self}{exp_Pty_Buffer}; ${*$self}{exp_Accum} = $self->_trim_length( ${*$self}{exp_Accum}, ${*$self}{"exp_Max_Accum"} ) if ( ${*$self}{"exp_Max_Accum"} ); $self->_print_handles( ${*$self}{exp_Pty_Buffer} ); print STDERR "Received \'" . $self->_trim_length( _make_readable($char) ) . "\' from ${*$self}{exp_Pty_Handle}\r\n" if ${*$self}{"exp_Debug"} > 1; } } } } return; } sub test_handles { my ($timeout, @handle_list) = @_; # This should be called by Expect::test_handles($timeout,@objects); my ( $allmask, $rout ); foreach my $handle (@handle_list) { my $rmask = ''; vec( $rmask, $handle->fileno(), 1 ) = 1; $allmask = '' unless defined($allmask); $allmask = $allmask | $rmask; } my $nfound = select( $rout = $allmask, undef, undef, $timeout ); return () unless $nfound; # Which handles have stuff? my @bits = split( //, unpack( 'b*', $rout ) ); my $handle_num = 0; my @return_list = (); foreach my $handle (@handle_list) { # I go to great lengths to get perl -w to shut the hell up. if ( defined( $bits[ $handle->fileno() ] ) and ( $bits[ $handle->fileno() ] ) ) { push( @return_list, $handle_num ); } } continue { $handle_num++; } return @return_list; } # Be nice close. This should emulate what an interactive shell does after a # command finishes... sort of. We're not as patient as a shell. sub soft_close { my ($self) = @_; my ( $nfound, $nread, $rmask, $end_time, $temp_buffer ); # Give it 15 seconds to cough up an eof. cluck "Closing ${*$self}{exp_Pty_Handle}.\r\n" if ${*$self}{exp_Debug}; return -1 if not defined $self->fileno(); # skip if handle already closed unless ( exists ${*$self}{exp_Has_EOF} and ${*$self}{exp_Has_EOF} ) { $end_time = time() + 15; while ( $end_time > time() ) { my $select_time = $end_time - time(); # Sanity check. $select_time = 0 if $select_time < 0; $rmask = ''; vec( $rmask, $self->fileno(), 1 ) = 1; ($nfound) = select( $rmask, undef, undef, $select_time ); last unless ( defined($nfound) && $nfound ); $nread = sysread( $self, $temp_buffer, 8096 ); # 0 = EOF. unless ( defined($nread) && $nread ) { print STDERR "Got EOF from ${*$self}{exp_Pty_Handle}.\r\n" if ${*$self}{exp_Debug}; last; } $self->_print_handles($temp_buffer); } if ( ( $end_time <= time() ) && ${*$self}{exp_Debug} ) { print STDERR "Timed out waiting for an EOF from ${*$self}{exp_Pty_Handle}.\r\n"; } } my $close_status = $self->close(); if ( $close_status && ${*$self}{exp_Debug} ) { print STDERR "${*$self}{exp_Pty_Handle} closed.\r\n"; } # quit now if it isn't a process. return $close_status unless defined( ${*$self}{exp_Pid} ); # Now give it 15 seconds to die. $end_time = time() + 15; while ( $end_time > time() ) { my $returned_pid = waitpid( ${*$self}{exp_Pid}, &WNOHANG ); # Stop here if the process dies. if ( defined($returned_pid) && $returned_pid ) { delete $Expect::Spawned_PIDs{$returned_pid}; if ( ${*$self}{exp_Debug} ) { printf STDERR ( "Pid %d of %s exited, Status: 0x%02X\r\n", ${*$self}{exp_Pid}, ${*$self}{exp_Pty_Handle}, $? ); } ${*$self}{exp_Pid} = undef; ${*$self}{exp_Exit} = $?; return ${*$self}{exp_Exit}; } sleep 1; # Keep loop nice. } # Send it a term if it isn't dead. if ( ${*$self}{exp_Debug} ) { print STDERR "${*$self}{exp_Pty_Handle} not exiting, sending TERM.\r\n"; } kill TERM => ${*$self}{exp_Pid}; # Now to be anal retentive.. wait 15 more seconds for it to die. $end_time = time() + 15; while ( $end_time > time() ) { my $returned_pid = waitpid( ${*$self}{exp_Pid}, &WNOHANG ); if ( defined($returned_pid) && $returned_pid ) { delete $Expect::Spawned_PIDs{$returned_pid}; if ( ${*$self}{exp_Debug} ) { printf STDERR ( "Pid %d of %s terminated, Status: 0x%02X\r\n", ${*$self}{exp_Pid}, ${*$self}{exp_Pty_Handle}, $? ); } ${*$self}{exp_Pid} = undef; ${*$self}{exp_Exit} = $?; return $?; } sleep 1; } # Since this is a 'soft' close, sending it a -9 would be inappropriate. return; } # 'Make it go away' close. sub hard_close { my ($self) = @_; cluck "Closing ${*$self}{exp_Pty_Handle}.\r\n" if ${*$self}{exp_Debug}; # Don't wait for an EOF. my $close_status = $self->close(); if ( $close_status && ${*$self}{exp_Debug} ) { print STDERR "${*$self}{exp_Pty_Handle} closed.\r\n"; } # Return now if handle. return $close_status unless defined( ${*$self}{exp_Pid} ); # Now give it 5 seconds to die. Less patience here if it won't die. my $end_time = time() + 5; while ( $end_time > time() ) { my $returned_pid = waitpid( ${*$self}{exp_Pid}, &WNOHANG ); # Stop here if the process dies. if ( defined($returned_pid) && $returned_pid ) { delete $Expect::Spawned_PIDs{$returned_pid}; if ( ${*$self}{exp_Debug} ) { printf STDERR ( "Pid %d of %s terminated, Status: 0x%02X\r\n", ${*$self}{exp_Pid}, ${*$self}{exp_Pty_Handle}, $? ); } ${*$self}{exp_Pid} = undef; ${*$self}{exp_Exit} = $?; return ${*$self}{exp_Exit}; } sleep 1; # Keep loop nice. } # Send it a term if it isn't dead. if ( ${*$self}{exp_Debug} ) { print STDERR "${*$self}{exp_Pty_Handle} not exiting, sending TERM.\r\n"; } kill TERM => ${*$self}{exp_Pid}; # wait 15 more seconds for it to die. $end_time = time() + 15; while ( $end_time > time() ) { my $returned_pid = waitpid( ${*$self}{exp_Pid}, &WNOHANG ); if ( defined($returned_pid) && $returned_pid ) { delete $Expect::Spawned_PIDs{$returned_pid}; if ( ${*$self}{exp_Debug} ) { printf STDERR ( "Pid %d of %s terminated, Status: 0x%02X\r\n", ${*$self}{exp_Pid}, ${*$self}{exp_Pty_Handle}, $? ); } ${*$self}{exp_Pid} = undef; ${*$self}{exp_Exit} = $?; return ${*$self}{exp_Exit}; } sleep 1; } kill KILL => ${*$self}{exp_Pid}; # wait 5 more seconds for it to die. $end_time = time() + 5; while ( $end_time > time() ) { my $returned_pid = waitpid( ${*$self}{exp_Pid}, &WNOHANG ); if ( defined($returned_pid) && $returned_pid ) { delete $Expect::Spawned_PIDs{$returned_pid}; if ( ${*$self}{exp_Debug} ) { printf STDERR ( "Pid %d of %s killed, Status: 0x%02X\r\n", ${*$self}{exp_Pid}, ${*$self}{exp_Pty_Handle}, $? ); } ${*$self}{exp_Pid} = undef; ${*$self}{exp_Exit} = $?; return ${*$self}{exp_Exit}; } sleep 1; } warn "Pid ${*$self}{exp_Pid} of ${*$self}{exp_Pty_Handle} is HUNG.\r\n"; ${*$self}{exp_Pid} = undef; return; } # These should not be called externally. sub _init_vars { my ($self) = @_; # for every spawned process or filehandle. ${*$self}{exp_Log_Stdout} = $Expect::Log_Stdout if defined($Expect::Log_Stdout); ${*$self}{exp_Log_Group} = $Expect::Log_Group; ${*$self}{exp_Debug} = $Expect::Debug; ${*$self}{exp_Exp_Internal} = $Expect::Exp_Internal; ${*$self}{exp_Manual_Stty} = $Expect::Manual_Stty; ${*$self}{exp_Stored_Stty} = 'sane'; ${*$self}{exp_Do_Soft_Close} = $Expect::Do_Soft_Close; # sysread doesn't like my or local vars. ${*$self}{exp_Pty_Buffer} = ''; # Initialize accumulator. ${*$self}{exp_Max_Accum} = $Expect::Exp_Max_Accum; ${*$self}{exp_Accum} = ''; ${*$self}{exp_NoTransfer} = 0; # create empty expect_before & after lists ${*$self}{exp_expect_before_list} = []; ${*$self}{exp_expect_after_list} = []; return; } sub _make_readable { my ($s) = @_; $s = '' if not defined($s); study $s; # Speed things up? $s =~ s/\\/\\\\/g; # So we can tell easily(?) what is a backslash $s =~ s/\n/\\n/g; $s =~ s/\r/\\r/g; $s =~ s/\t/\\t/g; $s =~ s/\'/\\\'/g; # So we can tell whassa quote and whassa notta quote. $s =~ s/\"/\\\"/g; # Formfeed (does anyone use formfeed?) $s =~ s/\f/\\f/g; $s =~ s/\010/\\b/g; # escape control chars high/low, but allow ISO 8859-1 chars $s =~ s/([\000-\037\177-\237\377])/sprintf("\\%03lo",ord($1))/ge; return $s; } sub _trim_length { my ($self, $string, $length) = @_; # This is sort of a reverse truncation function # Mostly so we don't have to see the full output when we're using # Also used if Max_Accum gets set to limit the size of the accumulator # for matching functions. # exp_internal croak('No string passed') if not defined $string; # If we're not passed a length (_trim_length is being used for debugging # purposes) AND debug >= 3, don't trim. return ($string) if (defined($self) and ${*$self}{"exp_Debug"} >= 3 and ( !( defined($length) ) ) ); my $indicate_truncation = ($length ? '' : '...'); $length ||= 1021; return $string if $length >= length $string; # We wouldn't want the accumulator to begin with '...' if max_accum is passed # This is because this funct. gets called internally w/ max_accum # and is also used to print information back to the user. return $indicate_truncation . substr( $string, ( length($string) - $length ), $length ); } sub _print_handles { my ($self, $print_this) = @_; # Given crap from 'self' and the handles self wants to print to, print to # them. these are indicated by the handle's 'group' if ( ${*$self}{exp_Log_Group} ) { foreach my $handle ( @{ ${*$self}{exp_Listen_Group} } ) { $print_this = '' unless defined($print_this); # Appease perl -w print STDERR "Printed '" . $self->_trim_length( _make_readable($print_this) ) . "' to ${*$handle}{exp_Pty_Handle} from ${*$self}{exp_Pty_Handle}.\r\n" if ( ${*$handle}{"exp_Debug"} > 1 ); print $handle $print_this; } } # If ${*$self}{exp_Pty_Handle} is STDIN this would make it echo. print STDOUT $print_this if ${*$self}{"exp_Log_Stdout"}; $self->print_log_file($print_this); $| = 1; # This should not be necessary but autoflush() doesn't always work. return; } sub _get_mode { my ($handle) = @_; my ($fcntl_flags) = ''; # What mode are we opening with? use fcntl to find out. $fcntl_flags = fcntl( \*{$handle}, Fcntl::F_GETFL, $fcntl_flags ); die "fcntl returned undef during exp_init of $handle, $!\r\n" unless defined($fcntl_flags); if ( $fcntl_flags | (Fcntl::O_RDWR) ) { return 'rw'; } elsif ( $fcntl_flags | (Fcntl::O_WRONLY) ) { return 'w'; } else { # Under Solaris (among others?) O_RDONLY is implemented as 0. so |O_RDONLY would fail. return 'r'; } } sub _undef { return undef; # Seems a little retarded but &CORE::undef fails in interconnect. # This is used for the default escape sequence function. # w/out the leading & it won't compile. } # clean up child processes sub DESTROY { my ($self) = @_; my $status = $?; # save this as it gets mangled by the terminating spawned children if ( ${*$self}{exp_Do_Soft_Close} ) { $self->soft_close(); } $self->hard_close(); $? = $status; # restore it. otherwise deleting an Expect object may mangle $?, which is unintuitive return; } 1; __END__ =head1 NAME Expect - automate interactions with command line programs that expose a text terminal interface. =head1 SYNOPSIS use Expect; # create an Expect object by spawning another process my $exp = Expect->spawn($command, @params) or die "Cannot spawn $command: $!\n"; # or by using an already opened filehandle (e.g. from Net::Telnet) my $exp = Expect->exp_init(\*FILEHANDLE); # if you prefer the OO mindset: my $exp = Expect->new; $exp->raw_pty(1); $exp->spawn($command, @parameters) or die "Cannot spawn $command: $!\n"; # send some string there: $exp->send("string\n"); # or, for the filehandle mindset: print $exp "string\n"; # then do some pattern matching with either the simple interface $patidx = $exp->expect($timeout, @match_patterns); # or multi-match on several spawned commands with callbacks, # just like the Tcl version $exp->expect($timeout, [ qr/regex1/ => sub { my $exp = shift; $exp->send("response\n"); exp_continue; } ], [ "regexp2" , \&callback, @cbparms ], ); # if no longer needed, do a soft_close to nicely shut down the command $exp->soft_close(); # or be less patient with $exp->hard_close(); Expect.pm is built to either spawn a process or take an existing filehandle and interact with it such that normally interactive tasks can be done without operator assistance. This concept makes more sense if you are already familiar with the versatile Tcl version of Expect. The public functions that make up Expect.pm are: Expect->new() Expect::interconnect(@objects_to_be_read_from) Expect::test_handles($timeout, @objects_to_test) Expect::version($version_requested | undef); $object->spawn(@command) $object->clear_accum() $object->set_accum($value) $object->debug($debug_level) $object->exp_internal(0 | 1) $object->notransfer(0 | 1) $object->raw_pty(0 | 1) $object->stty(@stty_modes) # See the IO::Stty docs $object->slave() $object->before(); $object->match(); $object->after(); $object->matchlist(); $object->match_number(); $object->error(); $object->command(); $object->exitstatus(); $object->pty_handle(); $object->do_soft_close(); $object->restart_timeout_upon_receive(0 | 1); $object->interact($other_object, $escape_sequence) $object->log_group(0 | 1 | undef) $object->log_user(0 | 1 | undef) $object->log_file("filename" | $filehandle | \&coderef | undef) $object->manual_stty(0 | 1 | undef) $object->match_max($max_buffersize or undef) $object->pid(); $object->send_slow($delay, @strings_to_send) $object->set_group(@listen_group_objects | undef) $object->set_seq($sequence,\&function,\@parameters); There are several configurable package variables that affect the behavior of Expect. They are: $Expect::Debug; $Expect::Exp_Internal; $Expect::IgnoreEintr; $Expect::Log_Group; $Expect::Log_Stdout; $Expect::Manual_Stty; $Expect::Multiline_Matching; $Expect::Do_Soft_Close; =head1 DESCRIPTION See an explanation of L The Expect module is a successor of Comm.pl and a descendent of Chat.pl. It more closely resembles the Tcl Expect language than its predecessors. It does not contain any of the networking code found in Comm.pl. I suspect this would be obsolete anyway given the advent of IO::Socket and external tools such as netcat. Expect.pm is an attempt to have more of a switch() & case feeling to make decision processing more fluid. Three separate types of debugging have been implemented to make code production easier. It is possible to interconnect multiple file handles (and processes) much like Tcl's Expect. An attempt was made to enable all the features of Tcl's Expect without forcing Tcl on the victim programmer :-) . Please, before you consider using Expect, read the FAQs about L and L =head1 USAGE =over 4 =item new Creates a new Expect object, i.e. a pty. You can change parameters on it before actually spawning a command. This is important if you want to modify the terminal settings for the slave. See slave() below. The object returned is actually a reblessed IO::Pty filehandle, so see there for additional methods. =item Expect->exp_init(\*FILEHANDLE) I =item Expect->init(\*FILEHANDLE) Initializes $new_handle_object for use with other Expect functions. It must be passed a B<_reference_> to FILEHANDLE if you want it to work properly. IO::File objects are preferable. Returns a reference to the newly created object. You can use only real filehandles, certain tied filehandles (e.g. Net::SSH2) that lack a fileno() will not work. Net::Telnet objects can be used but have been reported to work only for certain hosts. YMMV. =item Expect->spawn($command, @parameters) I =item $object->spawn($command, @parameters) I =item Expect->new($command, @parameters) Forks and execs $command. Returns an Expect object upon success or C if the fork was unsuccessful or the command could not be found. spawn() passes its parameters unchanged to Perls exec(), so look there for detailed semantics. Note that if spawn cannot exec() the given command, the Expect object is still valid and the next expect() will see "Cannot exec", so you can use that for error handling. Also note that you cannot reuse an object with an already spawned command, even if that command has exited. Sorry, but you have to allocate a new object... =item $object->debug(0 | 1 | 2 | 3 | undef) Sets debug level for $object. 1 refers to general debugging information, 2 refers to verbose debugging and 0 refers to no debugging. If you call debug() with no parameters it will return the current debugging level. When the object is created the debugging level will match that $Expect::Debug, normally 0. The '3' setting is new with 1.05, and adds the additional functionality of having the _full_ accumulated buffer printed every time data is read from an Expect object. This was implemented by request. I recommend against using this unless you think you need it as it can create quite a quantity of output under some circumstances.. =item $object->exp_internal(1 | 0) Sets/unsets 'exp_internal' debugging. This is similar in nature to its Tcl counterpart. It is extremely valuable when debugging expect() sequences. When the object is created the exp_internal setting will match the value of $Expect::Exp_Internal, normally 0. Returns the current setting if called without parameters. It is highly recommended that you make use of the debugging features lest you have angry code. =item $object->raw_pty(1 | 0) Set pty to raw mode before spawning. This disables echoing, CR->LF translation and an ugly hack for broken Solaris TTYs (which send to slow things down) and thus gives a more pipe-like behaviour (which is important if you want to transfer binary content). Note that this must be set I spawning the program. =item $object->stty(qw(mode1 mode2...)) Sets the tty mode for $object's associated terminal to the given modes. Note that on many systems the master side of the pty is not a tty, so you have to modify the slave pty instead, see next item. This needs IO::Stty installed, which is no longer required. =item $object->slave() Returns a filehandle to the slave part of the pty. Very useful in modifying the terminal settings: $object->slave->stty(qw(raw -echo)); Typical values are 'sane', 'raw', and 'raw -echo'. Note that I recommend setting the terminal to 'raw' or 'raw -echo', as this avoids a lot of hassle and gives pipe-like (i.e. transparent) behaviour (without the buffering issue). =item $object->print(@strings) I =item $object->send(@strings) Sends the given strings to the spawned command. Note that the strings are not logged in the logfile (see print_log_file) but will probably be echoed back by the pty, depending on pty settings (default is echo) and thus end up there anyway. This must also be taken into account when expect()ing for an answer: the next string will be the command just sent. I suggest setting the pty to raw, which disables echo and makes the pty transparently act like a bidirectional pipe. =item $object->expect($timeout, @match_patterns) =over 4 =item Simple interface Given $timeout in seconds Expect will wait for $object's handle to produce one of the match_patterns, which are matched exactly by default. If you want a regexp match, use a regexp object (C) or prefix the pattern with '-re'. $object->expect(15, 'match me exactly', qr/match\s+me\s+exactly/); $object->expect(15, 'match me exactly','-re','match\s+me\s+exactly'); Due to o/s limitations $timeout should be a round number. If $timeout is 0 Expect will check one time to see if $object's handle contains any of the match_patterns. If $timeout is undef Expect will wait forever for a pattern to match. If you don't want to explicitly put the timeout on all calls to C, you can set it via the C method . If the first argument of C doesn't look like a number, that value will be used. $object->timeout(15); $object->expect('match me exactly','-re','match\s+me\s+exactly'); If called in a scalar context, expect() will return the position of the matched pattern within @matched_patterns, or undef if no pattern was matched. This is a position starting from 1, so if you want to know which of an array of @matched_patterns matched you should subtract one from the return value. If called in an array context expect() will return ($matched_pattern_position, $error, $successfully_matching_string, $before_match, and $after_match). C<$matched_pattern_position> will contain the value that would have been returned if expect() had been called in a scalar context. C<$error> is the error that occurred that caused expect() to return. $error will contain a number followed by a string equivalent expressing the nature of the error. Possible values are undef, indicating no error, '1:TIMEOUT' indicating that $timeout seconds had elapsed without a match, '2:EOF' indicating an eof was read from $object, '3: spawn id($fileno) died' indicating that the process exited before matching and '4:$!' indicating whatever error was set in $ERRNO during the last read on $object's handle or during select(). All handles indicated by set_group plus STDOUT will have all data to come out of $object printed to them during expect() if log_group and log_stdout are set. C<$successfully_matching_string> C<$before_match> C<$after_match> Changed from older versions is the regular expression handling. By default now all strings passed to expect() are treated as literals. To match a regular expression pass '-re' as a parameter in front of the pattern you want to match as a regexp. This change makes it possible to match literals and regular expressions in the same expect() call. Also new is multiline matching. ^ will now match the beginning of lines. Unfortunately, because perl doesn't use $/ in determining where lines break using $ to find the end of a line frequently doesn't work. This is because your terminal is returning "\r\n" at the end of every line. One way to check for a pattern at the end of a line would be to use \r?$ instead of $. Example: Spawning telnet to a host, you might look for the escape character. telnet would return to you "\r\nEscape character is '^]'.\r\n". To find this you might use $match='^Escape char.*\.\r?$'; $telnet->expect(10,'-re',$match); =item New more Tcl/Expect-like interface expect($timeout, '-i', [ $obj1, $obj2, ... ], [ $re_pattern, sub { ...; exp_continue; }, @subparms, ], [ 'eof', sub { ... } ], [ 'timeout', sub { ... }, \$subparm1 ], '-i', [ $objn, ...], '-ex', $exact_pattern, sub { ... }, $exact_pattern, sub { ...; exp_continue_timeout; }, '-re', $re_pattern, sub { ... }, '-i', \@object_list, @pattern_list, ...); It's now possible to expect on more than one connection at a time by specifying 'C<-i>' and a single Expect object or a ref to an array containing Expect objects, e.g. expect($timeout, '-i', $exp1, @patterns_1, '-i', [ $exp2, $exp3 ], @patterns_2_3, ) Furthermore, patterns can now be specified as array refs containing [$regexp, sub { ...}, @optional_subprams] . When the pattern matches, the subroutine is called with parameters ($matched_expect_obj, @optional_subparms). The subroutine can return the symbol `exp_continue' to continue the expect matching with timeout starting anew or return the symbol `exp_continue_timeout' for continuing expect without resetting the timeout count. $exp->expect($timeout, [ qr/username: /i, sub { my $self = shift; $self->send("$username\n"); exp_continue; }], [ qr/password: /i, sub { my $self = shift; $self->send("$password\n"); exp_continue; }], $shell_prompt); `expect' is now exported by default. =back =item $object->exp_before() I =item $object->before() before() returns the 'before' part of the last expect() call. If the last expect() call didn't match anything, exp_before() will return the entire output of the object accumulated before the expect() call finished. Note that this is something different than Tcl Expects before()!! =item $object->exp_after() I =item $object->after() returns the 'after' part of the last expect() call. If the last expect() call didn't match anything, exp_after() will return undef(). =item $object->exp_match() I =item $object->match() returns the string matched by the last expect() call, undef if no string was matched. =item $object->exp_match_number() I =item $object->match_number() exp_match_number() returns the number of the pattern matched by the last expect() call. Keep in mind that the first pattern in a list of patterns is 1, not 0. Returns undef if no pattern was matched. =item $object->exp_matchlist() I =item $object->matchlist() exp_matchlist() returns a list of matched substrings from the brackets () inside the regexp that last matched. ($object->matchlist)[0] thus corresponds to $1, ($object->matchlist)[1] to $2, etc. =item $object->exp_error() I =item $object->error() exp_error() returns the error generated by the last expect() call if no pattern was matched. It is typically useful to examine the value returned by before() to find out what the output of the object was in determining why it didn't match any of the patterns. =item $object->clear_accum() Clear the contents of the accumulator for $object. This gets rid of any residual contents of a handle after expect() or send_slow() such that the next expect() call will only see new data from $object. The contents of the accumulator are returned. =item $object->set_accum($value) Sets the content of the accumulator for $object to $value. The previous content of the accumulator is returned. =item $object->exp_command() I =item $object->command() exp_command() returns the string that was used to spawn the command. Helpful for debugging and for reused patternmatch subroutines. =item $object->exp_exitstatus() I =item $object->exitstatus() Returns the exit status of $object (if it already exited). =item $object->exp_pty_handle() I =item $object->pty_handle() Returns a string representation of the attached pty, for example: `spawn id(5)' (pty has fileno 5), `handle id(7)' (pty was initialized from fileno 7) or `STDIN'. Useful for debugging. =item $object->restart_timeout_upon_receive(0 | 1) If this is set to 1, the expect timeout is retriggered whenever something is received from the spawned command. This allows to perform some aliveness testing and still expect for patterns. $exp->restart_timeout_upon_receive(1); $exp->expect($timeout, [ timeout => \&report_timeout ], [ qr/pattern/ => \&handle_pattern], ); Now the timeout isn't triggered if the command produces any kind of output, i.e. is still alive, but you can act upon patterns in the output. =item $object->notransfer(1 | 0) Do not truncate the content of the accumulator after a match. Normally, the accumulator is set to the remains that come after the matched string. Note that this setting is per object and not per pattern, so if you want to have normal acting patterns that truncate the accumulator, you have to add a $exp->set_accum($exp->after); to their callback, e.g. $exp->notransfer(1); $exp->expect($timeout, # accumulator not truncated, pattern1 will match again [ "pattern1" => sub { my $self = shift; ... } ], # accumulator truncated, pattern2 will not match again [ "pattern2" => sub { my $self = shift; ... $self->set_accum($self->after()); } ], ); This is only a temporary fix until I can rewrite the pattern matching part so it can take that additional -notransfer argument. =item Expect::interconnect(@objects); Read from @objects and print to their @listen_groups until an escape sequence is matched from one of @objects and the associated function returns 0 or undef. The special escape sequence 'EOF' is matched when an object's handle returns an end of file. Note that it is not necessary to include objects that only accept data in @objects since the escape sequence is _read_ from an object. Further note that the listen_group for a write-only object is always empty. Why would you want to have objects listening to STDOUT (for example)? By default every member of @objects _as well as every member of its listen group_ will be set to 'raw -echo' for the duration of interconnection. Setting $object->manual_stty() will stop this behavior per object. The original tty settings will be restored as interconnect exits. For a generic way to interconnect processes, take a look at L. =item Expect::test_handles(@objects) Given a set of objects determines which objects' handles have data ready to be read. B who's members are positions in @objects that have ready handles. Returns undef if there are no such handles ready. =item Expect::version($version_requested or undef); Returns current version of Expect. As of .99 earlier versions are not supported. Too many things were changed to make versioning possible. =item $object->interact( C<\*FILEHANDLE, $escape_sequence>) interact() is essentially a macro for calling interconnect() for connecting 2 processes together. \*FILEHANDLE defaults to \*STDIN and $escape_sequence defaults to undef. Interaction ceases when $escape_sequence is read from B, not $object. $object's listen group will consist solely of \*FILEHANDLE for the duration of the interaction. \*FILEHANDLE will not be echoed on STDOUT. =item $object->log_group(0 | 1 | undef) Set/unset logging of $object to its 'listen group'. If set all objects in the listen group will have output from $object printed to them during $object->expect(), $object->send_slow(), and C. Default value is on. During creation of $object the setting will match the value of $Expect::Log_Group, normally 1. =item $object->log_user(0 | 1 | undef) I =item $object->log_stdout(0 | 1 | undef) Set/unset logging of object's handle to STDOUT. This corresponds to Tcl's log_user variable. Returns current setting if called without parameters. Default setting is off for initialized handles. When a process object is created (not a filehandle initialized with exp_init) the log_stdout setting will match the value of $Expect::Log_Stdout variable, normally 1. If/when you initialize STDIN it is usually associated with a tty which will by default echo to STDOUT anyway, so be careful or you will have multiple echoes. =item $object->log_file("filename" | $filehandle | \&coderef | undef) Log session to a file. All characters send to or received from the spawned process are written to the file. Normally appends to the logfile, but you can pass an additional mode of "w" to truncate the file upon open(): $object->log_file("filename", "w"); Returns the logfilehandle. If called with an undef value, stops logging and closes logfile: $object->log_file(undef); If called without argument, returns the logfilehandle: $fh = $object->log_file(); Can be set to a code ref, which will be called instead of printing to the logfile: $object->log_file(\&myloggerfunc); =item $object->print_log_file(@strings) Prints to logfile (if opened) or calls the logfile hook function. This allows the user to add arbitrary text to the logfile. Note that this could also be done as $object->log_file->print() but would only work for log files, not code hooks. =item $object->set_seq($sequence, \&function, \@function_parameters) During Expect->interconnect() if $sequence is read from $object &function will be executed with parameters @function_parameters. It is B<_highly recommended_> that the escape sequence be a single character since the likelihood is great that the sequence will be broken into to separate reads from the $object's handle, making it impossible to strip $sequence from getting printed to $object's listen group. \&function should be something like 'main::control_w_function' and @function_parameters should be an array defined by the caller, passed by reference to set_seq(). Your function should return a non-zero value if execution of interconnect() is to resume after the function returns, zero or undefined if interconnect() should return after your function returns. The special sequence 'EOF' matches the end of file being reached by $object. See interconnect() for details. =item $object->set_group(@listener_objects) @listener_objects is the list of objects that should have their handles printed to by $object when Expect::interconnect, $object->expect() or $object->send_slow() are called. Calling w/out parameters will return the current list of the listener objects. =item $object->manual_stty(0 | 1 | undef) Sets/unsets whether or not Expect should make reasonable guesses as to when and how to set tty parameters for $object. Will match $Expect::Manual_Stty value (normally 0) when $object is created. If called without parameters manual_stty() will return the current manual_stty setting. =item $object->match_max($maximum_buffer_length | undef) I =item $object->max_accum($maximum_buffer_length | undef) Set the maximum accumulator size for object. This is useful if you think that the accumulator will grow out of hand during expect() calls. Since the buffer will be matched by every match_pattern it may get slow if the buffer gets too large. Returns current value if called without parameters. Not defined by default. =item $object->notransfer(0 | 1) If set, matched strings will not be deleted from the accumulator. Returns current value if called without parameters. False by default. =item $object->exp_pid() I =item $object->pid() Return pid of $object, if one exists. Initialized filehandles will not have pids (of course). =item $object->send_slow($delay, @strings); print each character from each string of @strings one at a time with $delay seconds before each character. This is handy for devices such as modems that can be annoying if you send them data too fast. After each character $object will be checked to determine whether or not it has any new data ready and if so update the accumulator for future expect() calls and print the output to STDOUT and @listen_group if log_stdout and log_group are appropriately set. =back =head2 Configurable Package Variables: =over 4 =item $Expect::Debug Defaults to 0. Newly created objects have a $object->debug() value of $Expect::Debug. See $object->debug(); =item $Expect::Do_Soft_Close Defaults to 0. When destroying objects, soft_close may take up to half a minute to shut everything down. From now on, only hard_close will be called, which is less polite but still gives the process a chance to terminate properly. Set this to '1' for old behaviour. =item $Expect::Exp_Internal Defaults to 0. Newly created objects have a $object->exp_internal() value of $Expect::Exp_Internal. See $object->exp_internal(). =item $Expect::IgnoreEintr Defaults to 0. If set to 1, when waiting for new data, Expect will ignore EINTR errors and restart the select() call instead. =item $Expect::Log_Group Defaults to 1. Newly created objects have a $object->log_group() value of $Expect::Log_Group. See $object->log_group(). =item $Expect::Log_Stdout Defaults to 1 for spawned commands, 0 for file handles attached with exp_init(). Newly created objects have a $object->log_stdout() value of $Expect::Log_Stdout. See $object->log_stdout(). =item $Expect::Manual_Stty Defaults to 0. Newly created objects have a $object->manual_stty() value of $Expect::Manual_Stty. See $object->manual_stty(). =item $Expect::Multiline_Matching Defaults to 1. Affects whether or not expect() uses the /m flag for doing regular expression matching. If set to 1 /m is used. This makes a difference when you are trying to match ^ and $. If you have this on you can match lines in the middle of a page of output using ^ and $ instead of it matching the beginning and end of the entire expression. I think this is handy. The $Expect::Multiline_Matching turns on and off Expect's multi-line matching mode. But this only has an effect if you pass in a string, and then use '-re' mode. If you pass in a regular expression value (via qr//), then the qr//'s own flags are preserved irrespective of what it gets interpolated into. There was a bug in Perl 5.8.x where interpolating a regex without /m into a match with /m would incorrectly apply the /m to the inner regex too, but this was fixed in Perl 5.10. The correct behavior, as seen in Perl 5.10, is that if you pass in a regex (via qr//), then $Expect::Multiline_Matching has no effect. So if you pass in a regex, then you must use the qr's flags to control whether it is multiline (which by default it is not, opposite of the default behavior of Expect). =back =head1 CONTRIBUTIONS Lee Eakin has ported the kibitz script from Tcl/Expect to Perl/Expect. Jeff Carr provided a simple example of how handle terminal window resize events (transmitted via the WINCH signal) in a ssh session. You can find both scripts in the examples/ subdir. Thanks to both! Historical notes: There are still a few lines of code dating back to the inspirational Comm.pl and Chat.pl modules without which this would not have been possible. Kudos to Eric Arnold and Randal 'Nuke your NT box with one line of perl code' Schwartz for making these available to the perl public. As of .98 I think all the old code is toast. No way could this have been done without it though. Special thanks to Graham Barr for helping make sense of the IO::Handle stuff as well as providing the highly recommended IO::Tty module. =head1 REFERENCES Mark Rogaski wrote: "I figured that you'd like to know that Expect.pm has been very useful to AT&T Labs over the past couple of years (since I first talked to Austin about design decisions). We use Expect.pm for managing the switches in our network via the telnet interface, and such automation has significantly increased our reliability. So, you can honestly say that one of the largest digital networks in existence (AT&T Frame Relay) uses Expect.pm quite extensively." =head1 FAQ - Frequently Asked Questions This is a growing collection of things that might help. Please send you questions that are not answered here to RGiersig@cpan.org =head2 What systems does Expect run on? Expect itself doesn't have real system dependencies, but the underlying IO::Tty needs pseudoterminals. IO::Stty uses POSIX.pm and Fcntl.pm. I have used it on Solaris, Linux and AIX, others report *BSD and OSF as working. Generally, any modern POSIX Unix should do, but there are exceptions to every rule. Feedback is appreciated. See L for a list of verified systems. =head2 Can I use this module with ActivePerl on Windows? Up to now, the answer was 'No', but this has changed. You still cannot use ActivePerl, but if you use the Cygwin environment (http://sources.redhat.com), which brings its own perl, and have the latest IO::Tty (v0.05 or later) installed, it should work (feedback appreciated). =head2 The examples in the tutorial don't work! The tutorial is hopelessly out of date and needs a serious overhaul. I apologize for this, I have concentrated my efforts mainly on the functionality. Volunteers welcomed. =head2 How can I find out what Expect is doing? If you set $Expect::Exp_Internal = 1; Expect will tell you very verbosely what it is receiving and sending, what matching it is trying and what it found. You can do this on a per-command base with $exp->exp_internal(1); You can also set $Expect::Debug = 1; # or 2, 3 for more verbose output or $exp->debug(1); which gives you even more output. =head2 I am seeing the output of the command I spawned. Can I turn that off? Yes, just set $Expect::Log_Stdout = 0; to globally disable it or $exp->log_stdout(0); for just that command. 'log_user' is provided as an alias so Tcl/Expect user get a DWIM experience... :-) =head2 No, I mean that when I send some text to the spawned process, it gets echoed back and I have to deal with it in the next expect. This is caused by the pty, which has probably 'echo' enabled. A solution would be to set the pty to raw mode, which in general is cleaner for communication between two programs (no more unexpected character translations). Unfortunately this would break a lot of old code that sends "\r" to the program instead of "\n" (translating this is also handled by the pty), so I won't add this to Expect just like that. But feel free to experiment with C<$exp-Eraw_pty(1)>. =head2 How do I send control characters to a process? A: You can send any characters to a process with the print command. To represent a control character in Perl, use \c followed by the letter. For example, control-G can be represented with "\cG" . Note that this will not work if you single-quote your string. So, to send control-C to a process in $exp, do: print $exp "\cC"; Or, if you prefer: $exp->send("\cC"); The ability to include control characters in a string like this is provided by Perl, not by Expect.pm . Trying to learn Expect.pm without a thorough grounding in Perl can be very daunting. We suggest you look into some of the excellent Perl learning material, such as the books _Programming Perl_ and _Learning Perl_ by O'Reilly, as well as the extensive online Perl documentation available through the perldoc command. =head2 My script fails from time to time without any obvious reason. It seems that I am sometimes loosing output from the spawned program. You could be exiting too fast without giving the spawned program enough time to finish. Try adding $exp->soft_close() to terminate the program gracefully or do an expect() for 'eof'. Alternatively, try adding a 'sleep 1' after you spawn() the program. It could be that pty creation on your system is just slow (but this is rather improbable if you are using the latest IO-Tty). =head2 I want to automate password entry for su/ssh/scp/rsh/... You shouldn't use Expect for this. Putting passwords, especially root passwords, into scripts in clear text can mean severe security problems. I strongly recommend using other means. For 'su', consider switching to 'sudo', which gives you root access on a per-command and per-user basis without the need to enter passwords. 'ssh'/'scp' can be set up with RSA authentication without passwords. 'rsh' can use the .rhost mechanism, but I'd strongly suggest to switch to 'ssh'; to mention 'rsh' and 'security' in the same sentence makes an oxymoron. It will work for 'telnet', though, and there are valid uses for it, but you still might want to consider using 'ssh', as keeping cleartext passwords around is very insecure. =head2 I want to use Expect to automate [anything with a buzzword]... Are you sure there is no other, easier way? As a rule of thumb, Expect is useful for automating things that expect to talk to a human, where no formal standard applies. For other tasks that do follow a well-defined protocol, there are often better-suited modules that already can handle those protocols. Don't try to do HTTP requests by spawning telnet to port 80, use LWP instead. To automate FTP, take a look at L or C (http://www.ncftp.org). You don't use a screwdriver to hammer in your nails either, or do you? =head2 Is it possible to use threads with Expect? Basically yes, with one restriction: you must spawn() your programs in the main thread and then pass the Expect objects to the handling threads. The reason is that spawn() uses fork(), and L: "Thinking of mixing fork() and threads? Please lie down and wait until the feeling passes." =head2 I want to log the whole session to a file. Use $exp->log_file("filename"); or $exp->log_file($filehandle); or even $exp->log_file(\&log_procedure); for maximum flexibility. Note that the logfile is appended to by default, but you can specify an optional mode "w" to truncate the logfile: $exp->log_file("filename", "w"); To stop logging, just call it with a false argument: $exp->log_file(undef); =head2 How can I turn off multi-line matching for my regexps? To globally unset multi-line matching for all regexps: $Expect::Multiline_Matching = 0; You can do that on a per-regexp basis by stating C<(?-m)> inside the regexp (you need perl5.00503 or later for that). =head2 How can I expect on multiple spawned commands? You can use the B<-i> parameter to specify a single object or a list of Expect objects. All following patterns will be evaluated against that list. You can specify B<-i> multiple times to create groups of objects and patterns to match against within the same expect statement. This works just like in Tcl/Expect. See the source example below. =head2 I seem to have problems with ptys! Well, pty handling is really a black magic, as it is extremely system dependent. I have extensively revised IO-Tty, so these problems should be gone. If your system is listed in the "verified" list of IO::Tty, you probably have some non-standard setup, e.g. you compiled your Linux-kernel yourself and disabled ptys. Please ask your friendly sysadmin for help. If your system is not listed, unpack the latest version of IO::Tty, do a 'perl Makefile.PL; make; make test; uname C<-a>' and send me the results and I'll see what I can deduce from that. =head2 I just want to read the output of a process without expect()ing anything. How can I do this? [ Are you sure you need Expect for this? How about qx() or open("prog|")? ] By using expect without any patterns to match. $process->expect(undef); # Forever until EOF $process->expect($timeout); # For a few seconds $process->expect(0); # Is there anything ready on the handle now? =head2 Ok, so now how do I get what was read on the handle? $read = $process->before(); =head2 Where's IO::Pty? Find it on CPAN as IO-Tty, which provides both. =head2 How come when I automate the passwd program to change passwords for me passwd dies before changing the password sometimes/every time? What's happening is you are closing the handle before passwd exits. When you close the handle to a process, it is sent a signal (SIGPIPE?) telling it that STDOUT has gone away. The default behavior for processes is to die in this circumstance. Two ways you can make this not happen are: $process->soft_close(); This will wait 15 seconds for a process to come up with an EOF by itself before killing it. $process->expect(undef); This will wait forever for the process to match an empty set of patterns. It will return when the process hits an EOF. As a rule, you should always expect() the result of your transaction before you continue with processing. =head2 How come when I try to make a logfile with log_file() or set_group() it doesn't print anything after the last time I run expect()? Output is only printed to the logfile/group when Expect reads from the process, during expect(), send_slow() and interconnect(). One way you can force this is to make use of $process->expect(undef); and $process->expect(0); which will make expect() run with an empty pattern set forever or just for an instant to capture the output of $process. The output is available in the accumulator, so you can grab it using $process->before(). =head2 I seem to have problems with terminal settings, double echoing, etc. Tty settings are a major pain to keep track of. If you find unexpected behavior such as double-echoing or a frozen session, doublecheck the documentation for default settings. When in doubt, handle them yourself using $exp->stty() and manual_stty() functions. As of .98 you shouldn't have to worry about stty settings getting fouled unless you use interconnect or intentionally change them (like doing -echo to get a password). If you foul up your terminal's tty settings, kill any hung processes and enter 'stty sane' at a shell prompt. This should make your terminal manageable again. Note that IO::Tty returns ptys with your systems default setting regarding echoing, CRLF translation etc. and Expect does not change them. I have considered setting the ptys to 'raw' without any translation whatsoever, but this would break a lot of existing things, as '\r' translation would not work anymore. On the other hand, a raw pty works much like a pipe and is more WYGIWYE (what you get is what you expect), so I suggest you set it to 'raw' by yourself: $exp = Expect->new; $exp->raw_pty(1); $exp->spawn(...); To disable echo: $exp->slave->stty(qw(-echo)); =head2 I'm spawning a telnet/ssh session and then let the user interact with it. But screen-oriented applications on the other side don't work properly. You have to set the terminal screen size for that. Luckily, IO::Pty already has a method for that, so modify your code to look like this: my $exp = Expect->new; $exp->slave->clone_winsize_from(\*STDIN); $exp->spawn("telnet somehost); Also, some applications need the TERM shell variable set so they know how to move the cursor across the screen. When logging in, the remote shell sends a query (Ctrl-Z I think) and expects the terminal to answer with a string, e.g. 'xterm'. If you really want to go that way (be aware, madness lies at its end), you can handle that and send back the value in $ENV{TERM}. This is only a hand-waving explanation, please figure out the details by yourself. =head2 I set the terminal size as explained above, but if I resize the window, the application does not notice this. You have to catch the signal WINCH ("window size changed"), change the terminal size and propagate the signal to the spawned application: my $exp = Expect->new; $exp->slave->clone_winsize_from(\*STDIN); $exp->spawn("ssh somehost); $SIG{WINCH} = \&winch; sub winch { $exp->slave->clone_winsize_from(\*STDIN); kill WINCH => $exp->pid if $exp->pid; $SIG{WINCH} = \&winch; } $exp->interact(); There is an example file ssh.pl in the examples/ subdir that shows how this works with ssh. Please note that I do strongly object against using Expect to automate ssh login, as there are better way to do that (see L). =head2 I noticed that the test uses a string that resembles, but not exactly matches, a well-known sentence that contains every character. What does that mean? That means you are anal-retentive. :-) [Gotcha there!] =head2 I get a "Could not assign a pty" error when running as a non-root user on an IRIX box? The OS may not be configured to grant additional pty's (pseudo terminals) to non-root users. /usr/sbin/mkpts should be 4755, not 700 for this to work. I don't know about security implications if you do this. =head2 How come I don't notice when the spawned process closes its stdin/out/err?? You are probably on one of the systems where the master doesn't get an EOF when the slave closes stdin/out/err. One possible solution is when you spawn a process, follow it with a unique string that would indicate the process is finished. $process = Expect->spawn('telnet somehost; echo ____END____'); And then $process->expect($timeout,'____END____','other','patterns'); =head1 Source Examples =head2 How to automate login my $telnet = Net::Telnet->new("remotehost") # see Net::Telnet or die "Cannot telnet to remotehost: $!\n";; my $exp = Expect->exp_init($telnet); # deprecated use of spawned telnet command # my $exp = Expect->spawn("telnet localhost") # or die "Cannot spawn telnet: $!\n";; my $spawn_ok; $exp->expect($timeout, [ qr'login: $', sub { $spawn_ok = 1; my $fh = shift; $fh->send("$username\n"); exp_continue; } ], [ 'Password: $', sub { my $fh = shift; print $fh "$password\n"; exp_continue; } ], [ eof => sub { if ($spawn_ok) { die "ERROR: premature EOF in login.\n"; } else { die "ERROR: could not spawn telnet.\n"; } } ], [ timeout => sub { die "No login.\n"; } ], '-re', qr'[#>:] $', #' wait for shell prompt, then exit expect ); =head2 How to expect on multiple spawned commands foreach my $cmd (@list_of_commands) { push @commands, Expect->spawn($cmd); } expect($timeout, '-i', \@commands, [ qr"pattern", # find this pattern in output of all commands sub { my $obj = shift; # object that matched print $obj "something\n"; exp_continue; # we don't want to terminate the expect call } ], '-i', $some_other_command, [ "some other pattern", sub { my ($obj, $parmref) = @_; # ... # now we exit the expect command }, \$parm ], ); =head2 How to propagate terminal sizes my $exp = Expect->new; $exp->slave->clone_winsize_from(\*STDIN); $exp->spawn("ssh somehost); $SIG{WINCH} = \&winch; sub winch { $exp->slave->clone_winsize_from(\*STDIN); kill WINCH => $exp->pid if $exp->pid; $SIG{WINCH} = \&winch; } $exp->interact(); =head1 HOMEPAGE L though the source code is now in GitHub: L =head1 MAILING LISTS There are two mailing lists available, expectperl-announce and expectperl-discuss, at http://lists.sourceforge.net/lists/listinfo/expectperl-announce and http://lists.sourceforge.net/lists/listinfo/expectperl-discuss =head1 BUG TRACKING You can use the CPAN Request Tracker http://rt.cpan.org/ and submit new bugs under http://rt.cpan.org/Ticket/Create.html?Queue=Expect =head1 AUTHORS (c) 1997 Austin Schutz EFE (retired) expect() interface & functionality enhancements (c) 1999-2006 Roland Giersig. This module is now maintained by Dave Jacoby EFE =head1 LICENSE This module can be used under the same terms as Perl. =head1 DISCLAIMER THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. In other words: Use at your own risk. Provided as is. Your mileage may vary. Read the source, Luke! And finally, just to be sure: Any Use of This Product, in Any Manner Whatsoever, Will Increase the Amount of Disorder in the Universe. Although No Liability Is Implied Herein, the Consumer Is Warned That This Process Will Ultimately Lead to the Heat Death of the Universe. =cut Expect-1.36/META.yml0000755000175000017500000000160414566210227011075 0ustar --- abstract: 'automate interactions with command line programs that expose a text terminal interface.' author: - 'Austin Schutz ' - 'Roland Giersig ' - 'Dave Jacoby ' build_requires: File::Temp: '0' Test::More: '1.00' configure_requires: ExtUtils::MakeMaker: '6.64' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.62, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Expect no_index: directory: - t - inc requires: Carp: '0' Errno: '0' Exporter: '0' Fcntl: '0' IO::Handle: '0' IO::Pty: '1.11' IO::Tty: '1.11' POSIX: '0' perl: '5.006000' resources: repository: http://github.com/jacoby/expect.pm.git version: '1.36' x_serialization_backend: 'CPAN::Meta::YAML version 0.018'