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