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

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