Commit | Line | Data |
---|---|---|
920dae64 AT |
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; |