| 1 | # -*-cperl-*- |
| 2 | # Please see the .pod files for documentation. This module is copyrighted |
| 3 | # as per the usual perl legalese: |
| 4 | # Copyright (c) 1997 Austin Schutz. |
| 5 | # expect() interface & functionality enhancements (c) 1999 Roland Giersig. |
| 6 | # |
| 7 | # All rights reserved. This program is free software; you can |
| 8 | # redistribute it and/or modify it under the same terms as Perl |
| 9 | # itself. |
| 10 | # |
| 11 | # Don't blame/flame me if you bust your stuff. |
| 12 | # Austin Schutz <ASchutz@users.sourceforge.net> |
| 13 | # |
| 14 | # This module now is maintained by |
| 15 | # Roland Giersig <RGiersig@cpan.org> |
| 16 | # |
| 17 | |
| 18 | use 5.006; # 4 won't cut it. |
| 19 | |
| 20 | package Expect; |
| 21 | |
| 22 | use IO::Pty 1.03; # We need make_slave_controlling_terminal() |
| 23 | use IO::Tty; |
| 24 | |
| 25 | use strict 'refs'; |
| 26 | use strict 'vars'; |
| 27 | use strict 'subs'; |
| 28 | use POSIX; # For setsid. |
| 29 | use Fcntl; # For checking file handle settings. |
| 30 | use Carp qw(cluck croak carp confess); |
| 31 | use IO::Handle; |
| 32 | use Exporter; |
| 33 | |
| 34 | # This is necessary to make routines within Expect work. |
| 35 | |
| 36 | @Expect::ISA = qw(IO::Pty Exporter); |
| 37 | @Expect::EXPORT = qw(expect exp_continue exp_continue_timeout); |
| 38 | |
| 39 | BEGIN { |
| 40 | $Expect::VERSION = '1.20'; |
| 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::Manual_Stty = 0; |
| 51 | $Expect::Multiline_Matching = 1; |
| 52 | $Expect::Do_Soft_Close = 0; |
| 53 | @Expect::Before_List = (); |
| 54 | @Expect::After_List = (); |
| 55 | %Expect::Spawned_PIDs = (); |
| 56 | } |
| 57 | |
| 58 | sub version { |
| 59 | my($version) = shift; |
| 60 | warn "Version $version is later than $Expect::VERSION. It may not be supported" if (defined ($version) && ($version > $Expect::VERSION)); |
| 61 | |
| 62 | die "Versions before 1.03 are not supported in this release" if ((defined ($version)) && ($version < 1.03)); |
| 63 | return $Expect::VERSION; |
| 64 | } |
| 65 | |
| 66 | sub new { |
| 67 | |
| 68 | my ($class) = shift; |
| 69 | $class = ref($class) if ref($class); # so we can be called as $exp->new() |
| 70 | |
| 71 | # Create the pty which we will use to pass process info. |
| 72 | my($self) = new IO::Pty; |
| 73 | die "$class: Could not assign a pty" unless $self; |
| 74 | bless $self => $class; |
| 75 | $self->autoflush(1); |
| 76 | |
| 77 | # This is defined here since the default is different for |
| 78 | # initialized handles as opposed to spawned processes. |
| 79 | ${*$self}{exp_Log_Stdout} = 1; |
| 80 | $self->_init_vars(); |
| 81 | |
| 82 | if (@_) { |
| 83 | # we got add'l parms, so pass them to spawn |
| 84 | return $self->spawn(@_); |
| 85 | } |
| 86 | return $self; |
| 87 | } |
| 88 | |
| 89 | sub spawn { |
| 90 | my ($class) = shift; |
| 91 | my $self; |
| 92 | |
| 93 | if (ref($class)) { |
| 94 | $self = $class; |
| 95 | } else { |
| 96 | $self = $class->new(); |
| 97 | } |
| 98 | |
| 99 | croak "Cannot reuse an object with an already spawned command" |
| 100 | if exists ${*$self}{"exp_Command"}; |
| 101 | my(@cmd) = @_; # spawn is passed command line args. |
| 102 | ${*$self}{"exp_Command"} = \@cmd; |
| 103 | |
| 104 | # set up pipe to detect childs exec error |
| 105 | pipe(FROM_CHILD, TO_PARENT) or die "Cannot open pipe: $!"; |
| 106 | pipe(FROM_PARENT, TO_CHILD) or die "Cannot open pipe: $!"; |
| 107 | TO_PARENT->autoflush(1); |
| 108 | TO_CHILD->autoflush(1); |
| 109 | eval { |
| 110 | fcntl(TO_PARENT, F_SETFD, FD_CLOEXEC); |
| 111 | }; |
| 112 | |
| 113 | my $pid = fork; |
| 114 | |
| 115 | unless (defined ($pid)) { |
| 116 | warn "Cannot fork: $!" if $^W; |
| 117 | return undef; |
| 118 | } |
| 119 | |
| 120 | if($pid) { |
| 121 | # parent |
| 122 | my $errno; |
| 123 | ${*$self}{exp_Pid} = $pid; |
| 124 | close TO_PARENT; |
| 125 | close FROM_PARENT; |
| 126 | $self->close_slave(); |
| 127 | $self->set_raw() if $self->raw_pty and isatty($self); |
| 128 | close TO_CHILD; # so child gets EOF and can go ahead |
| 129 | |
| 130 | # now wait for child exec (eof due to close-on-exit) or exec error |
| 131 | my $errstatus = sysread(FROM_CHILD, $errno, 256); |
| 132 | die "Cannot sync with child: $!" if not defined $errstatus; |
| 133 | close FROM_CHILD; |
| 134 | if ($errstatus) { |
| 135 | $! = $errno+0; |
| 136 | warn "Cannot exec(@cmd): $!\n" if $^W; |
| 137 | return undef; |
| 138 | } |
| 139 | } |
| 140 | else { |
| 141 | # child |
| 142 | close FROM_CHILD; |
| 143 | close TO_CHILD; |
| 144 | |
| 145 | $self->make_slave_controlling_terminal(); |
| 146 | my $slv = $self->slave() |
| 147 | or die "Cannot get slave: $!"; |
| 148 | |
| 149 | $slv->set_raw() if $self->raw_pty; |
| 150 | close($self); |
| 151 | |
| 152 | # wait for parent before we detach |
| 153 | my $buffer; |
| 154 | my $errstatus = sysread(FROM_PARENT, $buffer, 256); |
| 155 | die "Cannot sync with parent: $!" if not defined $errstatus; |
| 156 | close FROM_PARENT; |
| 157 | |
| 158 | close(STDIN); |
| 159 | open(STDIN,"<&". $slv->fileno()) |
| 160 | or die "Couldn't reopen STDIN for reading, $!\n"; |
| 161 | close(STDOUT); |
| 162 | open(STDOUT,">&". $slv->fileno()) |
| 163 | or die "Couldn't reopen STDOUT for writing, $!\n"; |
| 164 | close(STDERR); |
| 165 | open(STDERR,">&". $slv->fileno()) |
| 166 | or die "Couldn't reopen STDERR for writing, $!\n"; |
| 167 | |
| 168 | { exec(@cmd) }; |
| 169 | print TO_PARENT $!+0; |
| 170 | die "Cannot exec(@cmd): $!\n"; |
| 171 | } |
| 172 | |
| 173 | # This is sort of for code compatibility, and to make debugging a little |
| 174 | # easier. By code compatibility I mean that previously the process's |
| 175 | # handle was referenced by $process{Pty_Handle} instead of just $process. |
| 176 | # This is almost like 'naming' the handle to the process. |
| 177 | # I think this also reflects Tcl Expect-like behavior. |
| 178 | ${*$self}{exp_Pty_Handle} = "spawn id(".$self->fileno().")"; |
| 179 | if ((${*$self}{"exp_Debug"}) or (${*$self}{"exp_Exp_Internal"})) { |
| 180 | cluck("Spawned '@cmd'\r\n", |
| 181 | "\t${*$self}{exp_Pty_Handle}\r\n", |
| 182 | "\tPid: ${*$self}{exp_Pid}\r\n", |
| 183 | "\tTty: ".$self->SUPER::ttyname()."\r\n", |
| 184 | ); |
| 185 | } |
| 186 | $Expect::Spawned_PIDs{${*$self}{exp_Pid}} = undef; |
| 187 | return $self; |
| 188 | } |
| 189 | |
| 190 | |
| 191 | sub exp_init { |
| 192 | # take a filehandle, for use later with expect() or interconnect() . |
| 193 | # All the functions are written for reading from a tty, so if the naming |
| 194 | # scheme looks odd, that's why. |
| 195 | my ($class) = shift; |
| 196 | my($self) = shift; |
| 197 | bless $self, $class; |
| 198 | croak "exp_init not passed a file object, stopped" |
| 199 | unless defined($self->fileno()); |
| 200 | $self->autoflush(1); |
| 201 | # Define standard variables.. debug states, etc. |
| 202 | $self->_init_vars(); |
| 203 | # Turn of logging. By default we don't want crap from a file to get spewed |
| 204 | # on screen as we read it. |
| 205 | ${*$self}{exp_Log_Stdout} = 0; |
| 206 | ${*$self}{exp_Pty_Handle} = "handle id(".$self->fileno().")"; |
| 207 | ${*$self}{exp_Pty_Handle} = "STDIN" if $self->fileno() == fileno (STDIN); |
| 208 | print STDERR "Initialized ${*$self}{exp_Pty_Handle}.'\r\n" |
| 209 | if ${*$self}{"exp_Debug"}; |
| 210 | return $self; |
| 211 | } |
| 212 | |
| 213 | # make an alias |
| 214 | *init = \&exp_init; |
| 215 | |
| 216 | ###################################################################### |
| 217 | # We're happy OOP people. No direct access to stuff. |
| 218 | # For standard read-writeable parameters, we define some autoload magic... |
| 219 | my %Writeable_Vars = ( debug => 'exp_Debug', |
| 220 | exp_internal => 'exp_Exp_Internal', |
| 221 | do_soft_close => 'exp_Do_Soft_Close', |
| 222 | max_accum => 'exp_Max_Accum', |
| 223 | match_max => 'exp_Max_Accum', |
| 224 | notransfer => 'exp_NoTransfer', |
| 225 | log_stdout => 'exp_Log_Stdout', |
| 226 | log_user => 'exp_Log_Stdout', |
| 227 | log_group => 'exp_Log_Group', |
| 228 | manual_stty => 'exp_Manual_Stty', |
| 229 | restart_timeout_upon_receive => 'exp_Continue', |
| 230 | raw_pty => 'exp_Raw_Pty', |
| 231 | ); |
| 232 | my %Readable_Vars = ( pid => 'exp_Pid', |
| 233 | exp_pid => 'exp_Pid', |
| 234 | exp_match_number => 'exp_Match_Number', |
| 235 | match_number => 'exp_Match_Number', |
| 236 | exp_error => 'exp_Error', |
| 237 | error => 'exp_Error', |
| 238 | exp_command => 'exp_Command', |
| 239 | command => 'exp_Command', |
| 240 | exp_match => 'exp_Match', |
| 241 | match => 'exp_Match', |
| 242 | exp_matchlist => 'exp_Matchlist', |
| 243 | matchlist => 'exp_Matchlist', |
| 244 | exp_before => 'exp_Before', |
| 245 | before => 'exp_Before', |
| 246 | exp_after => 'exp_After', |
| 247 | after => 'exp_After', |
| 248 | exp_exitstatus => 'exp_Exit', |
| 249 | exitstatus => 'exp_Exit', |
| 250 | exp_pty_handle => 'exp_Pty_Handle', |
| 251 | pty_handle => 'exp_Pty_Handle', |
| 252 | exp_logfile => 'exp_Log_File', |
| 253 | logfile => 'exp_Log_File', |
| 254 | %Writeable_Vars, |
| 255 | ); |
| 256 | |
| 257 | sub AUTOLOAD { |
| 258 | my $self = shift; |
| 259 | my $type = ref($self) |
| 260 | or croak "$self is not an object"; |
| 261 | |
| 262 | use vars qw($AUTOLOAD); |
| 263 | my $name = $AUTOLOAD; |
| 264 | $name =~ s/.*:://; # strip fully-qualified portion |
| 265 | |
| 266 | unless (exists $Readable_Vars{$name}) { |
| 267 | croak "ERROR: cannot find method `$name' in class $type"; |
| 268 | } |
| 269 | my $varname = $Readable_Vars{$name}; |
| 270 | my $tmp; |
| 271 | $tmp = ${*$self}{$varname} if exists ${*$self}{$varname}; |
| 272 | |
| 273 | if (@_) { |
| 274 | if (exists $Writeable_Vars{$name}) { |
| 275 | my $ref = ref($tmp); |
| 276 | if ($ref eq 'ARRAY') { |
| 277 | ${*$self}{$varname} = [ @_ ]; |
| 278 | } elsif ($ref eq 'HASH') { |
| 279 | ${*$self}{$varname} = { @_ }; |
| 280 | } else { |
| 281 | ${*$self}{$varname} = shift; |
| 282 | } |
| 283 | } else { |
| 284 | carp "Trying to set read-only variable `$name'" |
| 285 | if $^W; |
| 286 | } |
| 287 | } |
| 288 | |
| 289 | my $ref = ref($tmp); |
| 290 | return (wantarray? @{$tmp} : $tmp) if ($ref eq 'ARRAY'); |
| 291 | return (wantarray? %{$tmp} : $tmp) if ($ref eq 'HASH'); |
| 292 | return $tmp; |
| 293 | } |
| 294 | |
| 295 | ###################################################################### |
| 296 | |
| 297 | sub set_seq { |
| 298 | # Set an escape sequence/function combo for a read handle for interconnect. |
| 299 | # Ex: $read_handle->set_seq('\17',\&function,\@parameters); |
| 300 | my($self) = shift; |
| 301 | my($escape_sequence,$function) = (shift,shift); |
| 302 | ${${*$self}{exp_Function}}{$escape_sequence} = $function; |
| 303 | if ((!defined($function)) ||($function eq 'undef')) { |
| 304 | ${${*$self}{exp_Function}}{$escape_sequence} = \&_undef; |
| 305 | } |
| 306 | ${${*$self}{exp_Parameters}}{$escape_sequence} = shift; |
| 307 | # This'll be a joy to execute. :) |
| 308 | if ( ${*$self}{"exp_Debug"} ) { |
| 309 | print STDERR "Escape seq. '" . $escape_sequence; |
| 310 | print STDERR "' function for ${*$self}{exp_Pty_Handle} set to '"; |
| 311 | print STDERR ${${*$self}{exp_Function}}{$escape_sequence}; |
| 312 | print STDERR "(" . join(',', @_) . ")'\r\n"; |
| 313 | } |
| 314 | } |
| 315 | |
| 316 | sub set_group { |
| 317 | my($self) = shift; |
| 318 | my($write_handle); |
| 319 | # Make sure we can read from the read handle |
| 320 | if (! defined($_[0])) { |
| 321 | if (defined (${*$self}{exp_Listen_Group})) { |
| 322 | return @{${*$self}{exp_Listen_Group}}; |
| 323 | } else { |
| 324 | # Refrain from referencing an undef |
| 325 | return undef; |
| 326 | } |
| 327 | } |
| 328 | @{${*$self}{exp_Listen_Group}} = (); |
| 329 | if ($self->_get_mode() !~ 'r') { |
| 330 | warn("Attempting to set a handle group on ${*$self}{exp_Pty_Handle}, ", |
| 331 | "a non-readable handle!\r\n"); |
| 332 | } |
| 333 | while ($write_handle = shift) { |
| 334 | if ($write_handle->_get_mode() !~ 'w') { |
| 335 | warn("Attempting to set a non-writeable listen handle ", |
| 336 | "${*$write_handle}{exp_Pty_handle} for ", |
| 337 | "${*$self}{exp_Pty_Handle}!\r\n"); |
| 338 | } |
| 339 | push (@{${*$self}{exp_Listen_Group}},$write_handle); |
| 340 | } |
| 341 | } |
| 342 | |
| 343 | sub log_file { |
| 344 | my $self = shift; |
| 345 | |
| 346 | return(${*$self}{exp_Log_File}) |
| 347 | if not @_; # we got no param, return filehandle |
| 348 | |
| 349 | my $file = shift; |
| 350 | my $mode = shift || "a"; |
| 351 | |
| 352 | if (${*$self}{exp_Log_File} and ref(${*$self}{exp_Log_File}) ne 'CODE') { |
| 353 | close(${*$self}{exp_Log_File}); |
| 354 | } |
| 355 | ${*$self}{exp_Log_File} = undef; |
| 356 | return if (not $file); |
| 357 | my $fh = $file; |
| 358 | if (not ref($file)) { |
| 359 | # it's a filename |
| 360 | $fh = new IO::File $file, $mode |
| 361 | or croak "Cannot open logfile $file: $!"; |
| 362 | } |
| 363 | if (ref($file) ne 'CODE') { |
| 364 | croak "Given logfile doesn't have a 'print' method" |
| 365 | if not $fh->can("print"); |
| 366 | $fh->autoflush(1); # so logfile is up to date |
| 367 | } |
| 368 | |
| 369 | ${*$self}{exp_Log_File} = $fh; |
| 370 | } |
| 371 | |
| 372 | |
| 373 | # I'm going to leave this here in case I might need to change something. |
| 374 | # Previously this was calling `stty`, in a most bastardized manner. |
| 375 | sub exp_stty { |
| 376 | my($self) = shift; |
| 377 | my($mode) = "@_"; |
| 378 | |
| 379 | return undef unless defined($mode); |
| 380 | if (not defined $INC{"IO/Stty.pm"}) { |
| 381 | carp "IO::Stty not installed, cannot change mode"; |
| 382 | return undef; |
| 383 | } |
| 384 | |
| 385 | if (${*$self}{"exp_Debug"}) { |
| 386 | print STDERR "Setting ${*$self}{exp_Pty_Handle} to tty mode '$mode'\r\n"; |
| 387 | } |
| 388 | unless (POSIX::isatty($self)) { |
| 389 | if (${*$self}{"exp_Debug"} or $^W) { |
| 390 | warn "${*$self}{exp_Pty_Handle} is not a tty. Not changing mode"; |
| 391 | } |
| 392 | return ''; # No undef to avoid warnings elsewhere. |
| 393 | } |
| 394 | IO::Stty::stty($self, split(/\s/,$mode)); |
| 395 | } |
| 396 | |
| 397 | *stty = \&exp_stty; |
| 398 | |
| 399 | # If we want to clear the buffer. Otherwise Accum will grow during send_slow |
| 400 | # etc. and contain the remainder after matches. |
| 401 | sub clear_accum { |
| 402 | my ($self) = shift; |
| 403 | my ($temp) = (${*$self}{exp_Accum}); |
| 404 | ${*$self}{exp_Accum} = ''; |
| 405 | # return the contents of the accumulator. |
| 406 | return $temp; |
| 407 | } |
| 408 | |
| 409 | sub set_accum { |
| 410 | my ($self) = shift; |
| 411 | my ($temp) = (${*$self}{exp_Accum}); |
| 412 | ${*$self}{exp_Accum} = shift; |
| 413 | # return the contents of the accumulator. |
| 414 | return $temp; |
| 415 | } |
| 416 | |
| 417 | ###################################################################### |
| 418 | # define constants for pattern subs |
| 419 | sub exp_continue() { "exp_continue" } |
| 420 | sub exp_continue_timeout() { "exp_continue_timeout" } |
| 421 | |
| 422 | ###################################################################### |
| 423 | # Expect on multiple objects at once. |
| 424 | # |
| 425 | # Call as Expect::expect($timeout, -i => \@exp_list, @patternlist, |
| 426 | # -i => $exp, @pattern_list, ...); |
| 427 | # or $exp->expect($timeout, @patternlist, -i => \@exp_list, @patternlist, |
| 428 | # -i => $exp, @pattern_list, ...); |
| 429 | # |
| 430 | # Patterns are arrays that consist of |
| 431 | # [ $pattern_type, $pattern, $sub, @subparms ] |
| 432 | # |
| 433 | # Optional $pattern_type is '-re' (RegExp, default) or '-ex' (exact); |
| 434 | # |
| 435 | # $sub is optional CODE ref, which is called as &{$sub}($exp, @subparms) |
| 436 | # if pattern matched; may return exp_continue or exp_continue_timeout. |
| 437 | # |
| 438 | # Old-style syntax (pure pattern strings with optional type) also supported. |
| 439 | # |
| 440 | |
| 441 | sub expect { |
| 442 | my $self; |
| 443 | print STDERR ("expect(@_) called...\n") if $Expect::Debug; |
| 444 | if (defined($_[0])) { |
| 445 | if (ref($_[0]) and $_[0]->isa('Expect')) { |
| 446 | $self = shift; |
| 447 | } elsif ($_[0] eq 'Expect') { |
| 448 | shift; # or as Expect->expect |
| 449 | } |
| 450 | } |
| 451 | croak "expect(): not enough arguments, should be expect(timeout, [patterns...])" if @_ < 1; |
| 452 | my $timeout = shift; |
| 453 | my $timeout_hook = undef; |
| 454 | |
| 455 | my @object_list; |
| 456 | my %patterns; |
| 457 | |
| 458 | my @pattern_list; |
| 459 | my @timeout_list; |
| 460 | my $curr_list; |
| 461 | |
| 462 | if ($self) { |
| 463 | $curr_list = [$self]; |
| 464 | } else { |
| 465 | # called directly, so first parameter must be '-i' to establish |
| 466 | # object list. |
| 467 | $curr_list = []; |
| 468 | croak "expect(): ERROR: if called directly (not as \$obj->expect(...), but as Expect::expect(...), first parameter MUST be '-i' to set an object (list) for the patterns to work on." |
| 469 | if ($_[0] ne '-i'); |
| 470 | } |
| 471 | # Let's make a list of patterns wanting to be evaled as regexps. |
| 472 | my $parm; |
| 473 | my $parm_nr = 1; |
| 474 | while (defined($parm = shift)) { |
| 475 | print STDERR ("expect(): handling param '$parm'...\n") if $Expect::Debug; |
| 476 | if (ref($parm)) { |
| 477 | if (ref($parm) eq 'ARRAY') { |
| 478 | my $err = _add_patterns_to_list(\@pattern_list, \@timeout_list, |
| 479 | $parm_nr, $parm); |
| 480 | carp ("expect(): Warning: multiple `timeout' patterns (", |
| 481 | scalar(@timeout_list), ").\r\n") |
| 482 | if @timeout_list > 1; |
| 483 | $timeout_hook = $timeout_list[-1] if $timeout_list[-1]; |
| 484 | croak $err if $err; |
| 485 | $parm_nr++; |
| 486 | } else { |
| 487 | croak ("expect(): Unknown pattern ref $parm"); |
| 488 | } |
| 489 | } else { |
| 490 | # not a ref, is an option or raw pattern |
| 491 | if (substr($parm, 0, 1) eq '-') { |
| 492 | # it's an option |
| 493 | print STDERR ("expect(): handling option '$parm'...\n") |
| 494 | if $Expect::Debug; |
| 495 | if ($parm eq '-i') { |
| 496 | # first add collected patterns to object list |
| 497 | if (scalar(@$curr_list)) { |
| 498 | push @object_list, $curr_list if not exists $patterns{"$curr_list"}; |
| 499 | push @{$patterns{"$curr_list"}}, @pattern_list; |
| 500 | @pattern_list = (); |
| 501 | } |
| 502 | # now put parm(s) into current object list |
| 503 | if (ref($_[0]) eq 'ARRAY') { |
| 504 | $curr_list = shift; |
| 505 | } else { |
| 506 | $curr_list = [ shift ]; |
| 507 | } |
| 508 | } elsif ($parm eq '-re' |
| 509 | or $parm eq '-ex') { |
| 510 | if (ref($_[1]) eq 'CODE') { |
| 511 | push @pattern_list, [ $parm_nr, $parm, shift, shift ]; |
| 512 | } else { |
| 513 | push @pattern_list, [ $parm_nr, $parm, shift, undef ]; |
| 514 | } |
| 515 | $parm_nr++; |
| 516 | } else { |
| 517 | croak ("Unknown option $parm"); |
| 518 | } |
| 519 | } else { |
| 520 | # a plain pattern, check if it is followed by a CODE ref |
| 521 | if (ref($_[0]) eq 'CODE') { |
| 522 | if ($parm eq 'timeout') { |
| 523 | push @timeout_list, shift; |
| 524 | carp ("expect(): Warning: multiple `timeout' patterns (", |
| 525 | scalar(@timeout_list), ").\r\n") |
| 526 | if @timeout_list > 1; |
| 527 | $timeout_hook = $timeout_list[-1] if $timeout_list[-1]; |
| 528 | } elsif ($parm eq 'eof') { |
| 529 | push @pattern_list, [ $parm_nr, "-$parm", undef, shift ]; |
| 530 | } else { |
| 531 | push @pattern_list, [ $parm_nr, '-ex', $parm, shift ]; |
| 532 | } |
| 533 | } else { |
| 534 | print STDERR ("expect(): exact match '$parm'...\n") |
| 535 | if $Expect::Debug; |
| 536 | push @pattern_list, [ $parm_nr, '-ex', $parm, undef ]; |
| 537 | } |
| 538 | $parm_nr++; |
| 539 | } |
| 540 | } |
| 541 | } |
| 542 | |
| 543 | # add rest of collected patterns to object list |
| 544 | carp "expect(): Empty object list" unless $curr_list; |
| 545 | push @object_list, $curr_list if not exists $patterns{"$curr_list"}; |
| 546 | push @{$patterns{"$curr_list"}}, @pattern_list; |
| 547 | |
| 548 | my $debug = $self ? ${*$self}{exp_Debug} : $Expect::Debug; |
| 549 | my $internal = $self ? ${*$self}{exp_Exp_Internal} : $Expect::Exp_Internal; |
| 550 | |
| 551 | # now start matching... |
| 552 | |
| 553 | if (@Expect::Before_List) { |
| 554 | print STDERR ("Starting BEFORE pattern matching...\r\n") |
| 555 | if ($debug or $internal); |
| 556 | _multi_expect(0, undef, @Expect::Before_List); |
| 557 | } |
| 558 | |
| 559 | cluck ("Starting EXPECT pattern matching...\r\n") |
| 560 | if ($debug or $internal); |
| 561 | my @ret; |
| 562 | @ret = _multi_expect($timeout, $timeout_hook, |
| 563 | map { [$_, @{$patterns{"$_"}}] } @object_list); |
| 564 | |
| 565 | if (@Expect::After_List) { |
| 566 | print STDERR ("Starting AFTER pattern matching...\r\n") |
| 567 | if ($debug or $internal); |
| 568 | _multi_expect(0, undef, @Expect::After_List); |
| 569 | } |
| 570 | |
| 571 | wantarray ? @ret : $ret[0]; |
| 572 | } |
| 573 | |
| 574 | ###################################################################### |
| 575 | # the real workhorse |
| 576 | # |
| 577 | sub _multi_expect($$@) { |
| 578 | my $timeout = shift; |
| 579 | my $timeout_hook = shift; |
| 580 | |
| 581 | if ($timeout_hook) { |
| 582 | croak "Unknown timeout_hook type $timeout_hook" |
| 583 | unless (ref($timeout_hook) eq 'CODE' |
| 584 | or ref($timeout_hook) eq 'ARRAY'); |
| 585 | } |
| 586 | |
| 587 | foreach my $pat (@_) { |
| 588 | my @patterns = @{$pat}[1..$#{$pat}]; |
| 589 | foreach my $exp (@{$pat->[0]}) { |
| 590 | ${*$exp}{exp_New_Data} = 1; # first round we always try to match |
| 591 | if (exists ${*$exp}{"exp_Max_Accum"} and ${*$exp}{"exp_Max_Accum"}) { |
| 592 | ${*$exp}{exp_Accum} = |
| 593 | $exp->_trim_length(${*$exp}{exp_Accum}, |
| 594 | ${*$exp}{exp_Max_Accum}); |
| 595 | } |
| 596 | print STDERR ("${*$exp}{exp_Pty_Handle}: beginning expect.\r\n", |
| 597 | "\tTimeout: ", |
| 598 | (defined($timeout) ? $timeout : "unlimited" ), |
| 599 | " seconds.\r\n", |
| 600 | "\tCurrent time: ". localtime(). "\r\n", |
| 601 | ) if $Expect::Debug; |
| 602 | |
| 603 | # What are we expecting? What do you expect? :-) |
| 604 | if (${*$exp}{exp_Exp_Internal}) { |
| 605 | print STDERR "${*$exp}{exp_Pty_Handle}: list of patterns:\r\n"; |
| 606 | foreach my $pattern (@patterns) { |
| 607 | print STDERR (' ', |
| 608 | defined($pattern->[0])? |
| 609 | '#'. $pattern->[0].': ' : |
| 610 | '', |
| 611 | $pattern->[1], |
| 612 | " `", _make_readable($pattern->[2]), |
| 613 | "'\r\n"); |
| 614 | } |
| 615 | print STDERR "\r\n"; |
| 616 | } |
| 617 | } |
| 618 | } |
| 619 | |
| 620 | my $successful_pattern; |
| 621 | my $exp_matched; |
| 622 | my $err; |
| 623 | my $before; |
| 624 | my $after; |
| 625 | my $match; |
| 626 | my @matchlist; |
| 627 | |
| 628 | # Set the last loop time to now for time comparisons at end of loop. |
| 629 | my $start_loop_time = time(); |
| 630 | my $exp_cont = 1; |
| 631 | |
| 632 | READLOOP: |
| 633 | while ($exp_cont) { |
| 634 | $exp_cont = 1; |
| 635 | $err = ""; |
| 636 | my $rmask = ''; |
| 637 | my $time_left = undef; |
| 638 | if (defined $timeout) { |
| 639 | $time_left = $timeout - (time() - $start_loop_time); |
| 640 | $time_left = 0 if $time_left < 0; |
| 641 | } |
| 642 | |
| 643 | $exp_matched = undef; |
| 644 | # Test for a match first so we can test the current Accum w/out |
| 645 | # worrying about an EOF. |
| 646 | |
| 647 | foreach my $pat (@_) { |
| 648 | my @patterns = @{$pat}[1..$#{$pat}]; |
| 649 | foreach my $exp (@{$pat->[0]}) { |
| 650 | # build mask for select in next section... |
| 651 | my $fn = $exp->fileno(); |
| 652 | vec($rmask, $fn, 1) = 1 if defined $fn; |
| 653 | |
| 654 | next unless ${*$exp}{exp_New_Data}; |
| 655 | |
| 656 | # clear error status |
| 657 | ${*$exp}{exp_Error} = undef; |
| 658 | |
| 659 | # This could be huge. We should attempt to do something |
| 660 | # about this. Because the output is used for debugging |
| 661 | # I'm of the opinion that showing smaller amounts if the |
| 662 | # total is huge should be ok. |
| 663 | # Thus the 'trim_length' |
| 664 | print STDERR ("\r\n${*$exp}{exp_Pty_Handle}: Does `", |
| 665 | $exp->_trim_length(_make_readable(${*$exp}{exp_Accum})), |
| 666 | "'\r\nmatch:\r\n") |
| 667 | if ${*$exp}{exp_Exp_Internal}; |
| 668 | |
| 669 | # we don't keep the parameter number anymore |
| 670 | # (clashes with before & after), instead the parameter number is |
| 671 | # stored inside the pattern; we keep the pattern ref |
| 672 | # and look up the number later. |
| 673 | foreach my $pattern (@patterns) { |
| 674 | print STDERR (" pattern", |
| 675 | defined($pattern->[0])? ' #' . $pattern->[0] : '', |
| 676 | ": ", $pattern->[1], |
| 677 | " `", _make_readable($pattern->[2]), |
| 678 | "'? ") |
| 679 | if (${*$exp}{exp_Exp_Internal}); |
| 680 | |
| 681 | # Matching exactly |
| 682 | if ($pattern->[1] eq '-ex') { |
| 683 | my $match_index = index(${*$exp}{exp_Accum}, |
| 684 | $pattern->[2]); |
| 685 | |
| 686 | # We matched if $match_index > -1 |
| 687 | if ($match_index > -1) { |
| 688 | $before = substr(${*$exp}{exp_Accum}, 0, $match_index); |
| 689 | $match = substr(${*$exp}{exp_Accum}, $match_index, |
| 690 | length($pattern->[2])); |
| 691 | $after = substr(${*$exp}{exp_Accum}, |
| 692 | $match_index + length($pattern->[2])) ; |
| 693 | ${*$exp}{exp_Before} = $before; |
| 694 | ${*$exp}{exp_Match} = $match; |
| 695 | ${*$exp}{exp_After} = $after; |
| 696 | ${*$exp}{exp_Match_Number} = $pattern->[0]; |
| 697 | $exp_matched = $exp; |
| 698 | } |
| 699 | } elsif ($pattern->[1] eq '-re') { |
| 700 | # m// in array context promises to return an empty list |
| 701 | # but doesn't if the pattern doesn't contain brackets (), |
| 702 | # so we kludge around by adding an empty bracket |
| 703 | # at the end. |
| 704 | |
| 705 | if ($Expect::Multiline_Matching) { |
| 706 | @matchlist = (${*$exp}{exp_Accum} |
| 707 | =~ m/$pattern->[2]()/m); |
| 708 | ($match, $before, $after) = ($&, $`, $'); |
| 709 | } else { |
| 710 | @matchlist = (${*$exp}{exp_Accum} |
| 711 | =~ m/$pattern->[2]()/); |
| 712 | ($match, $before, $after) = ($&, $`, $'); |
| 713 | } |
| 714 | if (@matchlist) { |
| 715 | # Matching regexp |
| 716 | ${*$exp}{exp_Before} = $before; |
| 717 | ${*$exp}{exp_Match} = $match; |
| 718 | ${*$exp}{exp_After} = $after; |
| 719 | pop @matchlist; # remove kludged empty bracket from end |
| 720 | @{${*$exp}{exp_Matchlist}} = @matchlist; |
| 721 | ${*$exp}{exp_Match_Number} = $pattern->[0]; |
| 722 | $exp_matched = $exp; |
| 723 | } |
| 724 | } else { |
| 725 | # 'timeout' or 'eof' |
| 726 | } |
| 727 | |
| 728 | if ($exp_matched) { |
| 729 | ${*$exp}{exp_Accum} = $after |
| 730 | unless ${*$exp}{exp_NoTransfer}; |
| 731 | print STDERR "YES!!\r\n" |
| 732 | if ${*$exp}{exp_Exp_Internal}; |
| 733 | print STDERR (" Before match string: `", |
| 734 | $exp->_trim_length(_make_readable(($before))), |
| 735 | "'\r\n", |
| 736 | " Match string: `", _make_readable($match), |
| 737 | "'\r\n", |
| 738 | " After match string: `", |
| 739 | $exp->_trim_length(_make_readable(($after))), |
| 740 | "'\r\n", |
| 741 | " Matchlist: (", |
| 742 | join(", ", |
| 743 | map { "`".$exp->_trim_length(_make_readable(($_)))."'" |
| 744 | } @matchlist, |
| 745 | ), |
| 746 | ")\r\n", |
| 747 | ) if (${*$exp}{exp_Exp_Internal}); |
| 748 | |
| 749 | # call hook function if defined |
| 750 | if ($pattern->[3]) { |
| 751 | print STDERR ("Calling hook $pattern->[3]...\r\n", |
| 752 | ) if (${*$exp}{exp_Exp_Internal} or $Expect::Debug); |
| 753 | if ($#{$pattern} > 3) { |
| 754 | # call with parameters if given |
| 755 | $exp_cont = &{$pattern->[3]}($exp, |
| 756 | @{$pattern}[4..$#{$pattern}]); |
| 757 | } else { |
| 758 | $exp_cont = &{$pattern->[3]}($exp); |
| 759 | } |
| 760 | } |
| 761 | if ($exp_cont and $exp_cont eq exp_continue) { |
| 762 | print STDERR ("Continuing expect, restarting timeout...\r\n") |
| 763 | if (${*$exp}{exp_Exp_Internal} or $Expect::Debug); |
| 764 | $start_loop_time = time(); # restart timeout count |
| 765 | next READLOOP; |
| 766 | } elsif ($exp_cont and $exp_cont eq exp_continue_timeout) { |
| 767 | print STDERR ("Continuing expect...\r\n") |
| 768 | if (${*$exp}{exp_Exp_Internal} or $Expect::Debug); |
| 769 | next READLOOP; |
| 770 | } |
| 771 | last READLOOP; |
| 772 | } |
| 773 | print STDERR "No.\r\n" if ${*$exp}{exp_Exp_Internal}; |
| 774 | } |
| 775 | print STDERR "\r\n" if ${*$exp}{exp_Exp_Internal}; |
| 776 | # don't have to match again until we get new data |
| 777 | ${*$exp}{exp_New_Data} = 0; |
| 778 | } |
| 779 | } # End of matching section |
| 780 | |
| 781 | # No match, let's see what is pending on the filehandles... |
| 782 | print STDERR ("Waiting for new data (", |
| 783 | defined($time_left)? $time_left : 'unlimited', |
| 784 | " seconds)...\r\n", |
| 785 | ) if ($Expect::Exp_Internal or $Expect::Debug); |
| 786 | my $nfound = select($rmask, undef, undef, $time_left); |
| 787 | |
| 788 | # go until we don't find something (== timeout). |
| 789 | if (not $nfound) { |
| 790 | # No pattern, no EOF. Did we time out? |
| 791 | $err = "1:TIMEOUT"; |
| 792 | foreach my $pat (@_) { |
| 793 | foreach my $exp (@{$pat->[0]}) { |
| 794 | $before = ${*$exp}{exp_Before} = ${*$exp}{exp_Accum}; |
| 795 | next if not defined $exp->fileno(); # skip already closed |
| 796 | ${*$exp}{exp_Error} = $err unless ${*$exp}{exp_Error}; |
| 797 | } |
| 798 | } |
| 799 | print STDERR ("TIMEOUT\r\n") |
| 800 | if ($Expect::Debug or $Expect::Exp_Internal); |
| 801 | if ($timeout_hook) { |
| 802 | my $ret; |
| 803 | print STDERR ("Calling timeout function $timeout_hook...\r\n") |
| 804 | if ($Expect::Debug or $Expect::Exp_Internal); |
| 805 | if (ref($timeout_hook) eq 'CODE') { |
| 806 | $ret = &{$timeout_hook}($_[0]->[0]); |
| 807 | } else { |
| 808 | if ($#{$timeout_hook} > 3) { |
| 809 | $ret = &{$timeout_hook->[3]}($_[0]->[0], |
| 810 | @{$timeout_hook}[4..$#{$timeout_hook}]); |
| 811 | } else { |
| 812 | $ret = &{$timeout_hook->[3]}($_[0]->[0]); |
| 813 | } |
| 814 | } |
| 815 | if ($ret and $ret eq exp_continue) { |
| 816 | $start_loop_time = time(); # restart timeout count |
| 817 | next READLOOP; |
| 818 | } |
| 819 | } |
| 820 | last READLOOP; |
| 821 | } |
| 822 | |
| 823 | my @bits = split(//,unpack('b*',$rmask)); |
| 824 | foreach my $pat (@_) { |
| 825 | foreach my $exp (@{$pat->[0]}) { |
| 826 | next if not defined $exp->fileno(); # skip already closed |
| 827 | if ($bits[$exp->fileno()]) { |
| 828 | print STDERR ("${*$exp}{exp_Pty_Handle}: new data.\r\n") |
| 829 | if $Expect::Debug; |
| 830 | # read in what we found. |
| 831 | my $buffer; |
| 832 | my $nread = sysread($exp, $buffer, 2048); |
| 833 | |
| 834 | # Make errors (nread undef) show up as EOF. |
| 835 | $nread = 0 unless defined ($nread); |
| 836 | |
| 837 | if ($nread == 0) { |
| 838 | print STDERR ("${*$exp}{exp_Pty_Handle}: EOF\r\n") |
| 839 | if ($Expect::Debug); |
| 840 | $before = ${*$exp}{exp_Before} = $exp->clear_accum(); |
| 841 | $err = "2:EOF"; |
| 842 | ${*$exp}{exp_Error} = $err; |
| 843 | ${*$exp}{exp_Has_EOF} = 1; |
| 844 | $exp_cont = undef; |
| 845 | foreach my $eof_pat (grep {$_->[1] eq '-eof'} @{$pat}[1..$#{$pat}]) { |
| 846 | my $ret; |
| 847 | print STDERR ("Calling EOF hook $eof_pat->[3]...\r\n", |
| 848 | ) if ($Expect::Debug); |
| 849 | if ($#{$eof_pat} > 3) { |
| 850 | # call with parameters if given |
| 851 | $ret = &{$eof_pat->[3]}($exp, |
| 852 | @{$eof_pat}[4..$#{$eof_pat}]); |
| 853 | } else { |
| 854 | $ret = &{$eof_pat->[3]}($exp); |
| 855 | } |
| 856 | if ($ret and |
| 857 | ($ret eq exp_continue |
| 858 | or $ret eq exp_continue_timeout)) { |
| 859 | $exp_cont = $ret; |
| 860 | } |
| 861 | } |
| 862 | # is it dead? |
| 863 | if (defined(${*$exp}{exp_Pid})) { |
| 864 | my $ret = waitpid(${*$exp}{exp_Pid}, WNOHANG); |
| 865 | if ($ret == ${*$exp}{exp_Pid}) { |
| 866 | printf STDERR ("%s: exit(0x%02X)\r\n", |
| 867 | ${*$exp}{exp_Pty_Handle}, $?) |
| 868 | if ($Expect::Debug); |
| 869 | $err = "3:Child PID ${*$exp}{exp_Pid} exited with status $?"; |
| 870 | ${*$exp}{exp_Error} = $err; |
| 871 | ${*$exp}{exp_Exit} = $?; |
| 872 | delete $Expect::Spawned_PIDs{${*$exp}{exp_Pid}}; |
| 873 | ${*$exp}{exp_Pid} = undef; |
| 874 | } |
| 875 | } |
| 876 | print STDERR ("${*$exp}{exp_Pty_Handle}: closing...\r\n") |
| 877 | if ($Expect::Debug); |
| 878 | $exp->hard_close(); |
| 879 | next; |
| 880 | } |
| 881 | print STDERR ("${*$exp}{exp_Pty_Handle}: read $nread byte(s).\r\n") |
| 882 | if ($Expect::Debug); |
| 883 | |
| 884 | # ugly hack for broken solaris ttys that spew <blank><backspace> |
| 885 | # into our pretty output |
| 886 | $buffer =~ s/ \cH//g if not ${*$exp}{exp_Raw_Pty}; |
| 887 | # Append it to the accumulator. |
| 888 | ${*$exp}{exp_Accum} .= $buffer; |
| 889 | if (exists ${*$exp}{exp_Max_Accum} |
| 890 | and ${*$exp}{exp_Max_Accum}) { |
| 891 | ${*$exp}{exp_Accum} = |
| 892 | $exp->_trim_length(${*$exp}{exp_Accum}, |
| 893 | ${*$exp}{exp_Max_Accum}); |
| 894 | } |
| 895 | ${*$exp}{exp_New_Data} = 1; # next round we try to match again |
| 896 | |
| 897 | $exp_cont = exp_continue |
| 898 | if (exists ${*$exp}{exp_Continue} and ${*$exp}{exp_Continue}); |
| 899 | # Now propagate what we have read to other listeners... |
| 900 | $exp->_print_handles($buffer); |
| 901 | |
| 902 | # End handle reading section. |
| 903 | } |
| 904 | } |
| 905 | } # end read loop |
| 906 | $start_loop_time = time() # restart timeout count |
| 907 | if ($exp_cont and $exp_cont eq exp_continue); |
| 908 | } |
| 909 | # End READLOOP |
| 910 | |
| 911 | # Post loop. Do we have anything? |
| 912 | # Tell us status |
| 913 | if ($Expect::Debug or $Expect::Exp_Internal) { |
| 914 | if ($exp_matched) { |
| 915 | print STDERR ("Returning from expect ", |
| 916 | ${*$exp_matched}{exp_Error} ? 'un' : '', |
| 917 | "successfully.", |
| 918 | ${*$exp_matched}{exp_Error} ? |
| 919 | "\r\n Error: ${*$exp_matched}{exp_Error}." : '', |
| 920 | "\r\n"); |
| 921 | } else { |
| 922 | print STDERR ("Returning from expect with TIMEOUT or EOF\r\n"); |
| 923 | } |
| 924 | if ($Expect::Debug and $exp_matched) { |
| 925 | print STDERR " ${*$exp_matched}{exp_Pty_Handle}: accumulator: `"; |
| 926 | if (${*$exp_matched}{exp_Error}) { |
| 927 | print STDERR ($exp_matched->_trim_length |
| 928 | (_make_readable(${*$exp_matched}{exp_Before})), |
| 929 | "'\r\n"); |
| 930 | } else { |
| 931 | print STDERR ($exp_matched->_trim_length |
| 932 | (_make_readable(${*$exp_matched}{exp_Accum})), |
| 933 | "'\r\n"); |
| 934 | } |
| 935 | } |
| 936 | } |
| 937 | |
| 938 | if ($exp_matched) { |
| 939 | return wantarray? |
| 940 | (${*$exp_matched}{exp_Match_Number}, |
| 941 | ${*$exp_matched}{exp_Error}, |
| 942 | ${*$exp_matched}{exp_Match}, |
| 943 | ${*$exp_matched}{exp_Before}, |
| 944 | ${*$exp_matched}{exp_After}, |
| 945 | $exp_matched, |
| 946 | ) : |
| 947 | ${*$exp_matched}{exp_Match_Number}; |
| 948 | } |
| 949 | |
| 950 | return wantarray? (undef, $err, undef, $before, undef, undef) : undef; |
| 951 | } |
| 952 | |
| 953 | |
| 954 | # Patterns are arrays that consist of |
| 955 | # [ $pattern_type, $pattern, $sub, @subparms ] |
| 956 | # optional $pattern_type is '-re' (RegExp, default) or '-ex' (exact); |
| 957 | # $sub is optional CODE ref, which is called as &{$sub}($exp, @subparms) |
| 958 | # if pattern matched; |
| 959 | # the $parm_nr gets unshifted onto the array for reporting purposes. |
| 960 | |
| 961 | sub _add_patterns_to_list($$$@) { |
| 962 | my $listref = shift; |
| 963 | my $timeoutlistref = shift; # gets timeout patterns |
| 964 | my $store_parm_nr = shift; |
| 965 | my $parm_nr = $store_parm_nr || 1; |
| 966 | foreach my $parm (@_) { |
| 967 | if (not ref($parm) eq 'ARRAY') { |
| 968 | return "Parameter #$parm_nr is not an ARRAY ref."; |
| 969 | } |
| 970 | $parm = [@$parm]; # make copy |
| 971 | if ($parm->[0] =~ m/\A-/) { |
| 972 | # it's an option |
| 973 | if ($parm->[0] ne '-re' |
| 974 | and $parm->[0] ne '-ex') { |
| 975 | return "Unknown option $parm->[0] in pattern #$parm_nr"; |
| 976 | } |
| 977 | } else { |
| 978 | if ($parm->[0] eq 'timeout') { |
| 979 | if (defined $timeoutlistref) { |
| 980 | splice @$parm, 0, 1, ("-$parm->[0]", undef); |
| 981 | unshift @$parm, $store_parm_nr? $parm_nr: undef; |
| 982 | push @$timeoutlistref, $parm; |
| 983 | } |
| 984 | next; |
| 985 | } elsif ($parm->[0] eq 'eof') { |
| 986 | splice @$parm, 0, 1, ("-$parm->[0]", undef); |
| 987 | } else { |
| 988 | unshift @$parm, '-re'; # defaults to RegExp |
| 989 | } |
| 990 | } |
| 991 | if (@$parm > 2) { |
| 992 | if (ref($parm->[2]) ne 'CODE') { |
| 993 | croak ("Pattern #$parm_nr doesn't have a CODE reference", |
| 994 | "after the pattern."); |
| 995 | } |
| 996 | } else { |
| 997 | push @$parm, undef; # make sure we have three elements |
| 998 | } |
| 999 | |
| 1000 | unshift @$parm, $store_parm_nr? $parm_nr: undef; |
| 1001 | push @$listref, $parm; |
| 1002 | $parm_nr++ |
| 1003 | } |
| 1004 | return undef; |
| 1005 | } |
| 1006 | |
| 1007 | ###################################################################### |
| 1008 | # $process->interact([$in_handle],[$escape sequence]) |
| 1009 | # If you don't specify in_handle STDIN will be used. |
| 1010 | sub interact { |
| 1011 | my ($self) = (shift); |
| 1012 | my ($infile) = (shift); |
| 1013 | my ($escape_sequence) = shift; |
| 1014 | my ($in_object,$in_handle,@old_group,$return_value); |
| 1015 | my ($old_manual_stty_val,$old_log_stdout_val); |
| 1016 | my ($outfile,$out_object); |
| 1017 | @old_group = $self->set_group(); |
| 1018 | # If the handle is STDIN we'll |
| 1019 | # $infile->fileno == 0 should be stdin.. follow stdin rules. |
| 1020 | no strict 'subs'; # Allow bare word 'STDIN' |
| 1021 | unless (defined($infile)) { |
| 1022 | # We need a handle object Associated with STDIN. |
| 1023 | $infile = new IO::File; |
| 1024 | $infile->IO::File::fdopen(STDIN,'r'); |
| 1025 | $outfile = new IO::File; |
| 1026 | $outfile->IO::File::fdopen(STDOUT,'w'); |
| 1027 | } elsif (fileno($infile) == fileno(STDIN)) { |
| 1028 | # With STDIN we want output to go to stdout. |
| 1029 | $outfile = new IO::File; |
| 1030 | $outfile->IO::File::fdopen(STDOUT,'w'); |
| 1031 | } else { |
| 1032 | undef ($outfile); |
| 1033 | } |
| 1034 | # Here we assure ourselves we have an Expect object. |
| 1035 | $in_object = Expect->exp_init($infile); |
| 1036 | if (defined($outfile)) { |
| 1037 | # as above.. we want output to go to stdout if we're given stdin. |
| 1038 | $out_object = Expect->exp_init($outfile); |
| 1039 | $out_object->manual_stty(1); |
| 1040 | $self->set_group($out_object); |
| 1041 | } else { |
| 1042 | $self->set_group($in_object); |
| 1043 | } |
| 1044 | $in_object->set_group($self); |
| 1045 | $in_object->set_seq($escape_sequence,undef) if defined($escape_sequence); |
| 1046 | # interconnect normally sets stty -echo raw. Interact really sort |
| 1047 | # of implies we don't do that by default. If anyone wanted to they could |
| 1048 | # set it before calling interact, of use interconnect directly. |
| 1049 | $old_manual_stty_val = $self->manual_stty(); |
| 1050 | $self->manual_stty(1); |
| 1051 | # I think this is right. Don't send stuff from in_obj to stdout by default. |
| 1052 | # in theory whatever 'self' is should echo what's going on. |
| 1053 | $old_log_stdout_val = $self->log_stdout(); |
| 1054 | $self->log_stdout(0); |
| 1055 | $in_object->log_stdout(0); |
| 1056 | # Allow for the setting of an optional EOF escape function. |
| 1057 | # $in_object->set_seq('EOF',undef); |
| 1058 | # $self->set_seq('EOF',undef); |
| 1059 | Expect::interconnect($self,$in_object); |
| 1060 | $self->log_stdout($old_log_stdout_val); |
| 1061 | $self->set_group(@old_group); |
| 1062 | # If old_group was undef, make sure that occurs. This is a slight hack since |
| 1063 | # it modifies the value directly. |
| 1064 | # Normally an undef passed to set_group will return the current groups. |
| 1065 | # It is possible that it may be of worth to make it possible to undef |
| 1066 | # The current group without doing this. |
| 1067 | unless (@old_group) { |
| 1068 | @{${*$self}{exp_Listen_Group}} = (); |
| 1069 | } |
| 1070 | $self->manual_stty($old_manual_stty_val); |
| 1071 | return $return_value; |
| 1072 | } |
| 1073 | |
| 1074 | sub interconnect { |
| 1075 | |
| 1076 | # my ($handle)=(shift); call as Expect::interconnect($spawn1,$spawn2,...) |
| 1077 | my ($rmask,$nfound,$nread); |
| 1078 | my ($rout, @bits, $emask, $eout, @ebits ) = (); |
| 1079 | my ($escape_sequence,$escape_character_buffer); |
| 1080 | my (@handles) = @_; |
| 1081 | my ($handle,$read_handle,$write_handle); |
| 1082 | my ($read_mask,$temp_mask) = ('',''); |
| 1083 | |
| 1084 | # Get read/write handles |
| 1085 | foreach $handle (@handles) { |
| 1086 | $temp_mask = ''; |
| 1087 | vec($temp_mask,$handle->fileno(),1) = 1; |
| 1088 | # Under Linux w/ 5.001 the next line comes up w/ 'Uninit var.'. |
| 1089 | # It appears to be impossible to make the warning go away. |
| 1090 | # doing something like $temp_mask='' unless defined ($temp_mask) |
| 1091 | # has no effect whatsoever. This may be a bug in 5.001. |
| 1092 | $read_mask = $read_mask | $temp_mask; |
| 1093 | } |
| 1094 | if ($Expect::Debug) { |
| 1095 | print STDERR "Read handles:\r\n"; |
| 1096 | foreach $handle (@handles) { |
| 1097 | print STDERR "\tRead handle: "; |
| 1098 | print STDERR "'${*$handle}{exp_Pty_Handle}'\r\n"; |
| 1099 | print STDERR "\t\tListen Handles:"; |
| 1100 | foreach $write_handle (@{${*$handle}{exp_Listen_Group}}) { |
| 1101 | print STDERR " '${*$write_handle}{exp_Pty_Handle}'"; |
| 1102 | } |
| 1103 | print STDERR ".\r\n"; |
| 1104 | } |
| 1105 | } |
| 1106 | |
| 1107 | # I think if we don't set raw/-echo here we may have trouble. We don't |
| 1108 | # want a bunch of echoing crap making all the handles jabber at each other. |
| 1109 | foreach $handle (@handles) { |
| 1110 | unless (${*$handle}{"exp_Manual_Stty"}) { |
| 1111 | # This is probably O/S specific. |
| 1112 | ${*$handle}{exp_Stored_Stty} = $handle->exp_stty('-g'); |
| 1113 | print STDERR "Setting tty for ${*$handle}{exp_Pty_Handle} to 'raw -echo'.\r\n"if ${*$handle}{"exp_Debug"}; |
| 1114 | $handle->exp_stty("raw -echo"); |
| 1115 | } |
| 1116 | foreach $write_handle (@{${*$handle}{exp_Listen_Group}}) { |
| 1117 | unless (${*$write_handle}{"exp_Manual_Stty"}) { |
| 1118 | ${*$write_handle}{exp_Stored_Stty} = $write_handle->exp_stty('-g'); |
| 1119 | print STDERR "Setting ${*$write_handle}{exp_Pty_Handle} to 'raw -echo'.\r\n"if ${*$handle}{"exp_Debug"}; |
| 1120 | $write_handle->exp_stty("raw -echo"); |
| 1121 | } |
| 1122 | } |
| 1123 | } |
| 1124 | |
| 1125 | print STDERR "Attempting interconnection\r\n" if $Expect::Debug; |
| 1126 | |
| 1127 | # Wait until the process dies or we get EOF |
| 1128 | # In the case of !${*$handle}{exp_Pid} it means |
| 1129 | # the handle was exp_inited instead of spawned. |
| 1130 | CONNECT_LOOP: |
| 1131 | # Go until we have a reason to stop |
| 1132 | while (1) { |
| 1133 | # test each handle to see if it's still alive. |
| 1134 | foreach $read_handle (@handles) { |
| 1135 | waitpid(${*$read_handle}{exp_Pid}, WNOHANG) |
| 1136 | if (exists (${*$read_handle}{exp_Pid}) and ${*$read_handle}{exp_Pid}); |
| 1137 | if (exists(${*$read_handle}{exp_Pid}) |
| 1138 | and (${*$read_handle}{exp_Pid}) |
| 1139 | and (! kill(0,${*$read_handle}{exp_Pid}))) { |
| 1140 | print STDERR "Got EOF (${*$read_handle}{exp_Pty_Handle} died) reading ${*$read_handle}{exp_Pty_Handle}\r\n" |
| 1141 | if ${*$read_handle}{"exp_Debug"}; |
| 1142 | last CONNECT_LOOP unless defined(${${*$read_handle}{exp_Function}}{"EOF"}); |
| 1143 | last CONNECT_LOOP unless &{${${*$read_handle}{exp_Function}}{"EOF"}}(@{${${*$read_handle}{exp_Parameters}}{"EOF"}}); |
| 1144 | } |
| 1145 | } |
| 1146 | |
| 1147 | # Every second? No, go until we get something from someone. |
| 1148 | ($nfound) = select($rout = $read_mask, undef, $eout = $emask, undef); |
| 1149 | # Is there anything to share? May be -1 if interrupted by a signal... |
| 1150 | next CONNECT_LOOP if not defined $nfound or $nfound < 1; |
| 1151 | # Which handles have stuff? |
| 1152 | @bits = split(//,unpack('b*',$rout)); |
| 1153 | $eout = 0 unless defined ($eout); |
| 1154 | @ebits = split(//,unpack('b*',$eout)); |
| 1155 | # print "Ebits: $eout\r\n"; |
| 1156 | foreach $read_handle (@handles) { |
| 1157 | if ($bits[$read_handle->fileno()]) { |
| 1158 | $nread = sysread( $read_handle, ${*$read_handle}{exp_Pty_Buffer}, 1024 ); |
| 1159 | # Appease perl -w |
| 1160 | $nread = 0 unless defined ($nread); |
| 1161 | print STDERR "interconnect: read $nread byte(s) from ${*$read_handle}{exp_Pty_Handle}.\r\n" if ${*$read_handle}{"exp_Debug"} > 1; |
| 1162 | # Test for escape seq. before printing. |
| 1163 | # Appease perl -w |
| 1164 | $escape_character_buffer = '' unless defined ($escape_character_buffer); |
| 1165 | $escape_character_buffer .= ${*$read_handle}{exp_Pty_Buffer}; |
| 1166 | foreach $escape_sequence (keys(%{${*$read_handle}{exp_Function}})) { |
| 1167 | print STDERR "Tested escape sequence $escape_sequence from ${*$read_handle}{exp_Pty_Handle}"if ${*$read_handle}{"exp_Debug"} > 1; |
| 1168 | # Make sure it doesn't grow out of bounds. |
| 1169 | $escape_character_buffer = $read_handle->_trim_length($escape_character_buffer,${*$read_handle}{"exp_Max_Accum"}) if (${*$read_handle}{"exp_Max_Accum"}); |
| 1170 | if ($escape_character_buffer =~ /($escape_sequence)/) { |
| 1171 | if (${*$read_handle}{"exp_Debug"}) { |
| 1172 | print STDERR "\r\ninterconnect got escape sequence from ${*$read_handle}{exp_Pty_Handle}.\r\n"; |
| 1173 | # I'm going to make the esc. seq. pretty because it will |
| 1174 | # probably contain unprintable characters. |
| 1175 | print STDERR "\tEscape Sequence: '"._trim_length(undef,_make_readable($escape_sequence))."'\r\n"; |
| 1176 | print STDERR "\tMatched by string: '"._trim_length(undef,_make_readable($&))."'\r\n"; |
| 1177 | } |
| 1178 | # Print out stuff before the escape. |
| 1179 | # Keep in mind that the sequence may have been split up |
| 1180 | # over several reads. |
| 1181 | # Let's get rid of it from this read. If part of it was |
| 1182 | # in the last read there's not a lot we can do about it now. |
| 1183 | if (${*$read_handle}{exp_Pty_Buffer} =~ /($escape_sequence)/) { |
| 1184 | $read_handle->_print_handles($`); |
| 1185 | } else { |
| 1186 | $read_handle->_print_handles(${*$read_handle}{exp_Pty_Buffer}) |
| 1187 | } |
| 1188 | # Clear the buffer so no more matches can be made and it will |
| 1189 | # only be printed one time. |
| 1190 | ${*$read_handle}{exp_Pty_Buffer} = ''; |
| 1191 | $escape_character_buffer = ''; |
| 1192 | # Do the function here. Must return non-zero to continue. |
| 1193 | # More cool syntax. Maybe I should turn these in to objects. |
| 1194 | last CONNECT_LOOP unless &{${${*$read_handle}{exp_Function}}{$escape_sequence}}(@{${${*$read_handle}{exp_Parameters}}{$escape_sequence}}); |
| 1195 | } |
| 1196 | } |
| 1197 | $nread = 0 unless defined($nread); # Appease perl -w? |
| 1198 | waitpid(${*$read_handle}{exp_Pid}, WNOHANG) if (defined (${*$read_handle}{exp_Pid}) &&${*$read_handle}{exp_Pid}); |
| 1199 | if ($nread == 0) { |
| 1200 | print STDERR "Got EOF reading ${*$read_handle}{exp_Pty_Handle}\r\n"if ${*$read_handle}{"exp_Debug"}; |
| 1201 | last CONNECT_LOOP unless defined(${${*$read_handle}{exp_Function}}{"EOF"}); |
| 1202 | last CONNECT_LOOP unless &{${${*$read_handle}{exp_Function}}{"EOF"}}(@{${${*$read_handle}{exp_Parameters}}{"EOF"}}); |
| 1203 | } |
| 1204 | last CONNECT_LOOP if ($nread < 0); # This would be an error |
| 1205 | $read_handle->_print_handles(${*$read_handle}{exp_Pty_Buffer}); |
| 1206 | } |
| 1207 | # I'm removing this because I haven't determined what causes exceptions |
| 1208 | # consistently. |
| 1209 | if (0) #$ebits[$read_handle->fileno()]) |
| 1210 | { |
| 1211 | print STDERR "Got Exception reading ${*$read_handle}{exp_Pty_Handle}\r\n"if ${*$read_handle}{"exp_Debug"}; |
| 1212 | last CONNECT_LOOP unless defined(${${*$read_handle}{exp_Function}}{"EOF"}); |
| 1213 | last CONNECT_LOOP unless &{${${*$read_handle}{exp_Function}}{"EOF"}}(@{${${*$read_handle}{exp_Parameters}}{"EOF"}}); |
| 1214 | } |
| 1215 | } |
| 1216 | } |
| 1217 | foreach $handle (@handles) { |
| 1218 | unless (${*$handle}{"exp_Manual_Stty"}) { |
| 1219 | $handle->exp_stty(${*$handle}{exp_Stored_Stty}); |
| 1220 | } |
| 1221 | foreach $write_handle (@{${*$handle}{exp_Listen_Group}}) { |
| 1222 | unless (${*$write_handle}{"exp_Manual_Stty"}) { |
| 1223 | $write_handle->exp_stty(${*$write_handle}{exp_Stored_Stty}); |
| 1224 | } |
| 1225 | } |
| 1226 | } |
| 1227 | } |
| 1228 | |
| 1229 | # user can decide if log output gets also sent to logfile |
| 1230 | sub print_log_file { |
| 1231 | my $self = shift; |
| 1232 | if (${*$self}{exp_Log_File}) { |
| 1233 | if (ref(${*$self}{exp_Log_File}) eq 'CODE') { |
| 1234 | ${*$self}{exp_Log_File}->(@_); |
| 1235 | } else { |
| 1236 | ${*$self}{exp_Log_File}->print(@_); |
| 1237 | } |
| 1238 | } |
| 1239 | } |
| 1240 | |
| 1241 | # we provide our own print so we can debug what gets sent to the |
| 1242 | # processes... |
| 1243 | sub print (@) { |
| 1244 | my ($self, @args) = @_; |
| 1245 | return if not defined $self->fileno(); # skip if closed |
| 1246 | if (${*$self}{exp_Exp_Internal}) { |
| 1247 | my $args = _make_readable(join('', @args)); |
| 1248 | cluck "Sending '$args' to ${*$self}{exp_Pty_Handle}\r\n"; |
| 1249 | } |
| 1250 | foreach my $arg (@args) { |
| 1251 | while (length($arg) > 80) { |
| 1252 | $self->SUPER::print(substr($arg, 0, 80)); |
| 1253 | $arg = substr($arg, 80); |
| 1254 | } |
| 1255 | $self->SUPER::print($arg); |
| 1256 | } |
| 1257 | } |
| 1258 | |
| 1259 | # make an alias for Tcl/Expect users for a DWIM experience... |
| 1260 | *send = \&print; |
| 1261 | |
| 1262 | # This is an Expect standard. It's nice for talking to modems and the like |
| 1263 | # where from time to time they get unhappy if you send items too quickly. |
| 1264 | sub send_slow{ |
| 1265 | my ($self) = shift; |
| 1266 | my($char,@linechars,$nfound,$rmask); |
| 1267 | return if not defined $self->fileno(); # skip if closed |
| 1268 | my($sleep_time) = shift; |
| 1269 | # Flushing makes it so each character can be seen separately. |
| 1270 | my $chunk; |
| 1271 | while ($chunk = shift) { |
| 1272 | @linechars = split ('', $chunk); |
| 1273 | foreach $char (@linechars) { |
| 1274 | # How slow? |
| 1275 | select (undef,undef,undef,$sleep_time); |
| 1276 | |
| 1277 | print $self $char; |
| 1278 | print STDERR "Printed character \'"._make_readable($char)."\' to ${*$self}{exp_Pty_Handle}.\r\n" if ${*$self}{"exp_Debug"} > 1; |
| 1279 | # I think I can get away with this if I save it in accum |
| 1280 | if (${*$self}{"exp_Log_Stdout"} ||${*$self}{exp_Log_Group}) { |
| 1281 | $rmask = ""; |
| 1282 | vec($rmask,$self->fileno(),1) = 1; |
| 1283 | # .01 sec granularity should work. If we miss something it will |
| 1284 | # probably get flushed later, maybe in an expect call. |
| 1285 | while (select($rmask,undef,undef,.01)) { |
| 1286 | my $ret = sysread($self,${*$self}{exp_Pty_Buffer},1024); |
| 1287 | last if not defined $ret or $ret == 0; |
| 1288 | # Is this necessary to keep? Probably.. # |
| 1289 | # if you need to expect it later. |
| 1290 | ${*$self}{exp_Accum}.= ${*$self}{exp_Pty_Buffer}; |
| 1291 | ${*$self}{exp_Accum} = $self->_trim_length(${*$self}{exp_Accum},${*$self}{"exp_Max_Accum"}) if (${*$self}{"exp_Max_Accum"}); |
| 1292 | $self->_print_handles(${*$self}{exp_Pty_Buffer}); |
| 1293 | print STDERR "Received \'".$self->_trim_length(_make_readable($char))."\' from ${*$self}{exp_Pty_Handle}\r\n" if ${*$self}{"exp_Debug"} > 1; |
| 1294 | } |
| 1295 | } |
| 1296 | } |
| 1297 | } |
| 1298 | } |
| 1299 | |
| 1300 | sub test_handles { |
| 1301 | # This should be called by Expect::test_handles($timeout,@objects); |
| 1302 | my ($rmask, $allmask, $rout, $nfound, @bits); |
| 1303 | my ($timeout) = shift; |
| 1304 | my (@handle_list) = @_; |
| 1305 | my($handle); |
| 1306 | foreach $handle (@handle_list) { |
| 1307 | $rmask = ''; |
| 1308 | vec($rmask,$handle->fileno(),1) = 1; |
| 1309 | $allmask = '' unless defined ($allmask); |
| 1310 | $allmask = $allmask | $rmask; |
| 1311 | } |
| 1312 | ($nfound) = select($rout = $allmask, undef, undef, $timeout); |
| 1313 | return () unless $nfound; |
| 1314 | # Which handles have stuff? |
| 1315 | @bits = split(//,unpack('b*',$rout)); |
| 1316 | |
| 1317 | my $handle_num = 0; |
| 1318 | my @return_list = (); |
| 1319 | foreach $handle (@handle_list) { |
| 1320 | # I go to great lengths to get perl -w to shut the hell up. |
| 1321 | if (defined($bits[$handle->fileno()]) and ($bits[$handle->fileno()])) { |
| 1322 | push(@return_list,$handle_num); |
| 1323 | } |
| 1324 | } continue { |
| 1325 | $handle_num++; |
| 1326 | } |
| 1327 | return (@return_list); |
| 1328 | } |
| 1329 | |
| 1330 | # Be nice close. This should emulate what an interactive shell does after a |
| 1331 | # command finishes... sort of. We're not as patient as a shell. |
| 1332 | sub soft_close { |
| 1333 | my($self) = shift; |
| 1334 | my($nfound,$nread,$rmask,$returned_pid); |
| 1335 | my($end_time,$select_time,$temp_buffer); |
| 1336 | my($close_status); |
| 1337 | # Give it 15 seconds to cough up an eof. |
| 1338 | cluck "Closing ${*$self}{exp_Pty_Handle}.\r\n" if ${*$self}{exp_Debug}; |
| 1339 | return -1 if not defined $self->fileno(); # skip if handle already closed |
| 1340 | unless (exists ${*$self}{exp_Has_EOF} and ${*$self}{exp_Has_EOF}) { |
| 1341 | $end_time = time() + 15; |
| 1342 | while ($end_time > time()) { |
| 1343 | $select_time = $end_time - time(); |
| 1344 | # Sanity check. |
| 1345 | $select_time = 0 if $select_time < 0; |
| 1346 | $rmask = ''; |
| 1347 | vec($rmask,$self->fileno(),1) = 1; |
| 1348 | ($nfound) = select($rmask,undef,undef,$select_time); |
| 1349 | last unless (defined($nfound) && $nfound); |
| 1350 | $nread = sysread($self,$temp_buffer,8096); |
| 1351 | # 0 = EOF. |
| 1352 | unless (defined($nread) && $nread) { |
| 1353 | print STDERR "Got EOF from ${*$self}{exp_Pty_Handle}.\r\n" if ${*$self}{exp_Debug}; |
| 1354 | last; |
| 1355 | } |
| 1356 | $self->_print_handles($temp_buffer); |
| 1357 | } |
| 1358 | if (($end_time <= time()) && ${*$self}{exp_Debug}) { |
| 1359 | print STDERR "Timed out waiting for an EOF from ${*$self}{exp_Pty_Handle}.\r\n"; |
| 1360 | } |
| 1361 | } |
| 1362 | if ( ($close_status = $self->close()) && ${*$self}{exp_Debug}) { |
| 1363 | print STDERR "${*$self}{exp_Pty_Handle} closed.\r\n"; |
| 1364 | } |
| 1365 | # quit now if it isn't a process. |
| 1366 | return $close_status unless defined(${*$self}{exp_Pid}); |
| 1367 | # Now give it 15 seconds to die. |
| 1368 | $end_time = time() + 15; |
| 1369 | while ($end_time > time()) { |
| 1370 | $returned_pid = waitpid(${*$self}{exp_Pid}, &WNOHANG); |
| 1371 | # Stop here if the process dies. |
| 1372 | if (defined($returned_pid) && $returned_pid) { |
| 1373 | delete $Expect::Spawned_PIDs{$returned_pid}; |
| 1374 | if (${*$self}{exp_Debug}) { |
| 1375 | printf STDERR ("Pid %d of %s exited, Status: 0x%02X\r\n", |
| 1376 | ${*$self}{exp_Pid}, ${*$self}{exp_Pty_Handle}, $?); |
| 1377 | } |
| 1378 | ${*$self}{exp_Pid} = undef; |
| 1379 | ${*$self}{exp_Exit} = $?; |
| 1380 | return ${*$self}{exp_Exit}; |
| 1381 | } |
| 1382 | sleep 1; # Keep loop nice. |
| 1383 | } |
| 1384 | # Send it a term if it isn't dead. |
| 1385 | if (${*$self}{exp_Debug}) { |
| 1386 | print STDERR "${*$self}{exp_Pty_Handle} not exiting, sending TERM.\r\n"; |
| 1387 | } |
| 1388 | kill TERM => ${*$self}{exp_Pid}; |
| 1389 | # Now to be anal retentive.. wait 15 more seconds for it to die. |
| 1390 | $end_time = time() + 15; |
| 1391 | while ($end_time > time()) { |
| 1392 | $returned_pid = waitpid(${*$self}{exp_Pid}, &WNOHANG); |
| 1393 | if (defined($returned_pid) && $returned_pid) { |
| 1394 | delete $Expect::Spawned_PIDs{$returned_pid}; |
| 1395 | if (${*$self}{exp_Debug}) { |
| 1396 | printf STDERR ("Pid %d of %s terminated, Status: 0x%02X\r\n", |
| 1397 | ${*$self}{exp_Pid}, ${*$self}{exp_Pty_Handle}, $?); |
| 1398 | } |
| 1399 | ${*$self}{exp_Pid} = undef; |
| 1400 | ${*$self}{exp_Exit} = $?; |
| 1401 | return $?; |
| 1402 | } |
| 1403 | sleep 1; |
| 1404 | } |
| 1405 | # Since this is a 'soft' close, sending it a -9 would be inappropriate. |
| 1406 | return undef; |
| 1407 | } |
| 1408 | |
| 1409 | # 'Make it go away' close. |
| 1410 | sub hard_close { |
| 1411 | my($self) = shift; |
| 1412 | my($nfound,$nread,$rmask,$returned_pid); |
| 1413 | my($end_time,$select_time,$temp_buffer); |
| 1414 | my($close_status); |
| 1415 | cluck "Closing ${*$self}{exp_Pty_Handle}.\r\n" if ${*$self}{exp_Debug}; |
| 1416 | # Don't wait for an EOF. |
| 1417 | if ( ($close_status = $self->close()) && ${*$self}{exp_Debug}) { |
| 1418 | print STDERR "${*$self}{exp_Pty_Handle} closed.\r\n"; |
| 1419 | } |
| 1420 | # Return now if handle. |
| 1421 | return $close_status unless defined(${*$self}{exp_Pid}); |
| 1422 | # Now give it 5 seconds to die. Less patience here if it won't die. |
| 1423 | $end_time = time() + 5; |
| 1424 | while ($end_time > time()) { |
| 1425 | $returned_pid = waitpid(${*$self}{exp_Pid}, &WNOHANG); |
| 1426 | # Stop here if the process dies. |
| 1427 | if (defined($returned_pid) && $returned_pid) { |
| 1428 | delete $Expect::Spawned_PIDs{$returned_pid}; |
| 1429 | if (${*$self}{exp_Debug}) { |
| 1430 | printf STDERR ("Pid %d of %s terminated, Status: 0x%02X\r\n", |
| 1431 | ${*$self}{exp_Pid}, ${*$self}{exp_Pty_Handle}, $?); |
| 1432 | } |
| 1433 | ${*$self}{exp_Pid} = undef; |
| 1434 | ${*$self}{exp_Exit} = $?; |
| 1435 | return ${*$self}{exp_Exit}; |
| 1436 | } |
| 1437 | sleep 1; # Keep loop nice. |
| 1438 | } |
| 1439 | # Send it a term if it isn't dead. |
| 1440 | if (${*$self}{exp_Debug}) { |
| 1441 | print STDERR "${*$self}{exp_Pty_Handle} not exiting, sending TERM.\r\n"; |
| 1442 | } |
| 1443 | kill TERM => ${*$self}{exp_Pid}; |
| 1444 | # wait 15 more seconds for it to die. |
| 1445 | $end_time = time() + 15; |
| 1446 | while ($end_time > time()) { |
| 1447 | $returned_pid = waitpid(${*$self}{exp_Pid}, &WNOHANG); |
| 1448 | if (defined($returned_pid) && $returned_pid) { |
| 1449 | delete $Expect::Spawned_PIDs{$returned_pid}; |
| 1450 | if (${*$self}{exp_Debug}) { |
| 1451 | printf STDERR ("Pid %d of %s terminated, Status: 0x%02X\r\n", |
| 1452 | ${*$self}{exp_Pid}, ${*$self}{exp_Pty_Handle}, $?); |
| 1453 | } |
| 1454 | ${*$self}{exp_Pid} = undef; |
| 1455 | ${*$self}{exp_Exit} = $?; |
| 1456 | return ${*$self}{exp_Exit}; |
| 1457 | } |
| 1458 | sleep 1; |
| 1459 | } |
| 1460 | kill KILL => ${*$self}{exp_Pid}; |
| 1461 | # wait 5 more seconds for it to die. |
| 1462 | $end_time = time() + 5; |
| 1463 | while ($end_time > time()) { |
| 1464 | $returned_pid = waitpid(${*$self}{exp_Pid}, &WNOHANG); |
| 1465 | if (defined($returned_pid) && $returned_pid) { |
| 1466 | delete $Expect::Spawned_PIDs{$returned_pid}; |
| 1467 | if (${*$self}{exp_Debug}) { |
| 1468 | printf STDERR ("Pid %d of %s killed, Status: 0x%02X\r\n", |
| 1469 | ${*$self}{exp_Pid}, ${*$self}{exp_Pty_Handle}, $?); |
| 1470 | } |
| 1471 | ${*$self}{exp_Pid} = undef; |
| 1472 | ${*$self}{exp_Exit} = $?; |
| 1473 | return ${*$self}{exp_Exit}; |
| 1474 | } |
| 1475 | sleep 1; |
| 1476 | } |
| 1477 | warn "Pid ${*$self}{exp_Pid} of ${*$self}{exp_Pty_Handle} is HUNG.\r\n"; |
| 1478 | ${*$self}{exp_Pid} = undef; |
| 1479 | return undef; |
| 1480 | } |
| 1481 | |
| 1482 | # These should not be called externally. |
| 1483 | |
| 1484 | sub _init_vars { |
| 1485 | my($self) = shift; |
| 1486 | |
| 1487 | # for every spawned process or filehandle. |
| 1488 | ${*$self}{exp_Log_Stdout} = $Expect::Log_Stdout |
| 1489 | if defined ($Expect::Log_Stdout); |
| 1490 | ${*$self}{exp_Log_Group} = $Expect::Log_Group; |
| 1491 | ${*$self}{exp_Debug} = $Expect::Debug; |
| 1492 | ${*$self}{exp_Exp_Internal} = $Expect::Exp_Internal; |
| 1493 | ${*$self}{exp_Manual_Stty} = $Expect::Manual_Stty; |
| 1494 | ${*$self}{exp_Stored_Stty} = 'sane'; |
| 1495 | ${*$self}{exp_Do_Soft_Close} = $Expect::Do_Soft_Close; |
| 1496 | |
| 1497 | # sysread doesn't like my or local vars. |
| 1498 | ${*$self}{exp_Pty_Buffer} = ''; |
| 1499 | |
| 1500 | # Initialize accumulator. |
| 1501 | ${*$self}{exp_Max_Accum} = $Expect::Exp_Max_Accum; |
| 1502 | ${*$self}{exp_Accum} = ''; |
| 1503 | ${*$self}{exp_NoTransfer} = 0; |
| 1504 | |
| 1505 | # create empty expect_before & after lists |
| 1506 | ${*$self}{exp_expect_before_list} = []; |
| 1507 | ${*$self}{exp_expect_after_list} = []; |
| 1508 | } |
| 1509 | |
| 1510 | |
| 1511 | sub _make_readable { |
| 1512 | my $s = shift; |
| 1513 | $s = '' if not defined ($s); |
| 1514 | study $s; # Speed things up? |
| 1515 | $s =~ s/\\/\\\\/g; # So we can tell easily(?) what is a backslash |
| 1516 | $s =~ s/\n/\\n/g; |
| 1517 | $s =~ s/\r/\\r/g; |
| 1518 | $s =~ s/\t/\\t/g; |
| 1519 | $s =~ s/\'/\\\'/g; # So we can tell whassa quote and whassa notta quote. |
| 1520 | $s =~ s/\"/\\\"/g; |
| 1521 | # Formfeed (does anyone use formfeed?) |
| 1522 | $s =~ s/\f/\\f/g; |
| 1523 | $s =~ s/\010/\\b/g; |
| 1524 | # escape control chars high/low, but allow ISO 8859-1 chars |
| 1525 | $s =~ s/[\000-\037\177-\237\377]/sprintf("\\%03lo",ord($&))/ge; |
| 1526 | |
| 1527 | return $s; |
| 1528 | } |
| 1529 | |
| 1530 | sub _trim_length { |
| 1531 | # This is sort of a reverse truncation function |
| 1532 | # Mostly so we don't have to see the full output when we're using |
| 1533 | # Also used if Max_Accum gets set to limit the size of the accumulator |
| 1534 | # for matching functions. |
| 1535 | # exp_internal |
| 1536 | my($self) = shift; |
| 1537 | my($string) = shift; |
| 1538 | my($length) = shift; |
| 1539 | |
| 1540 | # If we're not passed a length (_trim_length is being used for debugging |
| 1541 | # purposes) AND debug >= 3, don't trim. |
| 1542 | return($string) if (defined ($self) and |
| 1543 | ${*$self}{"exp_Debug"} >= 3 and (!(defined($length)))); |
| 1544 | my($indicate_truncation) = '...' unless $length; |
| 1545 | $length = 1021 unless $length; |
| 1546 | return($string) unless $length < length($string); |
| 1547 | # We wouldn't want the accumulator to begin with '...' if max_accum is passed |
| 1548 | # This is because this funct. gets called internally w/ max_accum |
| 1549 | # and is also used to print information back to the user. |
| 1550 | return $indicate_truncation.substr($string,(length($string) - $length),$length); |
| 1551 | } |
| 1552 | |
| 1553 | sub _print_handles { |
| 1554 | # Given crap from 'self' and the handles self wants to print to, print to |
| 1555 | # them. these are indicated by the handle's 'group' |
| 1556 | my($self) = shift; |
| 1557 | my($print_this) = shift; |
| 1558 | my($handle); |
| 1559 | if (${*$self}{exp_Log_Group}) { |
| 1560 | foreach $handle (@{${*$self}{exp_Listen_Group}}) { |
| 1561 | $print_this = '' unless defined ($print_this); |
| 1562 | # Appease perl -w |
| 1563 | print STDERR "Printed '".$self->_trim_length(_make_readable($print_this))."' to ${*$handle}{exp_Pty_Handle} from ${*$self}{exp_Pty_Handle}.\r\n" if (${*$handle}{"exp_Debug"} > 1); |
| 1564 | print $handle $print_this; |
| 1565 | } |
| 1566 | } |
| 1567 | # If ${*$self}{exp_Pty_Handle} is STDIN this would make it echo. |
| 1568 | print STDOUT $print_this |
| 1569 | if ${*$self}{"exp_Log_Stdout"}; |
| 1570 | $self->print_log_file($print_this); |
| 1571 | $|= 1; # This should not be necessary but autoflush() doesn't always work. |
| 1572 | } |
| 1573 | |
| 1574 | sub _get_mode { |
| 1575 | my($fcntl_flags) = ''; |
| 1576 | my($handle) = shift; |
| 1577 | # What mode are we opening with? use fcntl to find out. |
| 1578 | $fcntl_flags = fcntl(\*{$handle},Fcntl::F_GETFL,$fcntl_flags); |
| 1579 | die "fcntl returned undef during exp_init of $handle, $!\r\n" unless defined($fcntl_flags); |
| 1580 | if ($fcntl_flags | (Fcntl::O_RDWR)) { |
| 1581 | return 'rw'; |
| 1582 | } elsif ($fcntl_flags | (Fcntl::O_WRONLY)) { |
| 1583 | return 'w' |
| 1584 | } else { |
| 1585 | # Under Solaris (among others?) O_RDONLY is implemented as 0. so |O_RDONLY would fail. |
| 1586 | return 'r'; |
| 1587 | } |
| 1588 | } |
| 1589 | |
| 1590 | |
| 1591 | sub _undef { |
| 1592 | return undef; |
| 1593 | # Seems a little retarded but &CORE::undef fails in interconnect. |
| 1594 | # This is used for the default escape sequence function. |
| 1595 | # w/out the leading & it won't compile. |
| 1596 | } |
| 1597 | |
| 1598 | # clean up child processes |
| 1599 | sub DESTROY { |
| 1600 | my $status = $?; # save this as it gets mangled by the terminating spawned children |
| 1601 | my $self = shift; |
| 1602 | if (${*$self}{exp_Do_Soft_Close}) { |
| 1603 | $self->soft_close(); |
| 1604 | } |
| 1605 | $self->hard_close(); |
| 1606 | $? = $status; # restore it. otherwise deleting an Expect object may mangle $?, which is unintuitive |
| 1607 | } |
| 1608 | |
| 1609 | 1; |