cpan/Test-Harness/lib/TAP/Parser/Iterator/Process.pm

   1 package TAP::Parser::Iterator::Process;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Config;
   7 use IO::Handle;
   8
   9 use base 'TAP::Parser::Iterator';
  10
  11 my $IS_WIN32 = ( $^O =~ /^(MS)?Win32$/ );
  12
  13 =head1 NAME
  14
  15 TAP::Parser::Iterator::Process - Iterator for process-based TAP sources
  16
  17 =head1 VERSION
  18
  19 Version 3.42
  20
  21 =cut
  22
  23 our $VERSION = '3.42';
  24
  25 =head1 SYNOPSIS
  26
  27   use TAP::Parser::Iterator::Process;
  28   my %args = (
  29    command  => ['python', 'setup.py', 'test'],
  30    merge    => 1,
  31    setup    => sub { ... },
  32    teardown => sub { ... },
  33   );
  34   my $it   = TAP::Parser::Iterator::Process->new(\%args);
  35   my $line = $it->next;
  36
  37 =head1 DESCRIPTION
  38
  39 This is a simple iterator wrapper for executing external processes, used by
  40 L<TAP::Parser>.  Unless you're writing a plugin or subclassing, you probably
  41 won't need to use this module directly.
  42
  43 =head1 METHODS
  44
  45 =head2 Class Methods
  46
  47 =head3 C<new>
  48
  49 Create an iterator.  Expects one argument containing a hashref of the form:
  50
  51    command  => \@command_to_execute
  52    merge    => $attempt_merge_stderr_and_stdout?
  53    setup    => $callback_to_setup_command
  54    teardown => $callback_to_teardown_command
  55
  56 Tries to uses L<IPC::Open3> & L<IO::Select> to communicate with the spawned
  57 process if they are available.  Falls back onto C<open()>.
  58
  59 =head2 Instance Methods
  60
  61 =head3 C<next>
  62
  63 Iterate through the process output, of course.
  64
  65 =head3 C<next_raw>
  66
  67 Iterate raw input without applying any fixes for quirky input syntax.
  68
  69 =head3 C<wait>
  70
  71 Get the wait status for this iterator's process.
  72
  73 =head3 C<exit>
  74
  75 Get the exit status for this iterator's process.
  76
  77 =cut
  78
  79 {
  80
  81     no warnings 'uninitialized';
  82        # get around a catch22 in the test suite that causes failures on Win32:
  83     local $SIG{__DIE__} = undef;
  84     eval { require POSIX; &POSIX::WEXITSTATUS(0) };
  85     if ($@) {
  86         *_wait2exit = sub { $_[1] >> 8 };
  87     }
  88     else {
  89         *_wait2exit = sub { POSIX::WEXITSTATUS( $_[1] ) }
  90     }
  91 }
  92
  93 sub _use_open3 {
  94     my $self = shift;
  95     return unless $Config{d_fork} || $IS_WIN32;
  96     for my $module (qw( IPC::Open3 IO::Select )) {
  97         eval "use $module";
  98         return if $@;
  99     }
 100     return 1;
 101 }
 102
 103 {
 104     my $got_unicode;
 105
 106     sub _get_unicode {
 107         return $got_unicode if defined $got_unicode;
 108         eval 'use Encode qw(decode_utf8);';
 109         $got_unicode = $@ ? 0 : 1;
 110
 111     }
 112 }
 113
 114 # new() implementation supplied by TAP::Object
 115
 116 sub _initialize {
 117     my ( $self, $args ) = @_;
 118
 119     my @command = @{ delete $args->{command} || [] }
 120       or die "Must supply a command to execute";
 121
 122     $self->{command} = [@command];
 123
 124     # Private. Used to frig with chunk size during testing.
 125     my $chunk_size = delete $args->{_chunk_size} || 65536;
 126
 127     my $merge = delete $args->{merge};
 128     my ( $pid, $err, $sel );
 129
 130     if ( my $setup = delete $args->{setup} ) {
 131         $setup->(@command);
 132     }
 133
 134     my $out = IO::Handle->new;
 135
 136     if ( $self->_use_open3 ) {
 137
 138         # HOTPATCH {{{
 139         my $xclose = \&IPC::Open3::xclose;
 140         no warnings;
 141         local *IPC::Open3::xclose = sub {
 142             my $fh = shift;
 143             no strict 'refs';
 144             return if ( fileno($fh) == fileno(STDIN) );
 145             $xclose->($fh);
 146         };
 147
 148         # }}}
 149
 150         if ($IS_WIN32) {
 151             $err = $merge ? '' : '>&STDERR';
 152             eval {
 153                 $pid = open3(
 154                     '<&STDIN', $out, $merge ? '' : $err,
 155                     @command
 156                 );
 157             };
 158             die "Could not execute (@command): $@" if $@;
 159             if ( $] >= 5.006 ) {
 160                 binmode($out, ":crlf");
 161             }
 162         }
 163         else {
 164             $err = $merge ? '' : IO::Handle->new;
 165             eval { $pid = open3( '<&STDIN', $out, $err, @command ); };
 166             die "Could not execute (@command): $@" if $@;
 167             $sel = $merge ? undef : IO::Select->new( $out, $err );
 168         }
 169     }
 170     else {
 171         $err = '';
 172         my $command
 173           = join( ' ', map { $_ =~ /\s/ ? qq{"$_"} : $_ } @command );
 174         open( $out, "$command|" )
 175           or die "Could not execute ($command): $!";
 176     }
 177
 178     $self->{out}        = $out;
 179     $self->{err}        = $err;
 180     $self->{sel}        = $sel;
 181     $self->{pid}        = $pid;
 182     $self->{exit}       = undef;
 183     $self->{chunk_size} = $chunk_size;
 184
 185     if ( my $teardown = delete $args->{teardown} ) {
 186         $self->{teardown} = sub {
 187             $teardown->(@command);
 188         };
 189     }
 190
 191     return $self;
 192 }
 193
 194 =head3 C<handle_unicode>
 195
 196 Upgrade the input stream to handle UTF8.
 197
 198 =cut
 199
 200 sub handle_unicode {
 201     my $self = shift;
 202
 203     if ( $self->{sel} ) {
 204         if ( _get_unicode() ) {
 205
 206             # Make sure our iterator has been constructed and...
 207             my $next = $self->{_next} ||= $self->_next;
 208
 209             # ...wrap it to do UTF8 casting
 210             $self->{_next} = sub {
 211                 my $line = $next->();
 212                 return decode_utf8($line) if defined $line;
 213                 return;
 214             };
 215         }
 216     }
 217     else {
 218         if ( $] >= 5.008 ) {
 219             eval 'binmode($self->{out}, ":utf8")';
 220         }
 221     }
 222
 223 }
 224
 225 ##############################################################################
 226
 227 sub wait { shift->{wait} }
 228 sub exit { shift->{exit} }
 229
 230 sub _next {
 231     my $self = shift;
 232
 233     if ( my $out = $self->{out} ) {
 234         if ( my $sel = $self->{sel} ) {
 235             my $err        = $self->{err};
 236             my @buf        = ();
 237             my $partial    = '';                    # Partial line
 238             my $chunk_size = $self->{chunk_size};
 239             return sub {
 240                 return shift @buf if @buf;
 241
 242                 READ:
 243                 while ( my @ready = $sel->can_read ) {
 244                     for my $fh (@ready) {
 245                         my $got = sysread $fh, my ($chunk), $chunk_size;
 246
 247                         if ( $got == 0 ) {
 248                             $sel->remove($fh);
 249                         }
 250                         elsif ( $fh == $err ) {
 251                             print STDERR $chunk;    # echo STDERR
 252                         }
 253                         else {
 254                             $chunk   = $partial . $chunk;
 255                             $partial = '';
 256
 257                             # Make sure we have a complete line
 258                             unless ( substr( $chunk, -1, 1 ) eq "\n" ) {
 259                                 my $nl = rindex $chunk, "\n";
 260                                 if ( $nl == -1 ) {
 261                                     $partial = $chunk;
 262                                     redo READ;
 263                                 }
 264                                 else {
 265                                     $partial = substr( $chunk, $nl + 1 );
 266                                     $chunk = substr( $chunk, 0, $nl );
 267                                 }
 268                             }
 269
 270                             push @buf, split /\n/, $chunk;
 271                             return shift @buf if @buf;
 272                         }
 273                     }
 274                 }
 275
 276                 # Return partial last line
 277                 if ( length $partial ) {
 278                     my $last = $partial;
 279                     $partial = '';
 280                     return $last;
 281                 }
 282
 283                 $self->_finish;
 284                 return;
 285             };
 286         }
 287         else {
 288             return sub {
 289                 if ( defined( my $line = <$out> ) ) {
 290                     chomp $line;
 291                     return $line;
 292                 }
 293                 $self->_finish;
 294                 return;
 295             };
 296         }
 297     }
 298     else {
 299         return sub {
 300             $self->_finish;
 301             return;
 302         };
 303     }
 304 }
 305
 306 sub next_raw {
 307     my $self = shift;
 308     return ( $self->{_next} ||= $self->_next )->();
 309 }
 310
 311 sub _finish {
 312     my $self = shift;
 313
 314     my $status = $?;
 315
 316     # Avoid circular refs
 317     $self->{_next} = sub {return}
 318       if $] >= 5.006;
 319
 320     # If we have a subprocess we need to wait for it to terminate
 321     if ( defined $self->{pid} ) {
 322         if ( $self->{pid} == waitpid( $self->{pid}, 0 ) ) {
 323             $status = $?;
 324         }
 325     }
 326
 327     ( delete $self->{out} )->close if $self->{out};
 328
 329     # If we have an IO::Select we also have an error handle to close.
 330     if ( $self->{sel} ) {
 331         ( delete $self->{err} )->close;
 332         delete $self->{sel};
 333     }
 334     else {
 335         $status = $?;
 336     }
 337
 338     # Sometimes we get -1 on Windows. Presumably that means status not
 339     # available.
 340     $status = 0 if $IS_WIN32 && $status == -1;
 341
 342     $self->{wait} = $status;
 343     $self->{exit} = $self->_wait2exit($status);
 344
 345     if ( my $teardown = $self->{teardown} ) {
 346         $teardown->();
 347     }
 348
 349     return $self;
 350 }
 351
 352 =head3 C<get_select_handles>
 353
 354 Return a list of filehandles that may be used upstream in a select()
 355 call to signal that this Iterator is ready. Iterators that are not
 356 handle based should return an empty list.
 357
 358 =cut
 359
 360 sub get_select_handles {
 361     my $self = shift;
 362     return grep $_, ( $self->{out}, $self->{err} );
 363 }
 364
 365 1;
 366
 367 =head1 ATTRIBUTION
 368
 369 Originally ripped off from L<Test::Harness>.
 370
 371 =head1 SEE ALSO
 372
 373 L<TAP::Object>,
 374 L<TAP::Parser>,
 375 L<TAP::Parser::Iterator>,
 376
 377 =cut
 378