view release on metacpan or  search on metacpan

lib/Expect.pm  view on Meta::CPAN

	my ( $rout, $emask, $eout );
	my ( $escape_character_buffer );
	my ( $read_mask, $temp_mask ) = ( '', '' );

	# Get read/write handles
	foreach my $handle (@handles) {
		$temp_mask = '';
		vec( $temp_mask, $handle->fileno(), 1 ) = 1;

		# Under Linux w/ 5.001 the next line comes up w/ 'Uninit var.'.
		# It appears to be impossible to make the warning go away.
		# doing something like $temp_mask='' unless defined ($temp_mask)
		# has no effect whatsoever. This may be a bug in 5.001.
		$read_mask = $read_mask | $temp_mask;
	}
	if ($Expect::Debug) {
		print STDERR "Read handles:\r\n";
		foreach my $handle (@handles) {
			print STDERR "\tRead handle: ";
			print STDERR "'${*$handle}{exp_Pty_Handle}'\r\n";
			print STDERR "\t\tListen Handles:";
			foreach my $write_handle ( @{ ${*$handle}{exp_Listen_Group} } ) {
				print STDERR " '${*$write_handle}{exp_Pty_Handle}'";
			}
			print STDERR ".\r\n";
		}
	}

	#  I think if we don't set raw/-echo here we may have trouble. We don't
	# want a bunch of echoing crap making all the handles jabber at each other.
	foreach my $handle (@handles) {
		unless ( ${*$handle}{"exp_Manual_Stty"} ) {

			# This is probably O/S specific.
			${*$handle}{exp_Stored_Stty} = $handle->exp_stty('-g');
			print STDERR "Setting tty for ${*$handle}{exp_Pty_Handle} to 'raw -echo'.\r\n"
				if ${*$handle}{"exp_Debug"};
			$handle->exp_stty("raw -echo");
		}
		foreach my $write_handle ( @{ ${*$handle}{exp_Listen_Group} } ) {
			unless ( ${*$write_handle}{"exp_Manual_Stty"} ) {
				${*$write_handle}{exp_Stored_Stty} =
					$write_handle->exp_stty('-g');
				print STDERR "Setting ${*$write_handle}{exp_Pty_Handle} to 'raw -echo'.\r\n"
					if ${*$handle}{"exp_Debug"};
				$write_handle->exp_stty("raw -echo");
			}
		}
	}

	print STDERR "Attempting interconnection\r\n" if $Expect::Debug;

	# Wait until the process dies or we get EOF
	# In the case of !${*$handle}{exp_Pid} it means
	# the handle was exp_inited instead of spawned.
	CONNECT_LOOP:

	# Go until we have a reason to stop
	while (1) {

		# test each handle to see if it's still alive.
		foreach my $read_handle (@handles) {
			waitpid( ${*$read_handle}{exp_Pid}, WNOHANG )
				if ( exists( ${*$read_handle}{exp_Pid} )
				and ${*$read_handle}{exp_Pid} );
			if (    exists( ${*$read_handle}{exp_Pid} )
				and ( ${*$read_handle}{exp_Pid} )
				and ( !kill( 0, ${*$read_handle}{exp_Pid} ) ) )
			{
				print STDERR
					"Got EOF (${*$read_handle}{exp_Pty_Handle} died) reading ${*$read_handle}{exp_Pty_Handle}\r\n"
					if ${*$read_handle}{"exp_Debug"};
				last CONNECT_LOOP
					unless defined( ${ ${*$read_handle}{exp_Function} }{"EOF"} );
				last CONNECT_LOOP
					unless &{ ${ ${*$read_handle}{exp_Function} }{"EOF"} }
					( @{ ${ ${*$read_handle}{exp_Parameters} }{"EOF"} } );
			}
		}

		# Every second? No, go until we get something from someone.
		my $nfound = select( $rout = $read_mask, undef, $eout = $emask, undef );

		# Is there anything to share?  May be -1 if interrupted by a signal...
		next CONNECT_LOOP if not defined $nfound or $nfound < 1;

		# Which handles have stuff?
		my @bits = split( //, unpack( 'b*', $rout ) );
		$eout = 0 unless defined($eout);
		my @ebits = split( //, unpack( 'b*', $eout ) );

		#    print "Ebits: $eout\r\n";
		foreach my $read_handle (@handles) {
			if ( $bits[ $read_handle->fileno() ] ) {
				$nread = sysread(
					$read_handle, ${*$read_handle}{exp_Pty_Buffer},
					1024
				);

				# Appease perl -w
				$nread = 0 unless defined($nread);
				print STDERR "interconnect: read $nread byte(s) from ${*$read_handle}{exp_Pty_Handle}.\r\n"
					if ${*$read_handle}{"exp_Debug"} > 1;

				# Test for escape seq. before printing.
				# Appease perl -w
				$escape_character_buffer = ''
					unless defined($escape_character_buffer);
				$escape_character_buffer .= ${*$read_handle}{exp_Pty_Buffer};
				foreach my $escape_sequence ( keys( %{ ${*$read_handle}{exp_Function} } ) ) {
					print STDERR "Tested escape sequence $escape_sequence from ${*$read_handle}{exp_Pty_Handle}"
						if ${*$read_handle}{"exp_Debug"} > 1;

					# Make sure it doesn't grow out of bounds.
					$escape_character_buffer = $read_handle->_trim_length(
						$escape_character_buffer,
						${*$read_handle}{"exp_Max_Accum"}
					) if ( ${*$read_handle}{"exp_Max_Accum"} );
					if ( $escape_character_buffer =~ /($escape_sequence)/ ) {
						my $match = $1;
						if ( ${*$read_handle}{"exp_Debug"} ) {

lib/Expect.pm  view on Meta::CPAN

=item $object->matchlist()

exp_matchlist() returns a list of matched substrings from the brackets
() inside the regexp that last matched. ($object->matchlist)[0]
thus corresponds to $1, ($object->matchlist)[1] to $2, etc.


=item $object->exp_error() I<or>

=item $object->error()

exp_error() returns the error generated by the last expect() call if
no pattern was matched. It is typically useful to examine the value returned by
before() to find out what the output of the object was in determining
why it didn't match any of the patterns.


=item $object->clear_accum()

Clear the contents of the accumulator for $object. This gets rid of
any residual contents of a handle after expect() or send_slow() such
that the next expect() call will only see new data from $object. The
contents of the accumulator are returned.


=item $object->set_accum($value)

Sets the content of the accumulator for $object to $value. The
previous content of the accumulator is returned.


=item $object->exp_command() I<or>

=item $object->command()

exp_command() returns the string that was used to spawn the command. Helpful
for debugging and for reused patternmatch subroutines.


=item $object->exp_exitstatus() I<or>

=item $object->exitstatus()

Returns the exit status of $object (if it already exited).


=item $object->exp_pty_handle() I<or>

=item $object->pty_handle()

Returns a string representation of the attached pty, for example:
`spawn id(5)' (pty has fileno 5), `handle id(7)' (pty was initialized
from fileno 7) or `STDIN'. Useful for debugging.


=item $object->restart_timeout_upon_receive(0 | 1)

If this is set to 1, the expect timeout is retriggered whenever something
is received from the spawned command.  This allows to perform some
aliveness testing and still expect for patterns.

    $exp->restart_timeout_upon_receive(1);
    $exp->expect($timeout,
                 [ timeout => \&report_timeout ],
                 [ qr/pattern/ => \&handle_pattern],
                );

Now the timeout isn't triggered if the command produces any kind of output,
i.e. is still alive, but you can act upon patterns in the output.


=item $object->notransfer(1 | 0)

Do not truncate the content of the accumulator after a match.
Normally, the accumulator is set to the remains that come after the
matched string.  Note that this setting is per object and not per
pattern, so if you want to have normal acting patterns that truncate
the accumulator, you have to add a

    $exp->set_accum($exp->after);

to their callback, e.g.

    $exp->notransfer(1);
    $exp->expect($timeout,
                 # accumulator not truncated, pattern1 will match again
                 [ "pattern1" => sub { my $self = shift;
                                       ...
                                     } ],
                 # accumulator truncated, pattern2 will not match again
                 [ "pattern2" => sub { my $self = shift;
                                       ...
                                       $self->set_accum($self->after());
                                     } ],
                );

This is only a temporary fix until I can rewrite the pattern matching
part so it can take that additional -notransfer argument.


=item Expect::interconnect(@objects);

Read from @objects and print to their @listen_groups until an escape sequence
is matched from one of @objects and the associated function returns 0 or undef.
The special escape sequence 'EOF' is matched when an object's handle returns
an end of file. Note that it is not necessary to include objects that only
accept data in @objects since the escape sequence is _read_ from an object.
Further note that the listen_group for a write-only object is always empty.
Why would you want to have objects listening to STDOUT (for example)?
By default every member of @objects _as well as every member of its listen
group_ will be set to 'raw -echo' for the duration of interconnection.
Setting $object->manual_stty() will stop this behavior per object.
The original tty settings will be restored as interconnect exits.

For a generic way to interconnect processes, take a look at L<IPC::Run>.


=item Expect::test_handles(@objects)

Given a set of objects determines which objects' handles have data ready
to be read. B<Returns an array> who's members are positions in @objects that
have ready handles. Returns undef if there are no such handles ready.


=item Expect::version($version_requested or undef);

Returns current version of Expect. As of .99 earlier versions are not
supported. Too many things were changed to make versioning possible.