Permalink
Browse files

partial pty code in wheel::run... need to move to another machine

  • Loading branch information...
rcaputo committed Dec 30, 2000
1 parent 435a782 commit c5c96e7a1d2fe318efbb958a5ef9078d3888a0e8
Showing with 147 additions and 28 deletions.
  1. +1 −0 NEEDS
  2. +16 −4 README
  3. +65 −19 lib/POE/Wheel/Run.pm
  4. +65 −5 tests/22_wheel_run.t
View
1 NEEDS
@@ -53,5 +53,6 @@ POE::Kernel wants Time::HiRes
POE::Filter::Reference wants FreezeThaw
POE::Filter::Reference wants Compress::Zlib
* wants POE::NonExistent
+POE::Wheel::Run wants IO::Pty
# End.
View
20 README
@@ -182,7 +182,19 @@ Event : (not installed)
All tests successful, 4 tests skipped.
Files=23, Tests=406, 114 wallclock secs (55.15 cusr + 5.20 csys = 60.35 CPU)
-** POE 0.1202 on Solaris/SunOS 5.8
+** POE 0.1203 on Linux
+
+Hardware: Celeron 600; unknown RAM
+System : Linux 2.4.0-test12
+Perl : 5.005_03
+Gtk : (unknown)
+Tk : (not installed)
+Event : (installed; unknown version)
+
+All tests successful, 2 tests skipped.
+Files=23, Tests=415, 98 wallclock secs (14.22 cusr + 0.63 csys = 14.85 CPU)
+
+** POE 0.1203 on Solaris/SunOS 5.8
(dynweb's machine rocks)
@@ -191,10 +203,10 @@ System : SunOS 5.7
Perl : 5.6.0
Gtk : (not installed)
Tk : (not installed)
-Event : (not installed)
+Event : 0.80
-All tests successful, 5 tests skipped.
-Files=22, Tests=308, 64 wallclock secs (11.63 cusr + 0.94 csys = 12.57 CPU)
+All tests successful, 2 tests skipped.
+Files=23, Tests=415, 98 wallclock secs (14.03 cusr + 0.99 csys = 15.02 CPU)
-------------
Test Coverage
View
@@ -6,6 +6,13 @@ use strict;
use Carp;
use POE qw(Wheel Pipe::TwoWay Pipe::OneWay Driver::SysRW);
+BEGIN {
+ local $SIG{'__DIE__'} = 'DEFAULT';
+ eval { require IO::Pty; IO::Pty->import(); };
+ if ($@) { eval 'sub PTY_AVAILABLE () { 0 }'; }
+ else { eval 'sub PTY_AVAILABLE () { 1 }'; }
+};
+
# Offsets into $self.
sub UNIQUE_ID () { 0 }
sub DRIVER () { 1 }
@@ -78,6 +85,7 @@ sub new {
if defined($stderr_event) and not defined($stderr_filter);
my $error_event = delete $params{ErrorEvent};
+ my $use_pty = delete $params{UsePty};
# Make sure the user didn't pass in parameters we're not aware of.
if (scalar keys %params) {
@@ -86,20 +94,46 @@ sub new {
);
}
- # Make the pipes. We make more pipes than strictly necessary in
- # case someone wants to turn some on later. Uses a TwoWay pipe for
- # STDIN/STDOUT and a OneWay pipe for STDERR. This may save 2
- # filehandles if socketpair() is available.
- my ($stdin_read, $stdout_write, $stdout_read, $stdin_write) =
- POE::Pipe::TwoWay->new();
- croak "could not make stdin pipes: $!"
- unless defined $stdin_read and defined $stdin_write;
- croak "could not make stdout pipes: $!"
- unless defined $stdout_read and defined $stdout_write;
-
- my ($stderr_read, $stderr_write) = POE::Pipe::OneWay->new();
- croak "could not make stderr pipes: $!"
- unless defined $stderr_read and defined $stderr_write;
+ my ( $stdin_read, $stdout_write, $stdout_read, $stdin_write,
+ $stderr_read, $stderr_write, $sem_pipe_read, $sem_pipe_write,
+ );
+
+ # Use IO::Pty if requested.
+ if (defined $use_pty) {
+ croak "IO::Pty is not available" unless PTY_AVAILABLE;
+ my $pty_master = IO::Pty->new();
+ croak "could not create master pty: $!" unless defined $pty_master;
+ my $pty_slave = IO::Pty->new();
+ croak "could not create slave pty: $!" unless defined $pty_slave;
+
+ $stdin_read = $pty_slave;
+ $stdin_write = $pty_master;
+
+ $stdout_read = $pty_master;
+ $stdout_write = $pty_slave;
+
+ ($sem_pipe_read, $sem_pipe_write) = POE::Pipe::OneWay->new();
+ croak "could not make a semaphore pipe: $!\n" unless defined $sem_pipe_read;
+ }
+
+ # Use pipes otherwise.
+ else {
+
+ # We make more pipes than strictly necessary in case someone wants
+ # to turn some on later. Uses a TwoWay pipe for STDIN/STDOUT and
+ # a OneWay pipe for STDERR. This may save 2 filehandles if
+ # socketpair() is available.
+ ($stdin_read, $stdout_write, $stdout_read, $stdin_write) =
+ POE::Pipe::TwoWay->new();
+ croak "could not make stdin pipes: $!"
+ unless defined $stdin_read and defined $stdin_write;
+ croak "could not make stdout pipes: $!"
+ unless defined $stdout_read and defined $stdout_write;
+
+ my ($stderr_read, $stderr_write) = POE::Pipe::OneWay->new();
+ croak "could not make stderr pipes: $!"
+ unless defined $stderr_read and defined $stderr_write;
+ }
# Fork! Woo-hoo!
my $pid = fork;
@@ -116,9 +150,16 @@ sub new {
open( STDOUT, ">&=" . fileno($stdout_write) )
or die "can't redirect stdout in child pid $$: $!";
- # Redirect STDERR to the write end of the stderr pipe.
- open( STDERR, ">&=" . fileno($stderr_write) )
- or die "can't redirect stderr in child: $!";
+ # Redirect STDERR to the write end of the stderr pipe. If the
+ # stderr pipe's undef, then we use STDOUT.
+ if (defined $stderr_write) {
+ open( STDERR, ">&=" . fileno($stderr_write) )
+ or die "can't redirect stderr in child: $!";
+ }
+ else {
+ open( STDERR, ">&=" . fileno($stdout_write) )
+ or die "can't redirect stderr in child: $!";
+ }
# Fix the priority delta. -><- Hardcoded constants mean this
# process, at least here. [crosses fingers] -><- Also must add
@@ -142,6 +183,10 @@ sub new {
$( = $) = $group_id;
}
+ # Wait for the ok, if needed.
+ close $sem_pipe_write if defined $sem_pipe_write;
+ <$sem_pipe_read> if defined $sem_pipe_read;
+
# Exec the program depending on its form.
if (ref($program) eq 'ARRAY') {
exec(@$program) or die "can't exec (@$program) in child pid $$: $!";
@@ -151,8 +196,6 @@ sub new {
}
}
- # Parent here.
-
my $self = bless
[ &POE::Wheel::allocate_wheel_id(), # UNIQUE_ID
POE::Driver::SysRW->new(), # DRIVER
@@ -181,6 +224,9 @@ sub new {
$self->_define_stdout_reader() if defined $stdout_event;
$self->_define_stderr_reader() if defined $stderr_event;
+ close $sem_pipe_read if defined $sem_pipe_read;
+ print($sem_pipe_write "go\n") if defined $sem_pipe_write;
+
return $self;
}
View
@@ -119,8 +119,8 @@ use POE qw( Wheel::Run Filter::Line Pipe::TwoWay Pipe::OneWay );
}
}
-### Test Wheel::Run. Uses "!" as a newline to avoid having to deal
-### with whatever the system uses.
+### Test Wheel::Run with filehandles. Uses "!" as a newline to avoid
+### having to deal with whatever the system uses.
my $program =
( '/usr/bin/perl -we \'' .
@@ -133,7 +133,65 @@ my $program =
'exit 0;\''
);
-my $flush_count = 0;
+my $tty_flush_count = 0;
+
+POE::Session->create
+ ( inline_states =>
+ { _start => sub {
+ my ($kernel, $heap) = @_[KERNEL, HEAP];
+
+ # Run a child process.
+ $heap->{wheel} = POE::Wheel::Run->new
+ ( Program => $program,
+ Filter => POE::Filter::Line->new( Literal => "!" ),
+ StdoutEvent => 'stdout',
+ StderrEvent => 'stderr',
+ ErrorEvent => 'error',
+ StdinEvent => 'stdin',
+ );
+
+ # Ask the child for something on stdout.
+ $heap->{wheel}->put( 'out test-out' );
+ },
+
+ # Catch SIGCHLD. Stop the wheel if the exited child is ours.
+ _signal => sub {
+ my $signame = $_[ARG0];
+ if ($signame eq 'CHLD') {
+ my ($heap, $child_pid) = @_[HEAP, ARG1];
+ delete $heap->{wheel} if $child_pid == $heap->{wheel}->PID();
+ }
+ return 0;
+ },
+
+ # Count every line that's flushed to the child.
+ stdin => sub { $tty_flush_count++; },
+
+ # Got a stdout response. Ask for something on stderr.
+ stdout => sub { &ok_if(17, $_[ARG0] eq 'out: test-out');
+ $_[HEAP]->{wheel}->put( 'err test-err' );
+ },
+
+ # Got a sterr response. Tell the child to exit.
+ stderr => sub { &ok_if(18, $_[ARG0] eq 'err: test-err');
+ $_[HEAP]->{wheel}->put( 'bye' );
+ },
+ },
+ );
+
+### Test Wheel::Run with ptys. Uses "!" as a newline to avoid having
+### to deal with whatever the system uses.
+
+my $program =
+ ( '/usr/bin/perl -we \'' .
+ '$/ = q(!); select STDERR; $| = 1; select STDOUT; $| = 1; ' .
+ 'while (<STDIN>) { ' .
+ ' print; ' .
+ '} ' .
+ 'exit 0;\''
+ );
+
+my $pty_flush_count = 0;
POE::Session->create
( inline_states =>
@@ -179,9 +237,11 @@ POE::Session->create
},
);
+### Run the main loop.
+
$poe_kernel->run();
-# out, err, bye == 3
-&ok_if( 16, $flush_count == 3 );
+### Post-run tests.
+&ok_if( 16, $tty_flush_count == 3 );
&results();

0 comments on commit c5c96e7

Please sign in to comment.