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