1# -*-cperl-*- 2# This module is copyrighted as per the usual perl legalese: 3# Copyright (c) 1997 Austin Schutz. 4# expect() interface & functionality enhancements (c) 1999 Roland Giersig. 5# 6# All rights reserved. This program is free software; you can 7# redistribute it and/or modify it under the same terms as Perl 8# itself. 9# 10# Don't blame/flame me if you bust your stuff. 11# Austin Schutz <ASchutz@users.sourceforge.net> 12# 13# This module now is maintained by 14# Dave Jacoby <jacoby@cpan.org> 15# 16 17use 5.006; 18 19package Expect; 20use strict; 21use warnings; 22 23use IO::Pty 1.11; # We need make_slave_controlling_terminal() 24use IO::Tty; 25 26use POSIX qw(:sys_wait_h :unistd_h); # For WNOHANG and isatty 27use Fcntl qw(:DEFAULT); # For checking file handle settings. 28use Carp qw(cluck croak carp confess); 29use IO::Handle (); 30use Exporter qw(import); 31use Errno; 32 33# This is necessary to make routines within Expect work. 34 35@Expect::ISA = qw(IO::Pty); 36@Expect::EXPORT = qw(expect exp_continue exp_continue_timeout); 37 38BEGIN { 39 $Expect::VERSION = '1.35'; 40 41 # These are defaults which may be changed per object, or set as 42 # the user wishes. 43 # This will be unset, since the default behavior differs between 44 # spawned processes and initialized filehandles. 45 # $Expect::Log_Stdout = 1; 46 $Expect::Log_Group = 1; 47 $Expect::Debug = 0; 48 $Expect::Exp_Max_Accum = 0; # unlimited 49 $Expect::Exp_Internal = 0; 50 $Expect::IgnoreEintr = 0; 51 $Expect::Manual_Stty = 0; 52 $Expect::Multiline_Matching = 1; 53 $Expect::Do_Soft_Close = 0; 54 @Expect::Before_List = (); 55 @Expect::After_List = (); 56 %Expect::Spawned_PIDs = (); 57} 58 59sub version { 60 my ($version) = @_; 61 62 warn "Version $version is later than $Expect::VERSION. It may not be supported" 63 if ( defined($version) && ( $version > $Expect::VERSION ) ); 64 65 die "Versions before 1.03 are not supported in this release" 66 if ( ( defined($version) ) && ( $version < 1.03 ) ); 67 return $Expect::VERSION; 68} 69 70sub new { 71 my ($class, @args) = @_; 72 73 $class = ref($class) if ref($class); # so we can be called as $exp->new() 74 75 # Create the pty which we will use to pass process info. 76 my ($self) = IO::Pty->new; 77 die "$class: Could not assign a pty" unless $self; 78 bless $self => $class; 79 $self->autoflush(1); 80 81 # This is defined here since the default is different for 82 # initialized handles as opposed to spawned processes. 83 ${*$self}{exp_Log_Stdout} = 1; 84 $self->_init_vars(); 85 86 if (@args) { 87 88 # we got add'l parms, so pass them to spawn 89 return $self->spawn(@args); 90 } 91 return $self; 92} 93 94sub spawn { 95 my ($class, @cmd) = @_; 96 # spawn is passed command line args. 97 98 my $self; 99 100 if ( ref($class) ) { 101 $self = $class; 102 } else { 103 $self = $class->new(); 104 } 105 106 croak "Cannot reuse an object with an already spawned command" 107 if exists ${*$self}{"exp_Command"}; 108 ${*$self}{"exp_Command"} = \@cmd; 109 110 # set up pipe to detect childs exec error 111 pipe( FROM_CHILD, TO_PARENT ) or die "Cannot open pipe: $!"; 112 pipe( FROM_PARENT, TO_CHILD ) or die "Cannot open pipe: $!"; 113 TO_PARENT->autoflush(1); 114 TO_CHILD->autoflush(1); 115 eval { fcntl( TO_PARENT, Fcntl::F_SETFD, Fcntl::FD_CLOEXEC ); }; 116 117 my $pid = fork; 118 119 unless ( defined($pid) ) { 120 warn "Cannot fork: $!" if $^W; 121 return; 122 } 123 124 if ($pid) { 125 126 # parent 127 my $errno; 128 ${*$self}{exp_Pid} = $pid; 129 close TO_PARENT; 130 close FROM_PARENT; 131 $self->close_slave(); 132 $self->set_raw() if $self->raw_pty and isatty($self); 133 close TO_CHILD; # so child gets EOF and can go ahead 134 135 # now wait for child exec (eof due to close-on-exit) or exec error 136 my $errstatus = sysread( FROM_CHILD, $errno, 256 ); 137 die "Cannot sync with child: $!" if not defined $errstatus; 138 close FROM_CHILD; 139 if ($errstatus) { 140 $! = $errno + 0; 141 warn "Cannot exec(@cmd): $!\n" if $^W; 142 return; 143 } 144 } else { 145 146 # child 147 close FROM_CHILD; 148 close TO_CHILD; 149 150 $self->make_slave_controlling_terminal(); 151 my $slv = $self->slave() 152 or die "Cannot get slave: $!"; 153 154 $slv->set_raw() if $self->raw_pty; 155 close($self); 156 157 # wait for parent before we detach 158 my $buffer; 159 my $errstatus = sysread( FROM_PARENT, $buffer, 256 ); 160 die "Cannot sync with parent: $!" if not defined $errstatus; 161 close FROM_PARENT; 162 163 close(STDIN); 164 open( STDIN, "<&" . $slv->fileno() ) 165 or die "Couldn't reopen STDIN for reading, $!\n"; 166 close(STDOUT); 167 open( STDOUT, ">&" . $slv->fileno() ) 168 or die "Couldn't reopen STDOUT for writing, $!\n"; 169 close(STDERR); 170 open( STDERR, ">&" . $slv->fileno() ) 171 or die "Couldn't reopen STDERR for writing, $!\n"; 172 173 { exec(@cmd) }; 174 print TO_PARENT $! + 0; 175 die "Cannot exec(@cmd): $!\n"; 176 } 177 178 # This is sort of for code compatibility, and to make debugging a little 179 # easier. By code compatibility I mean that previously the process's 180 # handle was referenced by $process{Pty_Handle} instead of just $process. 181 # This is almost like 'naming' the handle to the process. 182 # I think this also reflects Tcl Expect-like behavior. 183 ${*$self}{exp_Pty_Handle} = "spawn id(" . $self->fileno() . ")"; 184 if ( ( ${*$self}{"exp_Debug"} ) or ( ${*$self}{"exp_Exp_Internal"} ) ) { 185 cluck( 186 "Spawned '@cmd'\r\n", 187 "\t${*$self}{exp_Pty_Handle}\r\n", 188 "\tPid: ${*$self}{exp_Pid}\r\n", 189 "\tTty: " . $self->SUPER::ttyname() . "\r\n", 190 ); 191 } 192 $Expect::Spawned_PIDs{ ${*$self}{exp_Pid} } = undef; 193 return $self; 194} 195 196sub exp_init { 197 my ($class, $self) = @_; 198 199 # take a filehandle, for use later with expect() or interconnect() . 200 # All the functions are written for reading from a tty, so if the naming 201 # scheme looks odd, that's why. 202 bless $self, $class; 203 croak "exp_init not passed a file object, stopped" 204 unless defined( $self->fileno() ); 205 $self->autoflush(1); 206 207 # Define standard variables.. debug states, etc. 208 $self->_init_vars(); 209 210 # Turn of logging. By default we don't want crap from a file to get spewed 211 # on screen as we read it. 212 ${*$self}{exp_Log_Stdout} = 0; 213 ${*$self}{exp_Pty_Handle} = "handle id(" . $self->fileno() . ")"; 214 ${*$self}{exp_Pty_Handle} = "STDIN" if $self->fileno() == fileno(STDIN); 215 print STDERR "Initialized ${*$self}{exp_Pty_Handle}.'\r\n" 216 if ${*$self}{"exp_Debug"}; 217 return $self; 218} 219 220# make an alias 221*init = \&exp_init; 222 223###################################################################### 224# We're happy OOP people. No direct access to stuff. 225# For standard read-writeable parameters, we define some autoload magic... 226my %Writeable_Vars = ( 227 debug => 'exp_Debug', 228 exp_internal => 'exp_Exp_Internal', 229 do_soft_close => 'exp_Do_Soft_Close', 230 max_accum => 'exp_Max_Accum', 231 match_max => 'exp_Max_Accum', 232 notransfer => 'exp_NoTransfer', 233 log_stdout => 'exp_Log_Stdout', 234 log_user => 'exp_Log_Stdout', 235 log_group => 'exp_Log_Group', 236 manual_stty => 'exp_Manual_Stty', 237 restart_timeout_upon_receive => 'exp_Continue', 238 raw_pty => 'exp_Raw_Pty', 239); 240my %Readable_Vars = ( 241 pid => 'exp_Pid', 242 exp_pid => 'exp_Pid', 243 exp_match_number => 'exp_Match_Number', 244 match_number => 'exp_Match_Number', 245 exp_error => 'exp_Error', 246 error => 'exp_Error', 247 exp_command => 'exp_Command', 248 command => 'exp_Command', 249 exp_match => 'exp_Match', 250 match => 'exp_Match', 251 exp_matchlist => 'exp_Matchlist', 252 matchlist => 'exp_Matchlist', 253 exp_before => 'exp_Before', 254 before => 'exp_Before', 255 exp_after => 'exp_After', 256 after => 'exp_After', 257 exp_exitstatus => 'exp_Exit', 258 exitstatus => 'exp_Exit', 259 exp_pty_handle => 'exp_Pty_Handle', 260 pty_handle => 'exp_Pty_Handle', 261 exp_logfile => 'exp_Log_File', 262 logfile => 'exp_Log_File', 263 %Writeable_Vars, 264); 265 266sub AUTOLOAD { 267 my ($self, @args) = @_; 268 269 my $type = ref($self) 270 or croak "$self is not an object"; 271 272 use vars qw($AUTOLOAD); 273 my $name = $AUTOLOAD; 274 $name =~ s/.*:://; # strip fully-qualified portion 275 276 unless ( exists $Readable_Vars{$name} ) { 277 croak "ERROR: cannot find method `$name' in class $type"; 278 } 279 my $varname = $Readable_Vars{$name}; 280 my $tmp; 281 $tmp = ${*$self}{$varname} if exists ${*$self}{$varname}; 282 283 if (@args) { 284 if ( exists $Writeable_Vars{$name} ) { 285 my $ref = ref($tmp); 286 if ( $ref eq 'ARRAY' ) { 287 ${*$self}{$varname} = [@args]; 288 } elsif ( $ref eq 'HASH' ) { 289 ${*$self}{$varname} = {@args}; 290 } else { 291 ${*$self}{$varname} = shift @args; 292 } 293 } else { 294 carp "Trying to set read-only variable `$name'" 295 if $^W; 296 } 297 } 298 299 my $ref = ref($tmp); 300 return ( wantarray ? @{$tmp} : $tmp ) if ( $ref eq 'ARRAY' ); 301 return ( wantarray ? %{$tmp} : $tmp ) if ( $ref eq 'HASH' ); 302 return $tmp; 303} 304 305###################################################################### 306 307sub set_seq { 308 my ( $self, $escape_sequence, $function, $params, @args ) = @_; 309 310 # Set an escape sequence/function combo for a read handle for interconnect. 311 # Ex: $read_handle->set_seq('',\&function,\@parameters); 312 ${ ${*$self}{exp_Function} }{$escape_sequence} = $function; 313 if ( ( !defined($function) ) || ( $function eq 'undef' ) ) { 314 ${ ${*$self}{exp_Function} }{$escape_sequence} = \&_undef; 315 } 316 ${ ${*$self}{exp_Parameters} }{$escape_sequence} = $params; 317 318 # This'll be a joy to execute. :) 319 if ( ${*$self}{"exp_Debug"} ) { 320 print STDERR "Escape seq. '" . $escape_sequence; 321 print STDERR "' function for ${*$self}{exp_Pty_Handle} set to '"; 322 print STDERR ${ ${*$self}{exp_Function} }{$escape_sequence}; 323 print STDERR "(" . join( ',', @args ) . ")'\r\n"; 324 } 325} 326 327sub set_group { 328 my ($self, @args) = @_; 329 330 # Make sure we can read from the read handle 331 if ( !defined( $args[0] ) ) { 332 if ( defined( ${*$self}{exp_Listen_Group} ) ) { 333 return @{ ${*$self}{exp_Listen_Group} }; 334 } else { 335 336 # Refrain from referencing an undef 337 return; 338 } 339 } 340 @{ ${*$self}{exp_Listen_Group} } = (); 341 if ( $self->_get_mode() !~ 'r' ) { 342 warn( 343 "Attempting to set a handle group on ${*$self}{exp_Pty_Handle}, ", 344 "a non-readable handle!\r\n" 345 ); 346 } 347 while ( my $write_handle = shift @args ) { 348 if ( $write_handle->_get_mode() !~ 'w' ) { 349 warn( 350 "Attempting to set a non-writeable listen handle ", 351 "${*$write_handle}{exp_Pty_handle} for ", 352 "${*$self}{exp_Pty_Handle}!\r\n" 353 ); 354 } 355 push( @{ ${*$self}{exp_Listen_Group} }, $write_handle ); 356 } 357} 358 359sub log_file { 360 my ($self, $file, $mode) = @_; 361 $mode ||= "a"; 362 363 return ( ${*$self}{exp_Log_File} ) 364 if @_ < 2; # we got no param, return filehandle 365 # $e->log_file(undef) is an acceptable call hence we need to check the number of parameters here 366 367 if ( ${*$self}{exp_Log_File} and ref( ${*$self}{exp_Log_File} ) ne 'CODE' ) { 368 close( ${*$self}{exp_Log_File} ); 369 } 370 ${*$self}{exp_Log_File} = undef; 371 return if ( not $file ); 372 my $fh = $file; 373 if ( not ref($file) ) { 374 375 # it's a filename 376 $fh = IO::File->new( $file, $mode ) 377 or croak "Cannot open logfile $file: $!"; 378 } 379 if ( ref($file) ne 'CODE' ) { 380 croak "Given logfile doesn't have a 'print' method" 381 if not $fh->can("print"); 382 $fh->autoflush(1); # so logfile is up to date 383 } 384 385 ${*$self}{exp_Log_File} = $fh; 386 387 return $fh; 388} 389 390# I'm going to leave this here in case I might need to change something. 391# Previously this was calling `stty`, in a most bastardized manner. 392sub exp_stty { 393 my ($self) = shift; 394 my ($mode) = "@_"; 395 396 return unless defined $mode; 397 if ( not defined $INC{"IO/Stty.pm"} ) { 398 carp "IO::Stty not installed, cannot change mode"; 399 return; 400 } 401 402 if ( ${*$self}{"exp_Debug"} ) { 403 print STDERR "Setting ${*$self}{exp_Pty_Handle} to tty mode '$mode'\r\n"; 404 } 405 unless ( POSIX::isatty($self) ) { 406 if ( ${*$self}{"exp_Debug"} or $^W ) { 407 warn "${*$self}{exp_Pty_Handle} is not a tty. Not changing mode"; 408 } 409 return ''; # No undef to avoid warnings elsewhere. 410 } 411 IO::Stty::stty( $self, split( /\s/, $mode ) ); 412} 413 414*stty = \&exp_stty; 415 416# If we want to clear the buffer. Otherwise Accum will grow during send_slow 417# etc. and contain the remainder after matches. 418sub clear_accum { 419 my ($self) = @_; 420 return $self->set_accum(''); 421} 422 423sub set_accum { 424 my ($self, $accum) = @_; 425 426 my $old_accum = ${*$self}{exp_Accum}; 427 ${*$self}{exp_Accum} = $accum; 428 429 # return the contents of the accumulator. 430 return $old_accum; 431} 432sub get_accum { 433 my ($self) = @_; 434 return ${*$self}{exp_Accum}; 435} 436 437###################################################################### 438# define constants for pattern subs 439sub exp_continue {"exp_continue"} 440sub exp_continue_timeout {"exp_continue_timeout"} 441 442###################################################################### 443# Expect on multiple objects at once. 444# 445# Call as Expect::expect($timeout, -i => \@exp_list, @patternlist, 446# -i => $exp, @pattern_list, ...); 447# or $exp->expect($timeout, @patternlist, -i => \@exp_list, @patternlist, 448# -i => $exp, @pattern_list, ...); 449# 450# Patterns are arrays that consist of 451# [ $pattern_type, $pattern, $sub, @subparms ] 452# 453# Optional $pattern_type is '-re' (RegExp, default) or '-ex' (exact); 454# 455# $sub is optional CODE ref, which is called as &{$sub}($exp, @subparms) 456# if pattern matched; may return exp_continue or exp_continue_timeout. 457# 458# Old-style syntax (pure pattern strings with optional type) also supported. 459# 460 461sub expect { 462 my $self; 463 464 print STDERR ("expect(@_) called...\n") if $Expect::Debug; 465 if ( defined( $_[0] ) ) { 466 if ( ref( $_[0] ) and $_[0]->isa('Expect') ) { 467 $self = shift; 468 } elsif ( $_[0] eq 'Expect' ) { 469 shift; # or as Expect->expect 470 } 471 } 472 croak "expect(): not enough arguments, should be expect(timeout, [patterns...])" 473 if @_ < 1; 474 my $timeout = shift; 475 my $timeout_hook = undef; 476 477 my @object_list; 478 my %patterns; 479 480 my @pattern_list; 481 my @timeout_list; 482 my $curr_list; 483 484 if ($self) { 485 $curr_list = [$self]; 486 } else { 487 488 # called directly, so first parameter must be '-i' to establish 489 # object list. 490 $curr_list = []; 491 croak 492 "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." 493 if ( $_[0] ne '-i' ); 494 } 495 496 # Let's make a list of patterns wanting to be evaled as regexps. 497 my $parm; 498 my $parm_nr = 1; 499 while ( defined( $parm = shift ) ) { 500 print STDERR ("expect(): handling param '$parm'...\n") 501 if $Expect::Debug; 502 if ( ref($parm) ) { 503 if ( ref($parm) eq 'ARRAY' ) { 504 my $err = _add_patterns_to_list( 505 \@pattern_list, \@timeout_list, 506 $parm_nr, $parm 507 ); 508 carp( 509 "expect(): Warning: multiple `timeout' patterns (", 510 scalar(@timeout_list), ").\r\n" 511 ) if @timeout_list > 1; 512 $timeout_hook = $timeout_list[-1] if $timeout_list[-1]; 513 croak $err if $err; 514 $parm_nr++; 515 } else { 516 croak("expect(): Unknown pattern ref $parm"); 517 } 518 } else { 519 520 # not a ref, is an option or raw pattern 521 if ( substr( $parm, 0, 1 ) eq '-' ) { 522 523 # it's an option 524 print STDERR ("expect(): handling option '$parm'...\n") 525 if $Expect::Debug; 526 if ( $parm eq '-i' ) { 527 528 # first add collected patterns to object list 529 if ( scalar(@$curr_list) ) { 530 push @object_list, $curr_list 531 if not exists $patterns{"$curr_list"}; 532 push @{ $patterns{"$curr_list"} }, @pattern_list; 533 @pattern_list = (); 534 } 535 536 # now put parm(s) into current object list 537 if ( ref( $_[0] ) eq 'ARRAY' ) { 538 $curr_list = shift; 539 } else { 540 $curr_list = [shift]; 541 } 542 } elsif ( $parm eq '-re' 543 or $parm eq '-ex' ) 544 { 545 if ( ref( $_[1] ) eq 'CODE' ) { 546 push @pattern_list, [ $parm_nr, $parm, shift, shift ]; 547 } else { 548 push @pattern_list, [ $parm_nr, $parm, shift, undef ]; 549 } 550 $parm_nr++; 551 } else { 552 croak("Unknown option $parm"); 553 } 554 } else { 555 556 # a plain pattern, check if it is followed by a CODE ref 557 if ( ref( $_[0] ) eq 'CODE' ) { 558 if ( $parm eq 'timeout' ) { 559 push @timeout_list, shift; 560 carp( 561 "expect(): Warning: multiple `timeout' patterns (", 562 scalar(@timeout_list), 563 ").\r\n" 564 ) if @timeout_list > 1; 565 $timeout_hook = $timeout_list[-1] if $timeout_list[-1]; 566 } elsif ( $parm eq 'eof' ) { 567 push @pattern_list, [ $parm_nr, "-$parm", undef, shift ]; 568 } else { 569 push @pattern_list, [ $parm_nr, '-ex', $parm, shift ]; 570 } 571 } else { 572 print STDERR ("expect(): exact match '$parm'...\n") 573 if $Expect::Debug; 574 push @pattern_list, [ $parm_nr, '-ex', $parm, undef ]; 575 } 576 $parm_nr++; 577 } 578 } 579 } 580 581 # add rest of collected patterns to object list 582 carp "expect(): Empty object list" unless $curr_list; 583 push @object_list, $curr_list if not exists $patterns{"$curr_list"}; 584 push @{ $patterns{"$curr_list"} }, @pattern_list; 585 586 my $debug = $self ? ${*$self}{exp_Debug} : $Expect::Debug; 587 my $internal = $self ? ${*$self}{exp_Exp_Internal} : $Expect::Exp_Internal; 588 589 # now start matching... 590 591 if (@Expect::Before_List) { 592 print STDERR ("Starting BEFORE pattern matching...\r\n") 593 if ( $debug or $internal ); 594 _multi_expect( 0, undef, @Expect::Before_List ); 595 } 596 597 cluck("Starting EXPECT pattern matching...\r\n") 598 if ( $debug or $internal ); 599 my @ret; 600 @ret = _multi_expect( 601 $timeout, $timeout_hook, 602 map { [ $_, @{ $patterns{"$_"} } ] } @object_list 603 ); 604 605 if (@Expect::After_List) { 606 print STDERR ("Starting AFTER pattern matching...\r\n") 607 if ( $debug or $internal ); 608 _multi_expect( 0, undef, @Expect::After_List ); 609 } 610 611 return wantarray ? @ret : $ret[0]; 612} 613 614###################################################################### 615# the real workhorse 616# 617sub _multi_expect { 618 my ($timeout, $timeout_hook, @params) = @_; 619 620 if ($timeout_hook) { 621 croak "Unknown timeout_hook type $timeout_hook" 622 unless ( ref($timeout_hook) eq 'CODE' 623 or ref($timeout_hook) eq 'ARRAY' ); 624 } 625 626 foreach my $pat (@params) { 627 my @patterns = @{$pat}[ 1 .. $#{$pat} ]; 628 foreach my $exp ( @{ $pat->[0] } ) { 629 ${*$exp}{exp_New_Data} = 1; # first round we always try to match 630 if ( exists ${*$exp}{"exp_Max_Accum"} 631 and ${*$exp}{"exp_Max_Accum"} ) 632 { 633 ${*$exp}{exp_Accum} = $exp->_trim_length( 634 ${*$exp}{exp_Accum}, 635 ${*$exp}{exp_Max_Accum} 636 ); 637 } 638 print STDERR ( 639 "${*$exp}{exp_Pty_Handle}: beginning expect.\r\n", 640 "\tTimeout: ", 641 ( defined($timeout) ? $timeout : "unlimited" ), 642 " seconds.\r\n", 643 "\tCurrent time: " . localtime() . "\r\n", 644 ) if $Expect::Debug; 645 646 # What are we expecting? What do you expect? :-) 647 if ( ${*$exp}{exp_Exp_Internal} ) { 648 print STDERR "${*$exp}{exp_Pty_Handle}: list of patterns:\r\n"; 649 foreach my $pattern (@patterns) { 650 print STDERR ( 651 ' ', 652 defined( $pattern->[0] ) 653 ? '#' . $pattern->[0] . ': ' 654 : '', 655 $pattern->[1], 656 " `", 657 _make_readable( $pattern->[2] ), 658 "'\r\n" 659 ); 660 } 661 print STDERR "\r\n"; 662 } 663 } 664 } 665 666 my $successful_pattern; 667 my $exp_matched; 668 my $err; 669 my $before; 670 my $after; 671 my $match; 672 my @matchlist; 673 674 # Set the last loop time to now for time comparisons at end of loop. 675 my $start_loop_time = time(); 676 my $exp_cont = 1; 677 678 READLOOP: 679 while ($exp_cont) { 680 $exp_cont = 1; 681 $err = ""; 682 my $rmask = ''; 683 my $time_left = undef; 684 if ( defined $timeout ) { 685 $time_left = $timeout - ( time() - $start_loop_time ); 686 $time_left = 0 if $time_left < 0; 687 } 688 689 $exp_matched = undef; 690 691 # Test for a match first so we can test the current Accum w/out 692 # worrying about an EOF. 693 694 foreach my $pat (@params) { 695 my @patterns = @{$pat}[ 1 .. $#{$pat} ]; 696 foreach my $exp ( @{ $pat->[0] } ) { 697 698 # build mask for select in next section... 699 my $fn = $exp->fileno(); 700 vec( $rmask, $fn, 1 ) = 1 if defined $fn; 701 702 next unless ${*$exp}{exp_New_Data}; 703 704 # clear error status 705 ${*$exp}{exp_Error} = undef; 706 ${*$exp}{exp_After} = undef; 707 ${*$exp}{exp_Match_Number} = undef; 708 ${*$exp}{exp_Match} = undef; 709 710 # This could be huge. We should attempt to do something 711 # about this. Because the output is used for debugging 712 # I'm of the opinion that showing smaller amounts if the 713 # total is huge should be ok. 714 # Thus the 'trim_length' 715 print STDERR ( 716 "\r\n${*$exp}{exp_Pty_Handle}: Does `", 717 $exp->_trim_length( _make_readable( ${*$exp}{exp_Accum} ) ), 718 "'\r\nmatch:\r\n" 719 ) if ${*$exp}{exp_Exp_Internal}; 720 721 # we don't keep the parameter number anymore 722 # (clashes with before & after), instead the parameter number is 723 # stored inside the pattern; we keep the pattern ref 724 # and look up the number later. 725 foreach my $pattern (@patterns) { 726 print STDERR ( 727 " pattern", 728 defined( $pattern->[0] ) ? ' #' . $pattern->[0] : '', 729 ": ", 730 $pattern->[1], 731 " `", 732 _make_readable( $pattern->[2] ), 733 "'? " 734 ) if ( ${*$exp}{exp_Exp_Internal} ); 735 736 # Matching exactly 737 if ( $pattern->[1] eq '-ex' ) { 738 my $match_index = 739 index( ${*$exp}{exp_Accum}, $pattern->[2] ); 740 741 # We matched if $match_index > -1 742 if ( $match_index > -1 ) { 743 $before = 744 substr( ${*$exp}{exp_Accum}, 0, $match_index ); 745 $match = substr( 746 ${*$exp}{exp_Accum}, 747 $match_index, length( $pattern->[2] ) 748 ); 749 $after = substr( 750 ${*$exp}{exp_Accum}, 751 $match_index + length( $pattern->[2] ) 752 ); 753 ${*$exp}{exp_Before} = $before; 754 ${*$exp}{exp_Match} = $match; 755 ${*$exp}{exp_After} = $after; 756 ${*$exp}{exp_Match_Number} = $pattern->[0]; 757 $exp_matched = $exp; 758 } 759 } elsif ( $pattern->[1] eq '-re' ) { 760 761 if ($Expect::Multiline_Matching) { 762 @matchlist = 763 ( ${*$exp}{exp_Accum} =~ m/($pattern->[2])/m); 764 } else { 765 @matchlist = 766 ( ${*$exp}{exp_Accum} =~ m/($pattern->[2])/); 767 } 768 if (@matchlist) { 769 770 # Matching regexp 771 $match = shift @matchlist; 772 my $start = index ${*$exp}{exp_Accum}, $match; 773 die 'The match could not be found' if $start == -1; 774 $before = substr ${*$exp}{exp_Accum}, 0, $start; 775 $after = substr ${*$exp}{exp_Accum}, $start + length($match); 776 777 ${*$exp}{exp_Before} = $before; 778 ${*$exp}{exp_Match} = $match; 779 ${*$exp}{exp_After} = $after; 780 #pop @matchlist; # remove kludged empty bracket from end 781 @{ ${*$exp}{exp_Matchlist} } = @matchlist; 782 ${*$exp}{exp_Match_Number} = $pattern->[0]; 783 $exp_matched = $exp; 784 } 785 } else { 786 787 # 'timeout' or 'eof' 788 } 789 790 if ($exp_matched) { 791 ${*$exp}{exp_Accum} = $after 792 unless ${*$exp}{exp_NoTransfer}; 793 print STDERR "YES!!\r\n" 794 if ${*$exp}{exp_Exp_Internal}; 795 print STDERR ( 796 " Before match string: `", 797 $exp->_trim_length( _make_readable( ($before) ) ), 798 "'\r\n", 799 " Match string: `", 800 _make_readable($match), 801 "'\r\n", 802 " After match string: `", 803 $exp->_trim_length( _make_readable( ($after) ) ), 804 "'\r\n", 805 " Matchlist: (", 806 join( 807 ", ", 808 map { "`" . $exp->_trim_length( _make_readable( ($_) ) ) . "'" } @matchlist, 809 ), 810 ")\r\n", 811 ) if ( ${*$exp}{exp_Exp_Internal} ); 812 813 # call hook function if defined 814 if ( $pattern->[3] ) { 815 print STDERR ( 816 "Calling hook $pattern->[3]...\r\n", 817 ) 818 if ( ${*$exp}{exp_Exp_Internal} 819 or $Expect::Debug ); 820 if ( $#{$pattern} > 3 ) { 821 822 # call with parameters if given 823 $exp_cont = &{ $pattern->[3] }( $exp, @{$pattern}[ 4 .. $#{$pattern} ] ); 824 } else { 825 $exp_cont = &{ $pattern->[3] }($exp); 826 } 827 } 828 if ( $exp_cont and $exp_cont eq exp_continue ) { 829 print STDERR ("Continuing expect, restarting timeout...\r\n") 830 if ( ${*$exp}{exp_Exp_Internal} 831 or $Expect::Debug ); 832 $start_loop_time = time(); # restart timeout count 833 next READLOOP; 834 } elsif ( $exp_cont 835 and $exp_cont eq exp_continue_timeout ) 836 { 837 print STDERR ("Continuing expect...\r\n") 838 if ( ${*$exp}{exp_Exp_Internal} 839 or $Expect::Debug ); 840 next READLOOP; 841 } 842 last READLOOP; 843 } 844 print STDERR "No.\r\n" if ${*$exp}{exp_Exp_Internal}; 845 } 846 print STDERR "\r\n" if ${*$exp}{exp_Exp_Internal}; 847 848 # don't have to match again until we get new data 849 ${*$exp}{exp_New_Data} = 0; 850 } 851 } # End of matching section 852 853 # No match, let's see what is pending on the filehandles... 854 print STDERR ( 855 "Waiting for new data (", 856 defined($time_left) ? $time_left : 'unlimited', 857 " seconds)...\r\n", 858 ) if ( $Expect::Exp_Internal or $Expect::Debug ); 859 my $nfound; 860 SELECT: { 861 $nfound = select( $rmask, undef, undef, $time_left ); 862 if ( $nfound < 0 ) { 863 if ( $!{EINTR} and $Expect::IgnoreEintr ) { 864 print STDERR ("ignoring EINTR, restarting select()...\r\n") 865 if ( $Expect::Exp_Internal or $Expect::Debug ); 866 next SELECT; 867 } 868 print STDERR ("select() returned error code '$!'\r\n") 869 if ( $Expect::Exp_Internal or $Expect::Debug ); 870 871 # returned error 872 $err = "4:$!"; 873 last READLOOP; 874 } 875 } 876 877 # go until we don't find something (== timeout). 878 if ( $nfound == 0 ) { 879 880 # No pattern, no EOF. Did we time out? 881 $err = "1:TIMEOUT"; 882 foreach my $pat (@params) { 883 foreach my $exp ( @{ $pat->[0] } ) { 884 $before = ${*$exp}{exp_Before} = ${*$exp}{exp_Accum}; 885 next if not defined $exp->fileno(); # skip already closed 886 ${*$exp}{exp_Error} = $err unless ${*$exp}{exp_Error}; 887 } 888 } 889 print STDERR ("TIMEOUT\r\n") 890 if ( $Expect::Debug or $Expect::Exp_Internal ); 891 if ($timeout_hook) { 892 my $ret; 893 print STDERR ("Calling timeout function $timeout_hook...\r\n") 894 if ( $Expect::Debug or $Expect::Exp_Internal ); 895 if ( ref($timeout_hook) eq 'CODE' ) { 896 $ret = &{$timeout_hook}( $params[0]->[0] ); 897 } else { 898 if ( $#{$timeout_hook} > 3 ) { 899 $ret = &{ $timeout_hook->[3] }( 900 $params[0]->[0], 901 @{$timeout_hook}[ 4 .. $#{$timeout_hook} ] 902 ); 903 } else { 904 $ret = &{ $timeout_hook->[3] }( $params[0]->[0] ); 905 } 906 } 907 if ( $ret and $ret eq exp_continue ) { 908 $start_loop_time = time(); # restart timeout count 909 next READLOOP; 910 } 911 } 912 last READLOOP; 913 } 914 915 my @bits = split( //, unpack( 'b*', $rmask ) ); 916 foreach my $pat (@params) { 917 foreach my $exp ( @{ $pat->[0] } ) { 918 next if not defined $exp->fileno(); # skip already closed 919 if ( $bits[ $exp->fileno() ] ) { 920 print STDERR ("${*$exp}{exp_Pty_Handle}: new data.\r\n") 921 if $Expect::Debug; 922 923 # read in what we found. 924 my $buffer; 925 my $nread = sysread( $exp, $buffer, 2048 ); 926 927 # Make errors (nread undef) show up as EOF. 928 $nread = 0 unless defined($nread); 929 930 if ( $nread == 0 ) { 931 print STDERR ("${*$exp}{exp_Pty_Handle}: EOF\r\n") 932 if ($Expect::Debug); 933 $before = ${*$exp}{exp_Before} = $exp->clear_accum(); 934 $err = "2:EOF"; 935 ${*$exp}{exp_Error} = $err; 936 ${*$exp}{exp_Has_EOF} = 1; 937 $exp_cont = undef; 938 foreach my $eof_pat ( grep { $_->[1] eq '-eof' } @{$pat}[ 1 .. $#{$pat} ] ) { 939 my $ret; 940 print STDERR ( "Calling EOF hook $eof_pat->[3]...\r\n", ) 941 if ($Expect::Debug); 942 if ( $#{$eof_pat} > 3 ) { 943 944 # call with parameters if given 945 $ret = &{ $eof_pat->[3] }( $exp, @{$eof_pat}[ 4 .. $#{$eof_pat} ] ); 946 } else { 947 $ret = &{ $eof_pat->[3] }($exp); 948 } 949 if ($ret 950 and ( $ret eq exp_continue 951 or $ret eq exp_continue_timeout ) 952 ) 953 { 954 $exp_cont = $ret; 955 } 956 } 957 958 # is it dead? 959 if ( defined( ${*$exp}{exp_Pid} ) ) { 960 my $ret = 961 waitpid( ${*$exp}{exp_Pid}, POSIX::WNOHANG ); 962 if ( $ret == ${*$exp}{exp_Pid} ) { 963 printf STDERR ( 964 "%s: exit(0x%02X)\r\n", 965 ${*$exp}{exp_Pty_Handle}, $? 966 ) if ($Expect::Debug); 967 $err = "3:Child PID ${*$exp}{exp_Pid} exited with status $?"; 968 ${*$exp}{exp_Error} = $err; 969 ${*$exp}{exp_Exit} = $?; 970 delete $Expect::Spawned_PIDs{ ${*$exp}{exp_Pid} }; 971 ${*$exp}{exp_Pid} = undef; 972 } 973 } 974 print STDERR ("${*$exp}{exp_Pty_Handle}: closing...\r\n") 975 if ($Expect::Debug); 976 $exp->hard_close(); 977 next; 978 } 979 print STDERR ("${*$exp}{exp_Pty_Handle}: read $nread byte(s).\r\n") 980 if ($Expect::Debug); 981 982 # ugly hack for broken solaris ttys that spew <blank><backspace> 983 # into our pretty output 984 $buffer =~ s/ \cH//g if not ${*$exp}{exp_Raw_Pty}; 985 986 # Append it to the accumulator. 987 ${*$exp}{exp_Accum} .= $buffer; 988 if ( exists ${*$exp}{exp_Max_Accum} 989 and ${*$exp}{exp_Max_Accum} ) 990 { 991 ${*$exp}{exp_Accum} = $exp->_trim_length( 992 ${*$exp}{exp_Accum}, 993 ${*$exp}{exp_Max_Accum} 994 ); 995 } 996 ${*$exp}{exp_New_Data} = 1; # next round we try to match again 997 998 $exp_cont = exp_continue 999 if ( exists ${*$exp}{exp_Continue} 1000 and ${*$exp}{exp_Continue} ); 1001 1002 # Now propagate what we have read to other listeners... 1003 $exp->_print_handles($buffer); 1004 1005 # End handle reading section. 1006 } 1007 } 1008 } # end read loop 1009 $start_loop_time = time() # restart timeout count 1010 if ( $exp_cont and $exp_cont eq exp_continue ); 1011 } 1012 1013 # End READLOOP 1014 1015 # Post loop. Do we have anything? 1016 # Tell us status 1017 if ( $Expect::Debug or $Expect::Exp_Internal ) { 1018 if ($exp_matched) { 1019 print STDERR ( 1020 "Returning from expect ", 1021 ${*$exp_matched}{exp_Error} ? 'un' : '', 1022 "successfully.", 1023 ${*$exp_matched}{exp_Error} 1024 ? "\r\n Error: ${*$exp_matched}{exp_Error}." 1025 : '', 1026 "\r\n" 1027 ); 1028 } else { 1029 print STDERR ("Returning from expect with TIMEOUT or EOF\r\n"); 1030 } 1031 if ( $Expect::Debug and $exp_matched ) { 1032 print STDERR " ${*$exp_matched}{exp_Pty_Handle}: accumulator: `"; 1033 if ( ${*$exp_matched}{exp_Error} ) { 1034 print STDERR ( 1035 $exp_matched->_trim_length( _make_readable( ${*$exp_matched}{exp_Before} ) ), 1036 "'\r\n" 1037 ); 1038 } else { 1039 print STDERR ( 1040 $exp_matched->_trim_length( _make_readable( ${*$exp_matched}{exp_Accum} ) ), 1041 "'\r\n" 1042 ); 1043 } 1044 } 1045 } 1046 1047 if ($exp_matched) { 1048 return wantarray 1049 ? ( 1050 ${*$exp_matched}{exp_Match_Number}, ${*$exp_matched}{exp_Error}, 1051 ${*$exp_matched}{exp_Match}, ${*$exp_matched}{exp_Before}, 1052 ${*$exp_matched}{exp_After}, $exp_matched, 1053 ) 1054 : ${*$exp_matched}{exp_Match_Number}; 1055 } 1056 1057 return wantarray ? ( undef, $err, undef, $before, undef, undef ) : undef; 1058} 1059 1060# Patterns are arrays that consist of 1061# [ $pattern_type, $pattern, $sub, @subparms ] 1062# optional $pattern_type is '-re' (RegExp, default) or '-ex' (exact); 1063# $sub is optional CODE ref, which is called as &{$sub}($exp, @subparms) 1064# if pattern matched; 1065# the $parm_nr gets unshifted onto the array for reporting purposes. 1066 1067sub _add_patterns_to_list { 1068 my ($listref, $timeoutlistref,$store_parm_nr, @params) = @_; 1069 1070 # $timeoutlistref gets timeout patterns 1071 my $parm_nr = $store_parm_nr || 1; 1072 foreach my $parm (@params) { 1073 if ( not ref($parm) eq 'ARRAY' ) { 1074 return "Parameter #$parm_nr is not an ARRAY ref."; 1075 } 1076 $parm = [@$parm]; # make copy 1077 if ( $parm->[0] =~ m/\A-/ ) { 1078 1079 # it's an option 1080 if ( $parm->[0] ne '-re' 1081 and $parm->[0] ne '-ex' ) 1082 { 1083 return "Unknown option $parm->[0] in pattern #$parm_nr"; 1084 } 1085 } else { 1086 if ( $parm->[0] eq 'timeout' ) { 1087 if ( defined $timeoutlistref ) { 1088 splice @$parm, 0, 1, ( "-$parm->[0]", undef ); 1089 unshift @$parm, $store_parm_nr ? $parm_nr : undef; 1090 push @$timeoutlistref, $parm; 1091 } 1092 next; 1093 } elsif ( $parm->[0] eq 'eof' ) { 1094 splice @$parm, 0, 1, ( "-$parm->[0]", undef ); 1095 } else { 1096 unshift @$parm, '-re'; # defaults to RegExp 1097 } 1098 } 1099 if ( @$parm > 2 ) { 1100 if ( ref( $parm->[2] ) ne 'CODE' ) { 1101 croak( 1102 "Pattern #$parm_nr doesn't have a CODE reference", 1103 "after the pattern." 1104 ); 1105 } 1106 } else { 1107 push @$parm, undef; # make sure we have three elements 1108 } 1109 1110 unshift @$parm, $store_parm_nr ? $parm_nr : undef; 1111 push @$listref, $parm; 1112 $parm_nr++; 1113 } 1114 1115 return; 1116} 1117 1118###################################################################### 1119# $process->interact([$in_handle],[$escape sequence]) 1120# If you don't specify in_handle STDIN will be used. 1121sub interact { 1122 my ($self, $infile, $escape_sequence) = @_; 1123 1124 my $outfile; 1125 my @old_group = $self->set_group(); 1126 1127 # If the handle is STDIN we'll 1128 # $infile->fileno == 0 should be stdin.. follow stdin rules. 1129 no strict 'subs'; # Allow bare word 'STDIN' 1130 unless ( defined($infile) ) { 1131 # We need a handle object Associated with STDIN. 1132 $infile = IO::File->new; 1133 $infile->IO::File::fdopen( STDIN, 'r' ); 1134 $outfile = IO::File->new; 1135 $outfile->IO::File::fdopen( STDOUT, 'w' ); 1136 } elsif ( fileno($infile) == fileno(STDIN) ) { 1137 1138 # With STDIN we want output to go to stdout. 1139 $outfile = IO::File->new; 1140 $outfile->IO::File::fdopen( STDOUT, 'w' ); 1141 } else { 1142 undef($outfile); 1143 } 1144 1145 # Here we assure ourselves we have an Expect object. 1146 my $in_object = Expect->exp_init($infile); 1147 if ( defined($outfile) ) { 1148 1149 # as above.. we want output to go to stdout if we're given stdin. 1150 my $out_object = Expect->exp_init($outfile); 1151 $out_object->manual_stty(1); 1152 $self->set_group($out_object); 1153 } else { 1154 $self->set_group($in_object); 1155 } 1156 $in_object->set_group($self); 1157 $in_object->set_seq( $escape_sequence, undef ) if defined($escape_sequence); 1158 1159 # interconnect normally sets stty -echo raw. Interact really sort 1160 # of implies we don't do that by default. If anyone wanted to they could 1161 # set it before calling interact, of use interconnect directly. 1162 my $old_manual_stty_val = $self->manual_stty(); 1163 $self->manual_stty(1); 1164 1165 # I think this is right. Don't send stuff from in_obj to stdout by default. 1166 # in theory whatever 'self' is should echo what's going on. 1167 my $old_log_stdout_val = $self->log_stdout(); 1168 $self->log_stdout(0); 1169 $in_object->log_stdout(0); 1170 1171 # Allow for the setting of an optional EOF escape function. 1172 # $in_object->set_seq('EOF',undef); 1173 # $self->set_seq('EOF',undef); 1174 Expect::interconnect( $self, $in_object ); 1175 $self->log_stdout($old_log_stdout_val); 1176 $self->set_group(@old_group); 1177 1178 # If old_group was undef, make sure that occurs. This is a slight hack since 1179 # it modifies the value directly. 1180 # Normally an undef passed to set_group will return the current groups. 1181 # It is possible that it may be of worth to make it possible to undef 1182 # The current group without doing this. 1183 unless (@old_group) { 1184 @{ ${*$self}{exp_Listen_Group} } = (); 1185 } 1186 $self->manual_stty($old_manual_stty_val); 1187 1188 return; 1189} 1190 1191sub interconnect { 1192 my (@handles) = @_; 1193 1194 # my ($handle)=(shift); call as Expect::interconnect($spawn1,$spawn2,...) 1195 my ( $nread ); 1196 my ( $rout, $emask, $eout ); 1197 my ( $escape_character_buffer ); 1198 my ( $read_mask, $temp_mask ) = ( '', '' ); 1199 1200 # Get read/write handles 1201 foreach my $handle (@handles) { 1202 $temp_mask = ''; 1203 vec( $temp_mask, $handle->fileno(), 1 ) = 1; 1204 1205 # Under Linux w/ 5.001 the next line comes up w/ 'Uninit var.'. 1206 # It appears to be impossible to make the warning go away. 1207 # doing something like $temp_mask='' unless defined ($temp_mask) 1208 # has no effect whatsoever. This may be a bug in 5.001. 1209 $read_mask = $read_mask | $temp_mask; 1210 } 1211 if ($Expect::Debug) { 1212 print STDERR "Read handles:\r\n"; 1213 foreach my $handle (@handles) { 1214 print STDERR "\tRead handle: "; 1215 print STDERR "'${*$handle}{exp_Pty_Handle}'\r\n"; 1216 print STDERR "\t\tListen Handles:"; 1217 foreach my $write_handle ( @{ ${*$handle}{exp_Listen_Group} } ) { 1218 print STDERR " '${*$write_handle}{exp_Pty_Handle}'"; 1219 } 1220 print STDERR ".\r\n"; 1221 } 1222 } 1223 1224 # I think if we don't set raw/-echo here we may have trouble. We don't 1225 # want a bunch of echoing crap making all the handles jabber at each other. 1226 foreach my $handle (@handles) { 1227 unless ( ${*$handle}{"exp_Manual_Stty"} ) { 1228 1229 # This is probably O/S specific. 1230 ${*$handle}{exp_Stored_Stty} = $handle->exp_stty('-g'); 1231 print STDERR "Setting tty for ${*$handle}{exp_Pty_Handle} to 'raw -echo'.\r\n" 1232 if ${*$handle}{"exp_Debug"}; 1233 $handle->exp_stty("raw -echo"); 1234 } 1235 foreach my $write_handle ( @{ ${*$handle}{exp_Listen_Group} } ) { 1236 unless ( ${*$write_handle}{"exp_Manual_Stty"} ) { 1237 ${*$write_handle}{exp_Stored_Stty} = 1238 $write_handle->exp_stty('-g'); 1239 print STDERR "Setting ${*$write_handle}{exp_Pty_Handle} to 'raw -echo'.\r\n" 1240 if ${*$handle}{"exp_Debug"}; 1241 $write_handle->exp_stty("raw -echo"); 1242 } 1243 } 1244 } 1245 1246 print STDERR "Attempting interconnection\r\n" if $Expect::Debug; 1247 1248 # Wait until the process dies or we get EOF 1249 # In the case of !${*$handle}{exp_Pid} it means 1250 # the handle was exp_inited instead of spawned. 1251 CONNECT_LOOP: 1252 1253 # Go until we have a reason to stop 1254 while (1) { 1255 1256 # test each handle to see if it's still alive. 1257 foreach my $read_handle (@handles) { 1258 waitpid( ${*$read_handle}{exp_Pid}, WNOHANG ) 1259 if ( exists( ${*$read_handle}{exp_Pid} ) 1260 and ${*$read_handle}{exp_Pid} ); 1261 if ( exists( ${*$read_handle}{exp_Pid} ) 1262 and ( ${*$read_handle}{exp_Pid} ) 1263 and ( !kill( 0, ${*$read_handle}{exp_Pid} ) ) ) 1264 { 1265 print STDERR 1266 "Got EOF (${*$read_handle}{exp_Pty_Handle} died) reading ${*$read_handle}{exp_Pty_Handle}\r\n" 1267 if ${*$read_handle}{"exp_Debug"}; 1268 last CONNECT_LOOP 1269 unless defined( ${ ${*$read_handle}{exp_Function} }{"EOF"} ); 1270 last CONNECT_LOOP 1271 unless &{ ${ ${*$read_handle}{exp_Function} }{"EOF"} } 1272 ( @{ ${ ${*$read_handle}{exp_Parameters} }{"EOF"} } ); 1273 } 1274 } 1275 1276 # Every second? No, go until we get something from someone. 1277 my $nfound = select( $rout = $read_mask, undef, $eout = $emask, undef ); 1278 1279 # Is there anything to share? May be -1 if interrupted by a signal... 1280 next CONNECT_LOOP if not defined $nfound or $nfound < 1; 1281 1282 # Which handles have stuff? 1283 my @bits = split( //, unpack( 'b*', $rout ) ); 1284 $eout = 0 unless defined($eout); 1285 my @ebits = split( //, unpack( 'b*', $eout ) ); 1286 1287 # print "Ebits: $eout\r\n"; 1288 foreach my $read_handle (@handles) { 1289 if ( $bits[ $read_handle->fileno() ] ) { 1290 $nread = sysread( 1291 $read_handle, ${*$read_handle}{exp_Pty_Buffer}, 1292 1024 1293 ); 1294 1295 # Appease perl -w 1296 $nread = 0 unless defined($nread); 1297 print STDERR "interconnect: read $nread byte(s) from ${*$read_handle}{exp_Pty_Handle}.\r\n" 1298 if ${*$read_handle}{"exp_Debug"} > 1; 1299 1300 # Test for escape seq. before printing. 1301 # Appease perl -w 1302 $escape_character_buffer = '' 1303 unless defined($escape_character_buffer); 1304 $escape_character_buffer .= ${*$read_handle}{exp_Pty_Buffer}; 1305 foreach my $escape_sequence ( keys( %{ ${*$read_handle}{exp_Function} } ) ) { 1306 print STDERR "Tested escape sequence $escape_sequence from ${*$read_handle}{exp_Pty_Handle}" 1307 if ${*$read_handle}{"exp_Debug"} > 1; 1308 1309 # Make sure it doesn't grow out of bounds. 1310 $escape_character_buffer = $read_handle->_trim_length( 1311 $escape_character_buffer, 1312 ${*$read_handle}{"exp_Max_Accum"} 1313 ) if ( ${*$read_handle}{"exp_Max_Accum"} ); 1314 if ( $escape_character_buffer =~ /($escape_sequence)/ ) { 1315 my $match = $1; 1316 if ( ${*$read_handle}{"exp_Debug"} ) { 1317 print STDERR 1318 "\r\ninterconnect got escape sequence from ${*$read_handle}{exp_Pty_Handle}.\r\n"; 1319 1320 # I'm going to make the esc. seq. pretty because it will 1321 # probably contain unprintable characters. 1322 print STDERR "\tEscape Sequence: '" 1323 . _trim_length( 1324 undef, 1325 _make_readable($escape_sequence) 1326 ) . "'\r\n"; 1327 print STDERR "\tMatched by string: '" . _trim_length( undef, _make_readable($match) ) . "'\r\n"; 1328 } 1329 1330 # Print out stuff before the escape. 1331 # Keep in mind that the sequence may have been split up 1332 # over several reads. 1333 # Let's get rid of it from this read. If part of it was 1334 # in the last read there's not a lot we can do about it now. 1335 if ( ${*$read_handle}{exp_Pty_Buffer} =~ /([\w\W]*)($escape_sequence)/ ) { 1336 $read_handle->_print_handles($1); 1337 } else { 1338 $read_handle->_print_handles( ${*$read_handle}{exp_Pty_Buffer} ); 1339 } 1340 1341 # Clear the buffer so no more matches can be made and it will 1342 # only be printed one time. 1343 ${*$read_handle}{exp_Pty_Buffer} = ''; 1344 $escape_character_buffer = ''; 1345 1346 # Do the function here. Must return non-zero to continue. 1347 # More cool syntax. Maybe I should turn these in to objects. 1348 last CONNECT_LOOP 1349 unless &{ ${ ${*$read_handle}{exp_Function} }{$escape_sequence} } 1350 ( @{ ${ ${*$read_handle}{exp_Parameters} }{$escape_sequence} } ); 1351 } 1352 } 1353 $nread = 0 unless defined($nread); # Appease perl -w? 1354 waitpid( ${*$read_handle}{exp_Pid}, WNOHANG ) 1355 if ( defined( ${*$read_handle}{exp_Pid} ) 1356 && ${*$read_handle}{exp_Pid} ); 1357 if ( $nread == 0 ) { 1358 print STDERR "Got EOF reading ${*$read_handle}{exp_Pty_Handle}\r\n" 1359 if ${*$read_handle}{"exp_Debug"}; 1360 last CONNECT_LOOP 1361 unless defined( ${ ${*$read_handle}{exp_Function} }{"EOF"} ); 1362 last CONNECT_LOOP 1363 unless &{ ${ ${*$read_handle}{exp_Function} }{"EOF"} } 1364 ( @{ ${ ${*$read_handle}{exp_Parameters} }{"EOF"} } ); 1365 } 1366 last CONNECT_LOOP if ( $nread < 0 ); # This would be an error 1367 $read_handle->_print_handles( ${*$read_handle}{exp_Pty_Buffer} ); 1368 } 1369 1370 # I'm removing this because I haven't determined what causes exceptions 1371 # consistently. 1372 if (0) #$ebits[$read_handle->fileno()]) 1373 { 1374 print STDERR "Got Exception reading ${*$read_handle}{exp_Pty_Handle}\r\n" 1375 if ${*$read_handle}{"exp_Debug"}; 1376 last CONNECT_LOOP 1377 unless defined( ${ ${*$read_handle}{exp_Function} }{"EOF"} ); 1378 last CONNECT_LOOP 1379 unless &{ ${ ${*$read_handle}{exp_Function} }{"EOF"} } 1380 ( @{ ${ ${*$read_handle}{exp_Parameters} }{"EOF"} } ); 1381 } 1382 } 1383 } 1384 foreach my $handle (@handles) { 1385 unless ( ${*$handle}{"exp_Manual_Stty"} ) { 1386 $handle->exp_stty( ${*$handle}{exp_Stored_Stty} ); 1387 } 1388 foreach my $write_handle ( @{ ${*$handle}{exp_Listen_Group} } ) { 1389 unless ( ${*$write_handle}{"exp_Manual_Stty"} ) { 1390 $write_handle->exp_stty( ${*$write_handle}{exp_Stored_Stty} ); 1391 } 1392 } 1393 } 1394 1395 return; 1396} 1397 1398# user can decide if log output gets also sent to logfile 1399sub print_log_file { 1400 my ($self, @params) = @_; 1401 1402 if ( ${*$self}{exp_Log_File} ) { 1403 if ( ref( ${*$self}{exp_Log_File} ) eq 'CODE' ) { 1404 ${*$self}{exp_Log_File}->(@params); 1405 } else { 1406 ${*$self}{exp_Log_File}->print(@params); 1407 } 1408 } 1409 1410 return; 1411} 1412 1413# we provide our own print so we can debug what gets sent to the 1414# processes... 1415sub print { 1416 my ( $self, @args ) = @_; 1417 1418 return if not defined $self->fileno(); # skip if closed 1419 if ( ${*$self}{exp_Exp_Internal} ) { 1420 my $args = _make_readable( join( '', @args ) ); 1421 cluck "Sending '$args' to ${*$self}{exp_Pty_Handle}\r\n"; 1422 } 1423 foreach my $arg (@args) { 1424 while ( length($arg) > 80 ) { 1425 $self->SUPER::print( substr( $arg, 0, 80 ) ); 1426 $arg = substr( $arg, 80 ); 1427 } 1428 $self->SUPER::print($arg); 1429 } 1430 1431 return; 1432} 1433 1434# make an alias for Tcl/Expect users for a DWIM experience... 1435*send = \&print; 1436 1437# This is an Expect standard. It's nice for talking to modems and the like 1438# where from time to time they get unhappy if you send items too quickly. 1439sub send_slow { 1440 my ($self, $sleep_time, @chunks) = @_; 1441 1442 return if not defined $self->fileno(); # skip if closed 1443 1444 # Flushing makes it so each character can be seen separately. 1445 my $chunk; 1446 while ( $chunk = shift @chunks ) { 1447 my @linechars = split( '', $chunk ); 1448 foreach my $char (@linechars) { 1449 1450 # How slow? 1451 select( undef, undef, undef, $sleep_time ); 1452 1453 print $self $char; 1454 print STDERR "Printed character \'" . _make_readable($char) . "\' to ${*$self}{exp_Pty_Handle}.\r\n" 1455 if ${*$self}{"exp_Debug"} > 1; 1456 1457 # I think I can get away with this if I save it in accum 1458 if ( ${*$self}{"exp_Log_Stdout"} || ${*$self}{exp_Log_Group} ) { 1459 my $rmask = ""; 1460 vec( $rmask, $self->fileno(), 1 ) = 1; 1461 1462 # .01 sec granularity should work. If we miss something it will 1463 # probably get flushed later, maybe in an expect call. 1464 while ( select( $rmask, undef, undef, .01 ) ) { 1465 my $ret = sysread( $self, ${*$self}{exp_Pty_Buffer}, 1024 ); 1466 last if not defined $ret or $ret == 0; 1467 1468 # Is this necessary to keep? Probably.. # 1469 # if you need to expect it later. 1470 ${*$self}{exp_Accum} .= ${*$self}{exp_Pty_Buffer}; 1471 ${*$self}{exp_Accum} = $self->_trim_length( 1472 ${*$self}{exp_Accum}, 1473 ${*$self}{"exp_Max_Accum"} 1474 ) if ( ${*$self}{"exp_Max_Accum"} ); 1475 $self->_print_handles( ${*$self}{exp_Pty_Buffer} ); 1476 print STDERR "Received \'" 1477 . $self->_trim_length( _make_readable($char) ) 1478 . "\' from ${*$self}{exp_Pty_Handle}\r\n" 1479 if ${*$self}{"exp_Debug"} > 1; 1480 } 1481 } 1482 } 1483 } 1484 1485 return; 1486} 1487 1488sub test_handles { 1489 my ($timeout, @handle_list) = @_; 1490 1491 # This should be called by Expect::test_handles($timeout,@objects); 1492 my ( $allmask, $rout ); 1493 foreach my $handle (@handle_list) { 1494 my $rmask = ''; 1495 vec( $rmask, $handle->fileno(), 1 ) = 1; 1496 $allmask = '' unless defined($allmask); 1497 $allmask = $allmask | $rmask; 1498 } 1499 my $nfound = select( $rout = $allmask, undef, undef, $timeout ); 1500 return () unless $nfound; 1501 1502 # Which handles have stuff? 1503 my @bits = split( //, unpack( 'b*', $rout ) ); 1504 1505 my $handle_num = 0; 1506 my @return_list = (); 1507 foreach my $handle (@handle_list) { 1508 1509 # I go to great lengths to get perl -w to shut the hell up. 1510 if ( defined( $bits[ $handle->fileno() ] ) 1511 and ( $bits[ $handle->fileno() ] ) ) 1512 { 1513 push( @return_list, $handle_num ); 1514 } 1515 } continue { 1516 $handle_num++; 1517 } 1518 1519 return @return_list; 1520} 1521 1522# Be nice close. This should emulate what an interactive shell does after a 1523# command finishes... sort of. We're not as patient as a shell. 1524sub soft_close { 1525 my ($self) = @_; 1526 1527 my ( $nfound, $nread, $rmask, $end_time, $temp_buffer ); 1528 1529 # Give it 15 seconds to cough up an eof. 1530 cluck "Closing ${*$self}{exp_Pty_Handle}.\r\n" if ${*$self}{exp_Debug}; 1531 return -1 if not defined $self->fileno(); # skip if handle already closed 1532 unless ( exists ${*$self}{exp_Has_EOF} and ${*$self}{exp_Has_EOF} ) { 1533 $end_time = time() + 15; 1534 while ( $end_time > time() ) { 1535 my $select_time = $end_time - time(); 1536 1537 # Sanity check. 1538 $select_time = 0 if $select_time < 0; 1539 $rmask = ''; 1540 vec( $rmask, $self->fileno(), 1 ) = 1; 1541 ($nfound) = select( $rmask, undef, undef, $select_time ); 1542 last unless ( defined($nfound) && $nfound ); 1543 $nread = sysread( $self, $temp_buffer, 8096 ); 1544 1545 # 0 = EOF. 1546 unless ( defined($nread) && $nread ) { 1547 print STDERR "Got EOF from ${*$self}{exp_Pty_Handle}.\r\n" 1548 if ${*$self}{exp_Debug}; 1549 last; 1550 } 1551 $self->_print_handles($temp_buffer); 1552 } 1553 if ( ( $end_time <= time() ) && ${*$self}{exp_Debug} ) { 1554 print STDERR "Timed out waiting for an EOF from ${*$self}{exp_Pty_Handle}.\r\n"; 1555 } 1556 } 1557 my $close_status = $self->close(); 1558 if ( $close_status && ${*$self}{exp_Debug} ) { 1559 print STDERR "${*$self}{exp_Pty_Handle} closed.\r\n"; 1560 } 1561 1562 # quit now if it isn't a process. 1563 return $close_status unless defined( ${*$self}{exp_Pid} ); 1564 1565 # Now give it 15 seconds to die. 1566 $end_time = time() + 15; 1567 while ( $end_time > time() ) { 1568 my $returned_pid = waitpid( ${*$self}{exp_Pid}, &WNOHANG ); 1569 1570 # Stop here if the process dies. 1571 if ( defined($returned_pid) && $returned_pid ) { 1572 delete $Expect::Spawned_PIDs{$returned_pid}; 1573 if ( ${*$self}{exp_Debug} ) { 1574 printf STDERR ( 1575 "Pid %d of %s exited, Status: 0x%02X\r\n", 1576 ${*$self}{exp_Pid}, 1577 ${*$self}{exp_Pty_Handle}, $? 1578 ); 1579 } 1580 ${*$self}{exp_Pid} = undef; 1581 ${*$self}{exp_Exit} = $?; 1582 return ${*$self}{exp_Exit}; 1583 } 1584 sleep 1; # Keep loop nice. 1585 } 1586 1587 # Send it a term if it isn't dead. 1588 if ( ${*$self}{exp_Debug} ) { 1589 print STDERR "${*$self}{exp_Pty_Handle} not exiting, sending TERM.\r\n"; 1590 } 1591 kill TERM => ${*$self}{exp_Pid}; 1592 1593 # Now to be anal retentive.. wait 15 more seconds for it to die. 1594 $end_time = time() + 15; 1595 while ( $end_time > time() ) { 1596 my $returned_pid = waitpid( ${*$self}{exp_Pid}, &WNOHANG ); 1597 if ( defined($returned_pid) && $returned_pid ) { 1598 delete $Expect::Spawned_PIDs{$returned_pid}; 1599 if ( ${*$self}{exp_Debug} ) { 1600 printf STDERR ( 1601 "Pid %d of %s terminated, Status: 0x%02X\r\n", 1602 ${*$self}{exp_Pid}, 1603 ${*$self}{exp_Pty_Handle}, $? 1604 ); 1605 } 1606 ${*$self}{exp_Pid} = undef; 1607 ${*$self}{exp_Exit} = $?; 1608 return $?; 1609 } 1610 sleep 1; 1611 } 1612 1613 # Since this is a 'soft' close, sending it a -9 would be inappropriate. 1614 return; 1615} 1616 1617# 'Make it go away' close. 1618sub hard_close { 1619 my ($self) = @_; 1620 1621 cluck "Closing ${*$self}{exp_Pty_Handle}.\r\n" if ${*$self}{exp_Debug}; 1622 1623 # Don't wait for an EOF. 1624 my $close_status = $self->close(); 1625 if ( $close_status && ${*$self}{exp_Debug} ) { 1626 print STDERR "${*$self}{exp_Pty_Handle} closed.\r\n"; 1627 } 1628 1629 # Return now if handle. 1630 return $close_status unless defined( ${*$self}{exp_Pid} ); 1631 1632 # Now give it 5 seconds to die. Less patience here if it won't die. 1633 my $end_time = time() + 5; 1634 while ( $end_time > time() ) { 1635 my $returned_pid = waitpid( ${*$self}{exp_Pid}, &WNOHANG ); 1636 1637 # Stop here if the process dies. 1638 if ( defined($returned_pid) && $returned_pid ) { 1639 delete $Expect::Spawned_PIDs{$returned_pid}; 1640 if ( ${*$self}{exp_Debug} ) { 1641 printf STDERR ( 1642 "Pid %d of %s terminated, Status: 0x%02X\r\n", 1643 ${*$self}{exp_Pid}, 1644 ${*$self}{exp_Pty_Handle}, $? 1645 ); 1646 } 1647 ${*$self}{exp_Pid} = undef; 1648 ${*$self}{exp_Exit} = $?; 1649 return ${*$self}{exp_Exit}; 1650 } 1651 sleep 1; # Keep loop nice. 1652 } 1653 1654 # Send it a term if it isn't dead. 1655 if ( ${*$self}{exp_Debug} ) { 1656 print STDERR "${*$self}{exp_Pty_Handle} not exiting, sending TERM.\r\n"; 1657 } 1658 kill TERM => ${*$self}{exp_Pid}; 1659 1660 # wait 15 more seconds for it to die. 1661 $end_time = time() + 15; 1662 while ( $end_time > time() ) { 1663 my $returned_pid = waitpid( ${*$self}{exp_Pid}, &WNOHANG ); 1664 if ( defined($returned_pid) && $returned_pid ) { 1665 delete $Expect::Spawned_PIDs{$returned_pid}; 1666 if ( ${*$self}{exp_Debug} ) { 1667 printf STDERR ( 1668 "Pid %d of %s terminated, Status: 0x%02X\r\n", 1669 ${*$self}{exp_Pid}, 1670 ${*$self}{exp_Pty_Handle}, $? 1671 ); 1672 } 1673 ${*$self}{exp_Pid} = undef; 1674 ${*$self}{exp_Exit} = $?; 1675 return ${*$self}{exp_Exit}; 1676 } 1677 sleep 1; 1678 } 1679 kill KILL => ${*$self}{exp_Pid}; 1680 1681 # wait 5 more seconds for it to die. 1682 $end_time = time() + 5; 1683 while ( $end_time > time() ) { 1684 my $returned_pid = waitpid( ${*$self}{exp_Pid}, &WNOHANG ); 1685 if ( defined($returned_pid) && $returned_pid ) { 1686 delete $Expect::Spawned_PIDs{$returned_pid}; 1687 if ( ${*$self}{exp_Debug} ) { 1688 printf STDERR ( 1689 "Pid %d of %s killed, Status: 0x%02X\r\n", 1690 ${*$self}{exp_Pid}, 1691 ${*$self}{exp_Pty_Handle}, $? 1692 ); 1693 } 1694 ${*$self}{exp_Pid} = undef; 1695 ${*$self}{exp_Exit} = $?; 1696 return ${*$self}{exp_Exit}; 1697 } 1698 sleep 1; 1699 } 1700 warn "Pid ${*$self}{exp_Pid} of ${*$self}{exp_Pty_Handle} is HUNG.\r\n"; 1701 ${*$self}{exp_Pid} = undef; 1702 1703 return; 1704} 1705 1706# These should not be called externally. 1707 1708sub _init_vars { 1709 my ($self) = @_; 1710 1711 # for every spawned process or filehandle. 1712 ${*$self}{exp_Log_Stdout} = $Expect::Log_Stdout 1713 if defined($Expect::Log_Stdout); 1714 ${*$self}{exp_Log_Group} = $Expect::Log_Group; 1715 ${*$self}{exp_Debug} = $Expect::Debug; 1716 ${*$self}{exp_Exp_Internal} = $Expect::Exp_Internal; 1717 ${*$self}{exp_Manual_Stty} = $Expect::Manual_Stty; 1718 ${*$self}{exp_Stored_Stty} = 'sane'; 1719 ${*$self}{exp_Do_Soft_Close} = $Expect::Do_Soft_Close; 1720 1721 # sysread doesn't like my or local vars. 1722 ${*$self}{exp_Pty_Buffer} = ''; 1723 1724 # Initialize accumulator. 1725 ${*$self}{exp_Max_Accum} = $Expect::Exp_Max_Accum; 1726 ${*$self}{exp_Accum} = ''; 1727 ${*$self}{exp_NoTransfer} = 0; 1728 1729 # create empty expect_before & after lists 1730 ${*$self}{exp_expect_before_list} = []; 1731 ${*$self}{exp_expect_after_list} = []; 1732 1733 return; 1734} 1735 1736sub _make_readable { 1737 my ($s) = @_; 1738 1739 $s = '' if not defined($s); 1740 study $s; # Speed things up? 1741 $s =~ s/\\/\\\\/g; # So we can tell easily(?) what is a backslash 1742 $s =~ s/\n/\\n/g; 1743 $s =~ s/\r/\\r/g; 1744 $s =~ s/\t/\\t/g; 1745 $s =~ s/\'/\\\'/g; # So we can tell whassa quote and whassa notta quote. 1746 $s =~ s/\"/\\\"/g; 1747 1748 # Formfeed (does anyone use formfeed?) 1749 $s =~ s/\f/\\f/g; 1750 $s =~ s/\010/\\b/g; 1751 1752 # escape control chars high/low, but allow ISO 8859-1 chars 1753 $s =~ s/([\000-\037\177-\237\377])/sprintf("\\%03lo",ord($1))/ge; 1754 1755 return $s; 1756} 1757 1758sub _trim_length { 1759 my ($self, $string, $length) = @_; 1760 1761 # This is sort of a reverse truncation function 1762 # Mostly so we don't have to see the full output when we're using 1763 # Also used if Max_Accum gets set to limit the size of the accumulator 1764 # for matching functions. 1765 # exp_internal 1766 1767 croak('No string passed') if not defined $string; 1768 1769 # If we're not passed a length (_trim_length is being used for debugging 1770 # purposes) AND debug >= 3, don't trim. 1771 return ($string) 1772 if (defined($self) 1773 and ${*$self}{"exp_Debug"} >= 3 1774 and ( !( defined($length) ) ) ); 1775 my $indicate_truncation = ($length ? '' : '...'); 1776 $length ||= 1021; 1777 return $string if $length >= length $string; 1778 1779 # We wouldn't want the accumulator to begin with '...' if max_accum is passed 1780 # This is because this funct. gets called internally w/ max_accum 1781 # and is also used to print information back to the user. 1782 return $indicate_truncation . substr( $string, ( length($string) - $length ), $length ); 1783} 1784 1785sub _print_handles { 1786 my ($self, $print_this) = @_; 1787 1788 # Given crap from 'self' and the handles self wants to print to, print to 1789 # them. these are indicated by the handle's 'group' 1790 if ( ${*$self}{exp_Log_Group} ) { 1791 foreach my $handle ( @{ ${*$self}{exp_Listen_Group} } ) { 1792 $print_this = '' unless defined($print_this); 1793 1794 # Appease perl -w 1795 print STDERR "Printed '" 1796 . $self->_trim_length( _make_readable($print_this) ) 1797 . "' to ${*$handle}{exp_Pty_Handle} from ${*$self}{exp_Pty_Handle}.\r\n" 1798 if ( ${*$handle}{"exp_Debug"} > 1 ); 1799 print $handle $print_this; 1800 } 1801 } 1802 1803 # If ${*$self}{exp_Pty_Handle} is STDIN this would make it echo. 1804 print STDOUT $print_this 1805 if ${*$self}{"exp_Log_Stdout"}; 1806 $self->print_log_file($print_this); 1807 $| = 1; # This should not be necessary but autoflush() doesn't always work. 1808 1809 return; 1810} 1811 1812sub _get_mode { 1813 my ($handle) = @_; 1814 1815 my ($fcntl_flags) = ''; 1816 1817 # What mode are we opening with? use fcntl to find out. 1818 $fcntl_flags = fcntl( \*{$handle}, Fcntl::F_GETFL, $fcntl_flags ); 1819 die "fcntl returned undef during exp_init of $handle, $!\r\n" 1820 unless defined($fcntl_flags); 1821 if ( $fcntl_flags | (Fcntl::O_RDWR) ) { 1822 return 'rw'; 1823 } elsif ( $fcntl_flags | (Fcntl::O_WRONLY) ) { 1824 return 'w'; 1825 } else { 1826 1827 # Under Solaris (among others?) O_RDONLY is implemented as 0. so |O_RDONLY would fail. 1828 return 'r'; 1829 } 1830} 1831 1832sub _undef { 1833 return undef; 1834 1835 # Seems a little retarded but &CORE::undef fails in interconnect. 1836 # This is used for the default escape sequence function. 1837 # w/out the leading & it won't compile. 1838} 1839 1840# clean up child processes 1841sub DESTROY { 1842 my ($self) = @_; 1843 1844 my $status = $?; # save this as it gets mangled by the terminating spawned children 1845 if ( ${*$self}{exp_Do_Soft_Close} ) { 1846 $self->soft_close(); 1847 } 1848 $self->hard_close(); 1849 $? = $status; # restore it. otherwise deleting an Expect object may mangle $?, which is unintuitive 1850 1851 return; 1852} 1853 18541; 1855__END__ 1856 1857=head1 NAME 1858 1859Expect - automate interactions with command line programs that expose a text terminal interface. 1860 1861=head1 SYNOPSIS 1862 1863 use Expect; 1864 1865 # create an Expect object by spawning another process 1866 my $exp = Expect->spawn($command, @params) 1867 or die "Cannot spawn $command: $!\n"; 1868 1869 # or by using an already opened filehandle (e.g. from Net::Telnet) 1870 my $exp = Expect->exp_init(\*FILEHANDLE); 1871 1872 # if you prefer the OO mindset: 1873 my $exp = Expect->new; 1874 $exp->raw_pty(1); 1875 $exp->spawn($command, @parameters) 1876 or die "Cannot spawn $command: $!\n"; 1877 1878 # send some string there: 1879 $exp->send("string\n"); 1880 1881 # or, for the filehandle mindset: 1882 print $exp "string\n"; 1883 1884 # then do some pattern matching with either the simple interface 1885 $patidx = $exp->expect($timeout, @match_patterns); 1886 1887 # or multi-match on several spawned commands with callbacks, 1888 # just like the Tcl version 1889 $exp->expect($timeout, 1890 [ qr/regex1/ => sub { my $exp = shift; 1891 $exp->send("response\n"); 1892 exp_continue; } ], 1893 [ "regexp2" , \&callback, @cbparms ], 1894 ); 1895 1896 # if no longer needed, do a soft_close to nicely shut down the command 1897 $exp->soft_close(); 1898 1899 # or be less patient with 1900 $exp->hard_close(); 1901 1902Expect.pm is built to either spawn a process or take an existing filehandle 1903and interact with it such that normally interactive tasks can be done 1904without operator assistance. This concept makes more sense if you are 1905already familiar with the versatile Tcl version of Expect. 1906The public functions that make up Expect.pm are: 1907 1908 Expect->new() 1909 Expect::interconnect(@objects_to_be_read_from) 1910 Expect::test_handles($timeout, @objects_to_test) 1911 Expect::version($version_requested | undef); 1912 $object->spawn(@command) 1913 $object->clear_accum() 1914 $object->set_accum($value) 1915 $object->debug($debug_level) 1916 $object->exp_internal(0 | 1) 1917 $object->notransfer(0 | 1) 1918 $object->raw_pty(0 | 1) 1919 $object->stty(@stty_modes) # See the IO::Stty docs 1920 $object->slave() 1921 $object->before(); 1922 $object->match(); 1923 $object->after(); 1924 $object->matchlist(); 1925 $object->match_number(); 1926 $object->error(); 1927 $object->command(); 1928 $object->exitstatus(); 1929 $object->pty_handle(); 1930 $object->do_soft_close(); 1931 $object->restart_timeout_upon_receive(0 | 1); 1932 $object->interact($other_object, $escape_sequence) 1933 $object->log_group(0 | 1 | undef) 1934 $object->log_user(0 | 1 | undef) 1935 $object->log_file("filename" | $filehandle | \&coderef | undef) 1936 $object->manual_stty(0 | 1 | undef) 1937 $object->match_max($max_buffersize or undef) 1938 $object->pid(); 1939 $object->send_slow($delay, @strings_to_send) 1940 $object->set_group(@listen_group_objects | undef) 1941 $object->set_seq($sequence,\&function,\@parameters); 1942 1943There are several configurable package variables that affect the behavior of Expect. They are: 1944 1945 $Expect::Debug; 1946 $Expect::Exp_Internal; 1947 $Expect::IgnoreEintr; 1948 $Expect::Log_Group; 1949 $Expect::Log_Stdout; 1950 $Expect::Manual_Stty; 1951 $Expect::Multiline_Matching; 1952 $Expect::Do_Soft_Close; 1953 1954=head1 DESCRIPTION 1955 1956See an explanation of L<What is Expect|http://code-maven.com/expect> 1957 1958The Expect module is a successor of Comm.pl and a descendent of Chat.pl. It 1959more closely resembles the Tcl Expect language than its predecessors. It 1960does not contain any of the networking code found in Comm.pl. I suspect this 1961would be obsolete anyway given the advent of IO::Socket and external tools 1962such as netcat. 1963 1964Expect.pm is an attempt to have more of a switch() & case feeling to make 1965decision processing more fluid. Three separate types of debugging have 1966been implemented to make code production easier. 1967 1968It is possible to interconnect multiple file handles (and processes) much 1969like Tcl's Expect. An attempt was made to enable all the features of Tcl's 1970Expect without forcing Tcl on the victim programmer :-) . 1971 1972Please, before you consider using Expect, read the FAQs about 1973L</"I want to automate password entry for su/ssh/scp/rsh/..."> and 1974L</"I want to use Expect to automate [anything with a buzzword]..."> 1975 1976 1977=head1 USAGE 1978 1979=over 4 1980 1981=item new 1982 1983Creates a new Expect object, i.e. a pty. You can change parameters on 1984it before actually spawning a command. This is important if you want 1985to modify the terminal settings for the slave. See slave() below. 1986The object returned is actually a reblessed IO::Pty filehandle, so see 1987there for additional methods. 1988 1989 1990=item Expect->exp_init(\*FILEHANDLE) I<or> 1991 1992=item Expect->init(\*FILEHANDLE) 1993 1994Initializes $new_handle_object for use with other Expect functions. It must 1995be passed a B<_reference_> to FILEHANDLE if you want it to work properly. 1996IO::File objects are preferable. Returns a reference to the newly created 1997object. 1998 1999You can use only real filehandles, certain tied filehandles 2000(e.g. Net::SSH2) that lack a fileno() will not work. Net::Telnet 2001objects can be used but have been reported to work only for certain 2002hosts. YMMV. 2003 2004 2005=item Expect->spawn($command, @parameters) I<or> 2006 2007=item $object->spawn($command, @parameters) I<or> 2008 2009=item Expect->new($command, @parameters) 2010 2011Forks and execs $command. Returns an Expect object upon success or 2012C<undef> if the fork was unsuccessful or the command could not be 2013found. spawn() passes its parameters unchanged to Perls exec(), so 2014look there for detailed semantics. 2015 2016Note that if spawn cannot exec() the given command, the Expect object 2017is still valid and the next expect() will see "Cannot exec", so you 2018can use that for error handling. 2019 2020Also note that you cannot reuse an object with an already spawned 2021command, even if that command has exited. Sorry, but you have to 2022allocate a new object... 2023 2024 2025=item $object->debug(0 | 1 | 2 | 3 | undef) 2026 2027Sets debug level for $object. 1 refers to general debugging 2028information, 2 refers to verbose debugging and 0 refers to no 2029debugging. If you call debug() with no parameters it will return the 2030current debugging level. When the object is created the debugging 2031level will match that $Expect::Debug, normally 0. 2032 2033The '3' setting is new with 1.05, and adds the additional 2034functionality of having the _full_ accumulated buffer printed every 2035time data is read from an Expect object. This was implemented by 2036request. I recommend against using this unless you think you need it 2037as it can create quite a quantity of output under some circumstances.. 2038 2039 2040=item $object->exp_internal(1 | 0) 2041 2042Sets/unsets 'exp_internal' debugging. This is similar in nature to its Tcl 2043counterpart. It is extremely valuable when debugging expect() sequences. 2044When the object is created the exp_internal setting will match the value of 2045$Expect::Exp_Internal, normally 0. Returns the current setting if called 2046without parameters. It is highly recommended that you make use of the 2047debugging features lest you have angry code. 2048 2049 2050=item $object->raw_pty(1 | 0) 2051 2052Set pty to raw mode before spawning. This disables echoing, CR->LF 2053translation and an ugly hack for broken Solaris TTYs (which send 2054<space><backspace> to slow things down) and thus gives a more 2055pipe-like behaviour (which is important if you want to transfer binary 2056content). Note that this must be set I<before> spawning the program. 2057 2058 2059=item $object->stty(qw(mode1 mode2...)) 2060 2061Sets the tty mode for $object's associated terminal to the given 2062modes. Note that on many systems the master side of the pty is not a 2063tty, so you have to modify the slave pty instead, see next item. This 2064needs IO::Stty installed, which is no longer required. 2065 2066 2067=item $object->slave() 2068 2069Returns a filehandle to the slave part of the pty. Very useful in modifying 2070the terminal settings: 2071 2072 $object->slave->stty(qw(raw -echo)); 2073 2074Typical values are 'sane', 'raw', and 'raw -echo'. Note that I 2075recommend setting the terminal to 'raw' or 'raw -echo', as this avoids 2076a lot of hassle and gives pipe-like (i.e. transparent) behaviour 2077(without the buffering issue). 2078 2079 2080=item $object->print(@strings) I<or> 2081 2082=item $object->send(@strings) 2083 2084Sends the given strings to the spawned command. Note that the strings 2085are not logged in the logfile (see print_log_file) but will probably 2086be echoed back by the pty, depending on pty settings (default is echo) 2087and thus end up there anyway. This must also be taken into account 2088when expect()ing for an answer: the next string will be the command 2089just sent. I suggest setting the pty to raw, which disables echo and 2090makes the pty transparently act like a bidirectional pipe. 2091 2092 2093=item $object->expect($timeout, @match_patterns) 2094 2095=over 4 2096 2097=item Simple interface 2098 2099Given $timeout in seconds Expect will wait for $object's handle to produce 2100one of the match_patterns, which are matched exactly by default. If you 2101want a regexp match, prefix the pattern with '-re'. 2102 2103 $object->expect(15, 'match me exactly','-re','match\s+me\s+exactly'); 2104 2105Due to o/s limitations $timeout should be a round number. If $timeout 2106is 0 Expect will check one time to see if $object's handle contains 2107any of the match_patterns. If $timeout is undef Expect 2108will wait forever for a pattern to match. 2109 2110If called in a scalar context, expect() will return the position of 2111the matched pattern within @matched_patterns, or undef if no pattern was 2112matched. This is a position starting from 1, so if you want to know 2113which of an array of @matched_patterns matched you should subtract one 2114from the return value. 2115 2116If called in an array context expect() will return 2117($matched_pattern_position, $error, $successfully_matching_string, 2118$before_match, and $after_match). 2119 2120C<$matched_pattern_position> will contain the value that would have been 2121returned if expect() had been called in a scalar context. 2122 2123C<$error> is 2124the error that occurred that caused expect() to return. $error will 2125contain a number followed by a string equivalent expressing the nature 2126of the error. Possible values are undef, indicating no error, 2127'1:TIMEOUT' indicating that $timeout seconds had elapsed without a 2128match, '2:EOF' indicating an eof was read from $object, '3: spawn 2129id($fileno) died' indicating that the process exited before matching 2130and '4:$!' indicating whatever error was set in $ERRNO during the last 2131read on $object's handle or during select(). All handles indicated by 2132set_group plus STDOUT will have all data to come out of $object 2133printed to them during expect() if log_group and log_stdout are set. 2134 2135C<$successfully_matching_string> 2136C<$before_match> 2137C<$after_match> 2138 2139Changed from older versions is the regular expression handling. By 2140default now all strings passed to expect() are treated as literals. To 2141match a regular expression pass '-re' as a parameter in front of the 2142pattern you want to match as a regexp. 2143 2144This change makes it possible to match literals and regular expressions 2145in the same expect() call. 2146 2147Also new is multiline matching. ^ will now match the beginning of 2148lines. Unfortunately, because perl doesn't use $/ in determining where 2149lines break using $ to find the end of a line frequently doesn't work. This 2150is because your terminal is returning "\r\n" at the end of every line. One 2151way to check for a pattern at the end of a line would be to use \r?$ instead 2152of $. 2153 2154Example: Spawning telnet to a host, you might look for the escape 2155character. telnet would return to you "\r\nEscape character is 2156'^]'.\r\n". To find this you might use $match='^Escape char.*\.\r?$'; 2157 2158 $telnet->expect(10,'-re',$match); 2159 2160=item New more Tcl/Expect-like interface 2161 2162 expect($timeout, 2163 '-i', [ $obj1, $obj2, ... ], 2164 [ $re_pattern, sub { ...; exp_continue; }, @subparms, ], 2165 [ 'eof', sub { ... } ], 2166 [ 'timeout', sub { ... }, \$subparm1 ], 2167 '-i', [ $objn, ...], 2168 '-ex', $exact_pattern, sub { ... }, 2169 $exact_pattern, sub { ...; exp_continue_timeout; }, 2170 '-re', $re_pattern, sub { ... }, 2171 '-i', \@object_list, @pattern_list, 2172 ...); 2173 2174 2175It's now possible to expect on more than one connection at a time by 2176specifying 'C<-i>' and a single Expect object or a ref to an array 2177containing Expect objects, e.g. 2178 2179 expect($timeout, 2180 '-i', $exp1, @patterns_1, 2181 '-i', [ $exp2, $exp3 ], @patterns_2_3, 2182 ) 2183 2184Furthermore, patterns can now be specified as array refs containing 2185[$regexp, sub { ...}, @optional_subprams] . When the pattern matches, 2186the subroutine is called with parameters ($matched_expect_obj, 2187@optional_subparms). The subroutine can return the symbol 2188`exp_continue' to continue the expect matching with timeout starting 2189anew or return the symbol `exp_continue_timeout' for continuing expect 2190without resetting the timeout count. 2191 2192 $exp->expect($timeout, 2193 [ qr/username: /i, sub { my $self = shift; 2194 $self->send("$username\n"); 2195 exp_continue; }], 2196 [ qr/password: /i, sub { my $self = shift; 2197 $self->send("$password\n"); 2198 exp_continue; }], 2199 $shell_prompt); 2200 2201 2202`expect' is now exported by default. 2203 2204=back 2205 2206=item $object->exp_before() I<or> 2207 2208=item $object->before() 2209 2210before() returns the 'before' part of the last expect() call. If the last 2211expect() call didn't match anything, exp_before() will return the entire 2212output of the object accumulated before the expect() call finished. 2213 2214Note that this is something different than Tcl Expects before()!! 2215 2216 2217=item $object->exp_after() I<or> 2218 2219=item $object->after() 2220 2221returns the 'after' part of the last expect() call. If the last 2222expect() call didn't match anything, exp_after() will return undef(). 2223 2224 2225=item $object->exp_match() I<or> 2226 2227=item $object->match() 2228 2229returns the string matched by the last expect() call, undef if 2230no string was matched. 2231 2232 2233=item $object->exp_match_number() I<or> 2234 2235=item $object->match_number() 2236 2237exp_match_number() returns the number of the pattern matched by the last 2238expect() call. Keep in mind that the first pattern in a list of patterns is 1, 2239not 0. Returns undef if no pattern was matched. 2240 2241 2242=item $object->exp_matchlist() I<or> 2243 2244=item $object->matchlist() 2245 2246exp_matchlist() returns a list of matched substrings from the brackets 2247() inside the regexp that last matched. ($object->matchlist)[0] 2248thus corresponds to $1, ($object->matchlist)[1] to $2, etc. 2249 2250 2251=item $object->exp_error() I<or> 2252 2253=item $object->error() 2254 2255exp_error() returns the error generated by the last expect() call if 2256no pattern was matched. It is typically useful to examine the value returned by 2257before() to find out what the output of the object was in determining 2258why it didn't match any of the patterns. 2259 2260 2261=item $object->clear_accum() 2262 2263Clear the contents of the accumulator for $object. This gets rid of 2264any residual contents of a handle after expect() or send_slow() such 2265that the next expect() call will only see new data from $object. The 2266contents of the accumulator are returned. 2267 2268 2269=item $object->set_accum($value) 2270 2271Sets the content of the accumulator for $object to $value. The 2272previous content of the accumulator is returned. 2273 2274 2275=item $object->exp_command() I<or> 2276 2277=item $object->command() 2278 2279exp_command() returns the string that was used to spawn the command. Helpful 2280for debugging and for reused patternmatch subroutines. 2281 2282 2283=item $object->exp_exitstatus() I<or> 2284 2285=item $object->exitstatus() 2286 2287Returns the exit status of $object (if it already exited). 2288 2289 2290=item $object->exp_pty_handle() I<or> 2291 2292=item $object->pty_handle() 2293 2294Returns a string representation of the attached pty, for example: 2295`spawn id(5)' (pty has fileno 5), `handle id(7)' (pty was initialized 2296from fileno 7) or `STDIN'. Useful for debugging. 2297 2298 2299=item $object->restart_timeout_upon_receive(0 | 1) 2300 2301If this is set to 1, the expect timeout is retriggered whenever something 2302is received from the spawned command. This allows to perform some 2303aliveness testing and still expect for patterns. 2304 2305 $exp->restart_timeout_upon_receive(1); 2306 $exp->expect($timeout, 2307 [ timeout => \&report_timeout ], 2308 [ qr/pattern/ => \&handle_pattern], 2309 ); 2310 2311Now the timeout isn't triggered if the command produces any kind of output, 2312i.e. is still alive, but you can act upon patterns in the output. 2313 2314 2315=item $object->notransfer(1 | 0) 2316 2317Do not truncate the content of the accumulator after a match. 2318Normally, the accumulator is set to the remains that come after the 2319matched string. Note that this setting is per object and not per 2320pattern, so if you want to have normal acting patterns that truncate 2321the accumulator, you have to add a 2322 2323 $exp->set_accum($exp->after); 2324 2325to their callback, e.g. 2326 2327 $exp->notransfer(1); 2328 $exp->expect($timeout, 2329 # accumulator not truncated, pattern1 will match again 2330 [ "pattern1" => sub { my $self = shift; 2331 ... 2332 } ], 2333 # accumulator truncated, pattern2 will not match again 2334 [ "pattern2" => sub { my $self = shift; 2335 ... 2336 $self->set_accum($self->after()); 2337 } ], 2338 ); 2339 2340This is only a temporary fix until I can rewrite the pattern matching 2341part so it can take that additional -notransfer argument. 2342 2343 2344=item Expect::interconnect(@objects); 2345 2346Read from @objects and print to their @listen_groups until an escape sequence 2347is matched from one of @objects and the associated function returns 0 or undef. 2348The special escape sequence 'EOF' is matched when an object's handle returns 2349an end of file. Note that it is not necessary to include objects that only 2350accept data in @objects since the escape sequence is _read_ from an object. 2351Further note that the listen_group for a write-only object is always empty. 2352Why would you want to have objects listening to STDOUT (for example)? 2353By default every member of @objects _as well as every member of its listen 2354group_ will be set to 'raw -echo' for the duration of interconnection. 2355Setting $object->manual_stty() will stop this behavior per object. 2356The original tty settings will be restored as interconnect exits. 2357 2358For a generic way to interconnect processes, take a look at L<IPC::Run>. 2359 2360 2361=item Expect::test_handles(@objects) 2362 2363Given a set of objects determines which objects' handles have data ready 2364to be read. B<Returns an array> who's members are positions in @objects that 2365have ready handles. Returns undef if there are no such handles ready. 2366 2367 2368=item Expect::version($version_requested or undef); 2369 2370Returns current version of Expect. As of .99 earlier versions are not 2371supported. Too many things were changed to make versioning possible. 2372 2373 2374=item $object->interact( C<\*FILEHANDLE, $escape_sequence>) 2375 2376interact() is essentially a macro for calling interconnect() for 2377connecting 2 processes together. \*FILEHANDLE defaults to \*STDIN and 2378$escape_sequence defaults to undef. Interaction ceases when $escape_sequence 2379is read from B<FILEHANDLE>, not $object. $object's listen group will 2380consist solely of \*FILEHANDLE for the duration of the interaction. 2381\*FILEHANDLE will not be echoed on STDOUT. 2382 2383 2384=item $object->log_group(0 | 1 | undef) 2385 2386Set/unset logging of $object to its 'listen group'. If set all objects 2387in the listen group will have output from $object printed to them during 2388$object->expect(), $object->send_slow(), and C<Expect::interconnect($object 2389, ...)>. Default value is on. During creation of $object the setting will 2390match the value of $Expect::Log_Group, normally 1. 2391 2392 2393=item $object->log_user(0 | 1 | undef) I<or> 2394 2395=item $object->log_stdout(0 | 1 | undef) 2396 2397Set/unset logging of object's handle to STDOUT. This corresponds to Tcl's 2398log_user variable. Returns current setting if called without parameters. 2399Default setting is off for initialized handles. When a process object is 2400created (not a filehandle initialized with exp_init) the log_stdout setting 2401will match the value of $Expect::Log_Stdout variable, normally 1. 2402If/when you initialize STDIN it is usually associated with a tty which 2403will by default echo to STDOUT anyway, so be careful or you will have 2404multiple echoes. 2405 2406 2407=item $object->log_file("filename" | $filehandle | \&coderef | undef) 2408 2409Log session to a file. All characters send to or received from the 2410spawned process are written to the file. Normally appends to the 2411logfile, but you can pass an additional mode of "w" to truncate the 2412file upon open(): 2413 2414 $object->log_file("filename", "w"); 2415 2416Returns the logfilehandle. 2417 2418If called with an undef value, stops logging and closes logfile: 2419 2420 $object->log_file(undef); 2421 2422If called without argument, returns the logfilehandle: 2423 2424 $fh = $object->log_file(); 2425 2426Can be set to a code ref, which will be called instead of printing 2427to the logfile: 2428 2429 $object->log_file(\&myloggerfunc); 2430 2431 2432=item $object->print_log_file(@strings) 2433 2434Prints to logfile (if opened) or calls the logfile hook function. 2435This allows the user to add arbitrary text to the logfile. Note that 2436this could also be done as $object->log_file->print() but would only 2437work for log files, not code hooks. 2438 2439 2440=item $object->set_seq($sequence, \&function, \@function_parameters) 2441 2442During Expect->interconnect() if $sequence is read from $object &function 2443will be executed with parameters @function_parameters. It is B<_highly 2444recommended_> that the escape sequence be a single character since the 2445likelihood is great that the sequence will be broken into to separate reads 2446from the $object's handle, making it impossible to strip $sequence from 2447getting printed to $object's listen group. \&function should be something 2448like 'main::control_w_function' and @function_parameters should be an 2449array defined by the caller, passed by reference to set_seq(). 2450Your function should return a non-zero value if execution of interconnect() 2451is to resume after the function returns, zero or undefined if interconnect() 2452should return after your function returns. 2453The special sequence 'EOF' matches the end of file being reached by $object. 2454See interconnect() for details. 2455 2456 2457=item $object->set_group(@listener_objects) 2458 2459@listener_objects is the list of objects that should have their handles 2460printed to by $object when Expect::interconnect, $object->expect() or 2461$object->send_slow() are called. Calling w/out parameters will return 2462the current list of the listener objects. 2463 2464 2465=item $object->manual_stty(0 | 1 | undef) 2466 2467Sets/unsets whether or not Expect should make reasonable guesses as to 2468when and how to set tty parameters for $object. Will match 2469$Expect::Manual_Stty value (normally 0) when $object is created. If called 2470without parameters manual_stty() will return the current manual_stty setting. 2471 2472 2473=item $object->match_max($maximum_buffer_length | undef) I<or> 2474 2475=item $object->max_accum($maximum_buffer_length | undef) 2476 2477Set the maximum accumulator size for object. This is useful if you think 2478that the accumulator will grow out of hand during expect() calls. Since 2479the buffer will be matched by every match_pattern it may get slow if the 2480buffer gets too large. Returns current value if called without parameters. 2481Not defined by default. 2482 2483 2484=item $object->notransfer(0 | 1) 2485 2486If set, matched strings will not be deleted from the accumulator. 2487Returns current value if called without parameters. False by default. 2488 2489 2490=item $object->exp_pid() I<or> 2491 2492=item $object->pid() 2493 2494Return pid of $object, if one exists. Initialized filehandles will not have 2495pids (of course). 2496 2497 2498=item $object->send_slow($delay, @strings); 2499 2500print each character from each string of @strings one at a time with $delay 2501seconds before each character. This is handy for devices such as modems 2502that can be annoying if you send them data too fast. After each character 2503$object will be checked to determine whether or not it has any new data ready 2504and if so update the accumulator for future expect() calls and print the 2505output to STDOUT and @listen_group if log_stdout and log_group are 2506appropriately set. 2507 2508=back 2509 2510=head2 Configurable Package Variables: 2511 2512=over 4 2513 2514=item $Expect::Debug 2515 2516Defaults to 0. Newly created objects have a $object->debug() value 2517of $Expect::Debug. See $object->debug(); 2518 2519=item $Expect::Do_Soft_Close 2520 2521Defaults to 0. When destroying objects, soft_close may take up to half 2522a minute to shut everything down. From now on, only hard_close will 2523be called, which is less polite but still gives the process a chance 2524to terminate properly. Set this to '1' for old behaviour. 2525 2526=item $Expect::Exp_Internal 2527 2528Defaults to 0. Newly created objects have a $object->exp_internal() 2529value of $Expect::Exp_Internal. See $object->exp_internal(). 2530 2531=item $Expect::IgnoreEintr 2532 2533Defaults to 0. If set to 1, when waiting for new data, Expect will 2534ignore EINTR errors and restart the select() call instead. 2535 2536=item $Expect::Log_Group 2537 2538Defaults to 1. Newly created objects have a $object->log_group() 2539value of $Expect::Log_Group. See $object->log_group(). 2540 2541=item $Expect::Log_Stdout 2542 2543Defaults to 1 for spawned commands, 0 for file handles 2544attached with exp_init(). Newly created objects have a 2545$object->log_stdout() value of $Expect::Log_Stdout. See 2546$object->log_stdout(). 2547 2548=item $Expect::Manual_Stty 2549 2550Defaults to 0. Newly created objects have a $object->manual_stty() 2551value of $Expect::Manual_Stty. See $object->manual_stty(). 2552 2553=item $Expect::Multiline_Matching 2554 2555Defaults to 1. Affects whether or not expect() uses the /m flag for 2556doing regular expression matching. If set to 1 /m is used. 2557 2558This makes a difference when you are trying to match ^ and $. If 2559you have this on you can match lines in the middle of a page of output 2560using ^ and $ instead of it matching the beginning and end of the entire 2561expression. I think this is handy. 2562 2563The $Expect::Multiline_Matching turns on and off Expect's multi-line 2564matching mode. But this only has an effect if you pass in a string, and 2565then use '-re' mode. If you pass in a regular expression value (via 2566qr//), then the qr//'s own flags are preserved irrespective of what it 2567gets interpolated into. There was a bug in Perl 5.8.x where interpolating 2568a regex without /m into a match with /m would incorrectly apply the /m 2569to the inner regex too, but this was fixed in Perl 5.10. The correct 2570behavior, as seen in Perl 5.10, is that if you pass in a regex (via 2571qr//), then $Expect::Multiline_Matching has no effect. 2572So if you pass in a regex, then you must use the qr's flags 2573to control whether it is multiline (which by default it is not, opposite 2574of the default behavior of Expect). 2575 2576=back 2577 2578=head1 CONTRIBUTIONS 2579 2580Lee Eakin <leakin@japh.itg.ti.com> has ported the kibitz script 2581from Tcl/Expect to Perl/Expect. 2582 2583Jeff Carr <jcarr@linuxmachines.com> provided a simple example of how 2584handle terminal window resize events (transmitted via the WINCH 2585signal) in a ssh session. 2586 2587You can find both scripts in the examples/ subdir. Thanks to both! 2588 2589Historical notes: 2590 2591There are still a few lines of code dating back to the inspirational 2592Comm.pl and Chat.pl modules without which this would not have been possible. 2593Kudos to Eric Arnold <Eric.Arnold@Sun.com> and Randal 'Nuke your NT box with 2594one line of perl code' Schwartz<merlyn@stonehenge.com> for making these 2595available to the perl public. 2596 2597As of .98 I think all the old code is toast. No way could this have been done 2598without it though. Special thanks to Graham Barr for helping make sense of 2599the IO::Handle stuff as well as providing the highly recommended IO::Tty 2600module. 2601 2602 2603=head1 REFERENCES 2604 2605Mark Rogaski <rogaski@att.com> wrote: 2606 2607"I figured that you'd like to know that Expect.pm has been very 2608useful to AT&T Labs over the past couple of years (since I first talked to 2609Austin about design decisions). We use Expect.pm for managing 2610the switches in our network via the telnet interface, and such automation 2611has significantly increased our reliability. So, you can honestly say that 2612one of the largest digital networks in existence (AT&T Frame Relay) uses 2613Expect.pm quite extensively." 2614 2615 2616=head1 FAQ - Frequently Asked Questions 2617 2618This is a growing collection of things that might help. 2619Please send you questions that are not answered here to 2620RGiersig@cpan.org 2621 2622 2623=head2 What systems does Expect run on? 2624 2625Expect itself doesn't have real system dependencies, but the underlying 2626IO::Tty needs pseudoterminals. IO::Stty uses POSIX.pm and Fcntl.pm. 2627 2628I have used it on Solaris, Linux and AIX, others report *BSD and OSF 2629as working. Generally, any modern POSIX Unix should do, but there 2630are exceptions to every rule. Feedback is appreciated. 2631 2632See L<IO::Tty> for a list of verified systems. 2633 2634 2635=head2 Can I use this module with ActivePerl on Windows? 2636 2637Up to now, the answer was 'No', but this has changed. 2638 2639You still cannot use ActivePerl, but if you use the Cygwin environment 2640(http://sources.redhat.com), which brings its own perl, and have 2641the latest IO::Tty (v0.05 or later) installed, it should work (feedback 2642appreciated). 2643 2644 2645=head2 The examples in the tutorial don't work! 2646 2647The tutorial is hopelessly out of date and needs a serious overhaul. 2648I apologize for this, I have concentrated my efforts mainly on the 2649functionality. Volunteers welcomed. 2650 2651 2652=head2 How can I find out what Expect is doing? 2653 2654If you set 2655 2656 $Expect::Exp_Internal = 1; 2657 2658Expect will tell you very verbosely what it is receiving and sending, 2659what matching it is trying and what it found. You can do this on a 2660per-command base with 2661 2662 $exp->exp_internal(1); 2663 2664You can also set 2665 2666 $Expect::Debug = 1; # or 2, 3 for more verbose output 2667 2668or 2669 2670 $exp->debug(1); 2671 2672which gives you even more output. 2673 2674 2675=head2 I am seeing the output of the command I spawned. Can I turn that off? 2676 2677Yes, just set 2678 2679 $Expect::Log_Stdout = 0; 2680 2681to globally disable it or 2682 2683 $exp->log_stdout(0); 2684 2685for just that command. 'log_user' is provided as an alias so 2686Tcl/Expect user get a DWIM experience... :-) 2687 2688 2689=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. 2690 2691This is caused by the pty, which has probably 'echo' enabled. A 2692solution would be to set the pty to raw mode, which in general is 2693cleaner for communication between two programs (no more unexpected 2694character translations). Unfortunately this would break a lot of old 2695code that sends "\r" to the program instead of "\n" (translating this 2696is also handled by the pty), so I won't add this to Expect just like that. 2697But feel free to experiment with C<$exp-E<gt>raw_pty(1)>. 2698 2699 2700=head2 How do I send control characters to a process? 2701 2702A: You can send any characters to a process with the print command. To 2703represent a control character in Perl, use \c followed by the letter. For 2704example, control-G can be represented with "\cG" . Note that this will not 2705work if you single-quote your string. So, to send control-C to a process in 2706$exp, do: 2707 2708 print $exp "\cC"; 2709 2710Or, if you prefer: 2711 2712 $exp->send("\cC"); 2713 2714The ability to include control characters in a string like this is provided 2715by Perl, not by Expect.pm . Trying to learn Expect.pm without a thorough 2716grounding in Perl can be very daunting. We suggest you look into some of 2717the excellent Perl learning material, such as the books _Programming Perl_ 2718and _Learning Perl_ by O'Reilly, as well as the extensive online Perl 2719documentation available through the perldoc command. 2720 2721 2722=head2 My script fails from time to time without any obvious reason. It seems that I am sometimes loosing output from the spawned program. 2723 2724You could be exiting too fast without giving the spawned program 2725enough time to finish. Try adding $exp->soft_close() to terminate the 2726program gracefully or do an expect() for 'eof'. 2727 2728Alternatively, try adding a 'sleep 1' after you spawn() the program. 2729It could be that pty creation on your system is just slow (but this is 2730rather improbable if you are using the latest IO-Tty). 2731 2732 2733=head2 I want to automate password entry for su/ssh/scp/rsh/... 2734 2735You shouldn't use Expect for this. Putting passwords, especially 2736root passwords, into scripts in clear text can mean severe security 2737problems. I strongly recommend using other means. For 'su', consider 2738switching to 'sudo', which gives you root access on a per-command and 2739per-user basis without the need to enter passwords. 'ssh'/'scp' can be 2740set up with RSA authentication without passwords. 'rsh' can use 2741the .rhost mechanism, but I'd strongly suggest to switch to 'ssh'; to 2742mention 'rsh' and 'security' in the same sentence makes an oxymoron. 2743 2744It will work for 'telnet', though, and there are valid uses for it, 2745but you still might want to consider using 'ssh', as keeping cleartext 2746passwords around is very insecure. 2747 2748 2749=head2 I want to use Expect to automate [anything with a buzzword]... 2750 2751Are you sure there is no other, easier way? As a rule of thumb, 2752Expect is useful for automating things that expect to talk to a human, 2753where no formal standard applies. For other tasks that do follow a 2754well-defined protocol, there are often better-suited modules that 2755already can handle those protocols. Don't try to do HTTP requests by 2756spawning telnet to port 80, use LWP instead. To automate FTP, take a 2757look at L<Net::FTP> or C<ncftp> (http://www.ncftp.org). You don't use 2758a screwdriver to hammer in your nails either, or do you? 2759 2760 2761=head2 Is it possible to use threads with Expect? 2762 2763Basically yes, with one restriction: you must spawn() your programs in 2764the main thread and then pass the Expect objects to the handling 2765threads. The reason is that spawn() uses fork(), and L<perlthrtut>: 2766 2767 "Thinking of mixing fork() and threads? Please lie down and wait until the feeling passes." 2768 2769 2770=head2 I want to log the whole session to a file. 2771 2772Use 2773 2774 $exp->log_file("filename"); 2775 2776or 2777 2778 $exp->log_file($filehandle); 2779 2780or even 2781 2782 $exp->log_file(\&log_procedure); 2783 2784for maximum flexibility. 2785 2786Note that the logfile is appended to by default, but you can 2787specify an optional mode "w" to truncate the logfile: 2788 2789 $exp->log_file("filename", "w"); 2790 2791To stop logging, just call it with a false argument: 2792 2793 $exp->log_file(undef); 2794 2795 2796=head2 How can I turn off multi-line matching for my regexps? 2797 2798To globally unset multi-line matching for all regexps: 2799 2800 $Expect::Multiline_Matching = 0; 2801 2802You can do that on a per-regexp basis by stating C<(?-m)> inside the regexp 2803(you need perl5.00503 or later for that). 2804 2805 2806=head2 How can I expect on multiple spawned commands? 2807 2808You can use the B<-i> parameter to specify a single object or a list 2809of Expect objects. All following patterns will be evaluated against 2810that list. 2811 2812You can specify B<-i> multiple times to create groups of objects 2813and patterns to match against within the same expect statement. 2814 2815This works just like in Tcl/Expect. 2816 2817See the source example below. 2818 2819 2820=head2 I seem to have problems with ptys! 2821 2822Well, pty handling is really a black magic, as it is extremely system 2823dependent. I have extensively revised IO-Tty, so these problems 2824should be gone. 2825 2826If your system is listed in the "verified" list of IO::Tty, you 2827probably have some non-standard setup, e.g. you compiled your 2828Linux-kernel yourself and disabled ptys. Please ask your friendly 2829sysadmin for help. 2830 2831If your system is not listed, unpack the latest version of IO::Tty, 2832do a 'perl Makefile.PL; make; make test; uname C<-a>' and send me the 2833results and I'll see what I can deduce from that. 2834 2835 2836=head2 I just want to read the output of a process without expect()ing anything. How can I do this? 2837 2838[ Are you sure you need Expect for this? How about qx() or open("prog|")? ] 2839 2840By using expect without any patterns to match. 2841 2842 $process->expect(undef); # Forever until EOF 2843 $process->expect($timeout); # For a few seconds 2844 $process->expect(0); # Is there anything ready on the handle now? 2845 2846 2847=head2 Ok, so now how do I get what was read on the handle? 2848 2849 $read = $process->before(); 2850 2851 2852=head2 Where's IO::Pty? 2853 2854Find it on CPAN as IO-Tty, which provides both. 2855 2856 2857=head2 How come when I automate the passwd program to change passwords for me passwd dies before changing the password sometimes/every time? 2858 2859What's happening is you are closing the handle before passwd exits. 2860When you close the handle to a process, it is sent a signal (SIGPIPE?) 2861telling it that STDOUT has gone away. The default behavior for 2862processes is to die in this circumstance. Two ways you can make this 2863not happen are: 2864 2865 $process->soft_close(); 2866 2867This will wait 15 seconds for a process to come up with an EOF by 2868itself before killing it. 2869 2870 $process->expect(undef); 2871 2872This will wait forever for the process to match an empty set of 2873patterns. It will return when the process hits an EOF. 2874 2875As a rule, you should always expect() the result of your transaction 2876before you continue with processing. 2877 2878 2879=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()? 2880 2881Output is only printed to the logfile/group when Expect reads from the 2882process, during expect(), send_slow() and interconnect(). 2883One way you can force this is to make use of 2884 2885 $process->expect(undef); 2886 2887and 2888 2889 $process->expect(0); 2890 2891which will make expect() run with an empty pattern set forever or just 2892for an instant to capture the output of $process. The output is 2893available in the accumulator, so you can grab it using 2894$process->before(). 2895 2896 2897=head2 I seem to have problems with terminal settings, double echoing, etc. 2898 2899Tty settings are a major pain to keep track of. If you find unexpected 2900behavior such as double-echoing or a frozen session, doublecheck the 2901documentation for default settings. When in doubt, handle them 2902yourself using $exp->stty() and manual_stty() functions. As of .98 2903you shouldn't have to worry about stty settings getting fouled unless 2904you use interconnect or intentionally change them (like doing -echo to 2905get a password). 2906 2907If you foul up your terminal's tty settings, kill any hung processes 2908and enter 'stty sane' at a shell prompt. This should make your 2909terminal manageable again. 2910 2911Note that IO::Tty returns ptys with your systems default setting 2912regarding echoing, CRLF translation etc. and Expect does not change 2913them. I have considered setting the ptys to 'raw' without any 2914translation whatsoever, but this would break a lot of existing things, 2915as '\r' translation would not work anymore. On the other hand, a raw 2916pty works much like a pipe and is more WYGIWYE (what you get is what 2917you expect), so I suggest you set it to 'raw' by yourself: 2918 2919 $exp = Expect->new; 2920 $exp->raw_pty(1); 2921 $exp->spawn(...); 2922 2923To disable echo: 2924 2925 $exp->slave->stty(qw(-echo)); 2926 2927 2928=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. 2929 2930You have to set the terminal screen size for that. Luckily, IO::Pty 2931already has a method for that, so modify your code to look like this: 2932 2933 my $exp = Expect->new; 2934 $exp->slave->clone_winsize_from(\*STDIN); 2935 $exp->spawn("telnet somehost); 2936 2937Also, some applications need the TERM shell variable set so they know 2938how to move the cursor across the screen. When logging in, the remote 2939shell sends a query (Ctrl-Z I think) and expects the terminal to 2940answer with a string, e.g. 'xterm'. If you really want to go that way 2941(be aware, madness lies at its end), you can handle that and send back 2942the value in $ENV{TERM}. This is only a hand-waving explanation, 2943please figure out the details by yourself. 2944 2945 2946=head2 I set the terminal size as explained above, but if I resize the window, the application does not notice this. 2947 2948You have to catch the signal WINCH ("window size changed"), change the 2949terminal size and propagate the signal to the spawned application: 2950 2951 my $exp = Expect->new; 2952 $exp->slave->clone_winsize_from(\*STDIN); 2953 $exp->spawn("ssh somehost); 2954 $SIG{WINCH} = \&winch; 2955 2956 sub winch { 2957 $exp->slave->clone_winsize_from(\*STDIN); 2958 kill WINCH => $exp->pid if $exp->pid; 2959 $SIG{WINCH} = \&winch; 2960 } 2961 2962 $exp->interact(); 2963 2964There is an example file ssh.pl in the examples/ subdir that shows how 2965this works with ssh. Please note that I do strongly object against 2966using Expect to automate ssh login, as there are better way to do that 2967(see L<ssh-keygen>). 2968 2969=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? 2970 2971That means you are anal-retentive. :-) [Gotcha there!] 2972 2973 2974=head2 I get a "Could not assign a pty" error when running as a non-root user on an IRIX box? 2975 2976The OS may not be configured to grant additional pty's (pseudo terminals) 2977to non-root users. /usr/sbin/mkpts should be 4755, not 700 for this 2978to work. I don't know about security implications if you do this. 2979 2980 2981=head2 How come I don't notice when the spawned process closes its stdin/out/err?? 2982 2983You are probably on one of the systems where the master doesn't get an 2984EOF when the slave closes stdin/out/err. 2985 2986One possible solution is when you spawn a process, follow it with a 2987unique string that would indicate the process is finished. 2988 2989 $process = Expect->spawn('telnet somehost; echo ____END____'); 2990 2991And then $process->expect($timeout,'____END____','other','patterns'); 2992 2993 2994=head1 Source Examples 2995 2996 2997=head2 How to automate login 2998 2999 my $telnet = Net::Telnet->new("remotehost") # see Net::Telnet 3000 or die "Cannot telnet to remotehost: $!\n";; 3001 my $exp = Expect->exp_init($telnet); 3002 3003 # deprecated use of spawned telnet command 3004 # my $exp = Expect->spawn("telnet localhost") 3005 # or die "Cannot spawn telnet: $!\n";; 3006 3007 my $spawn_ok; 3008 $exp->expect($timeout, 3009 [ 3010 qr'login: $', 3011 sub { 3012 $spawn_ok = 1; 3013 my $fh = shift; 3014 $fh->send("$username\n"); 3015 exp_continue; 3016 } 3017 ], 3018 [ 3019 'Password: $', 3020 sub { 3021 my $fh = shift; 3022 print $fh "$password\n"; 3023 exp_continue; 3024 } 3025 ], 3026 [ 3027 eof => 3028 sub { 3029 if ($spawn_ok) { 3030 die "ERROR: premature EOF in login.\n"; 3031 } else { 3032 die "ERROR: could not spawn telnet.\n"; 3033 } 3034 } 3035 ], 3036 [ 3037 timeout => 3038 sub { 3039 die "No login.\n"; 3040 } 3041 ], 3042 '-re', qr'[#>:] $', #' wait for shell prompt, then exit expect 3043 ); 3044 3045 3046=head2 How to expect on multiple spawned commands 3047 3048 foreach my $cmd (@list_of_commands) { 3049 push @commands, Expect->spawn($cmd); 3050 } 3051 3052 expect($timeout, 3053 '-i', \@commands, 3054 [ 3055 qr"pattern", # find this pattern in output of all commands 3056 sub { 3057 my $obj = shift; # object that matched 3058 print $obj "something\n"; 3059 exp_continue; # we don't want to terminate the expect call 3060 } 3061 ], 3062 '-i', $some_other_command, 3063 [ 3064 "some other pattern", 3065 sub { 3066 my ($obj, $parmref) = @_; 3067 # ... 3068 3069 # now we exit the expect command 3070 }, 3071 \$parm 3072 ], 3073 ); 3074 3075 3076=head2 How to propagate terminal sizes 3077 3078 my $exp = Expect->new; 3079 $exp->slave->clone_winsize_from(\*STDIN); 3080 $exp->spawn("ssh somehost); 3081 $SIG{WINCH} = \&winch; 3082 3083 sub winch { 3084 $exp->slave->clone_winsize_from(\*STDIN); 3085 kill WINCH => $exp->pid if $exp->pid; 3086 $SIG{WINCH} = \&winch; 3087 } 3088 3089 $exp->interact(); 3090 3091=head1 HOMEPAGE 3092 3093L<http://sourceforge.net/projects/expectperl/> though the source code is now in GitHub: L<https://github.com/jacoby/expect.pm> 3094 3095 3096=head1 MAILING LISTS 3097 3098There are two mailing lists available, expectperl-announce and 3099expectperl-discuss, at 3100 3101 http://lists.sourceforge.net/lists/listinfo/expectperl-announce 3102 3103and 3104 3105 http://lists.sourceforge.net/lists/listinfo/expectperl-discuss 3106 3107 3108=head1 BUG TRACKING 3109 3110You can use the CPAN Request Tracker http://rt.cpan.org/ and submit 3111new bugs under 3112 3113 http://rt.cpan.org/Ticket/Create.html?Queue=Expect 3114 3115 3116=head1 AUTHORS 3117 3118(c) 1997 Austin Schutz E<lt>F<ASchutz@users.sourceforge.net>E<gt> (retired) 3119 3120expect() interface & functionality enhancements (c) 1999-2006 Roland Giersig. 3121 3122This module is now maintained by Dave Jacoby E<lt>F<jacoby@cpan.org>E<gt> 3123 3124=head1 LICENSE 3125 3126This module can be used under the same terms as Perl. 3127 3128 3129=head1 DISCLAIMER 3130 3131THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED 3132WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 3133MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. 3134IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, 3135INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 3136BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS 3137OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 3138ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR 3139TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE 3140USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH 3141DAMAGE. 3142 3143In other words: Use at your own risk. Provided as is. Your mileage 3144may vary. Read the source, Luke! 3145 3146And finally, just to be sure: 3147 3148Any Use of This Product, in Any Manner Whatsoever, Will Increase the 3149Amount of Disorder in the Universe. Although No Liability Is Implied 3150Herein, the Consumer Is Warned That This Process Will Ultimately Lead 3151to the Heat Death of the Universe. 3152 3153=cut 3154