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