lib/TAP/Parser/Iterator/Process.pm

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