projects / OpenSPARC-T2-SAM / blame
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Initial commit of OpenSPARC T2 architecture model.
[OpenSPARC-T2-SAM] / sam-t2 / devtools / v9 / lib / perl5 / site_perl / 5.8.8 / Expect.pm
CommitLineData
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
18use 5.006; # 4 won't cut it.
19
20package Expect;
21
22use IO::Pty 1.03; # We need make_slave_controlling_terminal()
23use IO::Tty;
24
25use strict 'refs';
26use strict 'vars';
27use strict 'subs';
28use POSIX; # For setsid.
29use Fcntl; # For checking file handle settings.
30use Carp qw(cluck croak carp confess);
31use IO::Handle;
32use 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
39BEGIN {
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
58sub 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
66sub 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
89sub 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
191sub 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...
219my %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 );
232my %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
257sub 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
297sub 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
316sub 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
343sub 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.
375sub 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.
401sub 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
409sub 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
419sub exp_continue() { "exp_continue" }
420sub 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
441sub 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#
577sub _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
961sub _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.
1010sub 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
1074sub 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
1230sub 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...
1243sub 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.
1264sub 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
1300sub 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.
1332sub 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.
1410sub 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
1484sub _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
1511sub _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
1530sub _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
1553sub _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
1574sub _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
1591sub _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
1599sub 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
16091;
Full OpenSPARC architecture tarball including simulator, hypervisor, and OBP.