1 package TAP::Parser::Iterator::Process;
4 use vars qw($VERSION @ISA);
6 use TAP::Parser::Iterator ();
10 @ISA = 'TAP::Parser::Iterator';
12 my $IS_WIN32 = ( $^O =~ /^(MS)?Win32$/ );
16 TAP::Parser::Iterator::Process - Internal TAP::Parser Iterator
28 # see TAP::Parser::IteratorFactory for preferred usage
31 use TAP::Parser::Iterator::Process;
33 command => ['python', 'setup.py', 'test'],
36 teardown => sub { ... },
38 my $it = TAP::Parser::Iterator::Process->new(\%args);
43 This is a simple iterator wrapper for executing external processes, used by
44 L<TAP::Parser>. Unless you're subclassing, you probably won't need to use
53 Create an iterator. Expects one argument containing a hashref of the form:
55 command => \@command_to_execute
56 merge => $attempt_merge_stderr_and_stdout?
57 setup => $callback_to_setup_command
58 teardown => $callback_to_teardown_command
60 Tries to uses L<IPC::Open3> & L<IO::Select> to communicate with the spawned
61 process if they are available. Falls back onto C<open()>.
63 =head2 Instance Methods
67 Iterate through the process output, of course.
71 Iterate raw input without applying any fixes for quirky input syntax.
75 Get the wait status for this iterator's process.
79 Get the exit status for this iterator's process.
83 eval { require POSIX; &POSIX::WEXITSTATUS(0) };
85 *_wait2exit = sub { $_[1] >> 8 };
88 *_wait2exit = sub { POSIX::WEXITSTATUS( $_[1] ) }
93 return unless $Config{d_fork} || $IS_WIN32;
94 for my $module (qw( IPC::Open3 IO::Select )) {
105 return $got_unicode if defined $got_unicode;
106 eval 'use Encode qw(decode_utf8);';
107 $got_unicode = $@ ? 0 : 1;
112 # new() implementation supplied by TAP::Object
115 my ( $self, $args ) = @_;
117 my @command = @{ delete $args->{command} || [] }
118 or die "Must supply a command to execute";
120 # Private. Used to frig with chunk size during testing.
121 my $chunk_size = delete $args->{_chunk_size} || 65536;
123 my $merge = delete $args->{merge};
124 my ( $pid, $err, $sel );
126 if ( my $setup = delete $args->{setup} ) {
130 my $out = IO::Handle->new;
132 if ( $self->_use_open3 ) {
135 my $xclose = \&IPC::Open3::xclose;
136 local $^W; # no warnings
137 local *IPC::Open3::xclose = sub {
140 return if ( fileno($fh) == fileno(STDIN) );
147 $err = $merge ? '' : '>&STDERR';
150 '<&STDIN', $out, $merge ? '' : $err,
154 die "Could not execute (@command): $@" if $@;
157 # Kludge to avoid warning under 5.5
158 eval 'binmode($out, ":crlf")';
162 $err = $merge ? '' : IO::Handle->new;
163 eval { $pid = open3( '<&STDIN', $out, $err, @command ); };
164 die "Could not execute (@command): $@" if $@;
165 $sel = $merge ? undef : IO::Select->new( $out, $err );
171 = join( ' ', map { $_ =~ /\s/ ? qq{"$_"} : $_ } @command );
172 open( $out, "$command|" )
173 or die "Could not execute ($command): $!";
180 $self->{exit} = undef;
181 $self->{chunk_size} = $chunk_size;
183 if ( my $teardown = delete $args->{teardown} ) {
184 $self->{teardown} = sub {
185 $teardown->(@command);
192 =head3 C<handle_unicode>
194 Upgrade the input stream to handle UTF8.
201 if ( $self->{sel} ) {
202 if ( _get_unicode() ) {
204 # Make sure our iterator has been constructed and...
205 my $next = $self->{_next} ||= $self->_next;
207 # ...wrap it to do UTF8 casting
208 $self->{_next} = sub {
209 my $line = $next->();
210 return decode_utf8($line) if defined $line;
217 eval 'binmode($self->{out}, ":utf8")';
223 ##############################################################################
225 sub wait { shift->{wait} }
226 sub exit { shift->{exit} }
231 if ( my $out = $self->{out} ) {
232 if ( my $sel = $self->{sel} ) {
233 my $err = $self->{err};
235 my $partial = ''; # Partial line
236 my $chunk_size = $self->{chunk_size};
238 return shift @buf if @buf;
241 while ( my @ready = $sel->can_read ) {
242 for my $fh (@ready) {
243 my $got = sysread $fh, my ($chunk), $chunk_size;
248 elsif ( $fh == $err ) {
249 print STDERR $chunk; # echo STDERR
252 $chunk = $partial . $chunk;
255 # Make sure we have a complete line
256 unless ( substr( $chunk, -1, 1 ) eq "\n" ) {
257 my $nl = rindex $chunk, "\n";
263 $partial = substr( $chunk, $nl + 1 );
264 $chunk = substr( $chunk, 0, $nl );
268 push @buf, split /\n/, $chunk;
269 return shift @buf if @buf;
274 # Return partial last line
275 if ( length $partial ) {
287 if ( defined( my $line = <$out> ) ) {
306 return ( $self->{_next} ||= $self->_next )->();
314 # Avoid circular refs
315 $self->{_next} = sub {return}
318 # If we have a subprocess we need to wait for it to terminate
319 if ( defined $self->{pid} ) {
320 if ( $self->{pid} == waitpid( $self->{pid}, 0 ) ) {
325 ( delete $self->{out} )->close if $self->{out};
327 # If we have an IO::Select we also have an error handle to close.
328 if ( $self->{sel} ) {
329 ( delete $self->{err} )->close;
336 # Sometimes we get -1 on Windows. Presumably that means status not
338 $status = 0 if $IS_WIN32 && $status == -1;
340 $self->{wait} = $status;
341 $self->{exit} = $self->_wait2exit($status);
343 if ( my $teardown = $self->{teardown} ) {
350 =head3 C<get_select_handles>
352 Return a list of filehandles that may be used upstream in a select()
353 call to signal that this Iterator is ready. Iterators that are not
354 handle based should return an empty list.
358 sub get_select_handles {
360 return grep $_, ( $self->{out}, $self->{err} );
367 Originally ripped off from L<Test::Harness>.
373 L<TAP::Parser::Iterator>,
374 L<TAP::Parser::IteratorFactory>,