1package TAP::Parser::Iterator::Process; 2 3use strict; 4use warnings; 5 6use Config; 7use IO::Handle; 8 9use base 'TAP::Parser::Iterator'; 10 11my $IS_WIN32 = ( $^O =~ /^(MS)?Win32$/ ); 12 13=head1 NAME 14 15TAP::Parser::Iterator::Process - Iterator for process-based TAP sources 16 17=head1 VERSION 18 19Version 3.44 20 21=cut 22 23our $VERSION = '3.44'; 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 39This is a simple iterator wrapper for executing external processes, used by 40L<TAP::Parser>. Unless you're writing a plugin or subclassing, you probably 41won't need to use this module directly. 42 43=head1 METHODS 44 45=head2 Class Methods 46 47=head3 C<new> 48 49Create 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 56Tries to uses L<IPC::Open3> & L<IO::Select> to communicate with the spawned 57process if they are available. Falls back onto C<open()>. 58 59=head2 Instance Methods 60 61=head3 C<next> 62 63Iterate through the process output, of course. 64 65=head3 C<next_raw> 66 67Iterate raw input without applying any fixes for quirky input syntax. 68 69=head3 C<wait> 70 71Get the wait status for this iterator's process. 72 73=head3 C<exit> 74 75Get 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 93sub _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 116sub _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 196Upgrade the input stream to handle UTF8. 197 198=cut 199 200sub 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 227sub wait { shift->{wait} } 228sub exit { shift->{exit} } 229 230sub _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 306sub next_raw { 307 my $self = shift; 308 return ( $self->{_next} ||= $self->_next )->(); 309} 310 311sub _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 354Return a list of filehandles that may be used upstream in a select() 355call to signal that this Iterator is ready. Iterators that are not 356handle based should return an empty list. 357 358=cut 359 360sub get_select_handles { 361 my $self = shift; 362 return grep $_, ( $self->{out}, $self->{err} ); 363} 364 3651; 366 367=head1 ATTRIBUTION 368 369Originally ripped off from L<Test::Harness>. 370 371=head1 SEE ALSO 372 373L<TAP::Object>, 374L<TAP::Parser>, 375L<TAP::Parser::Iterator>, 376 377=cut 378 379