Commit | Line | Data |
3fea05b9 |
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.17 |
21 | |
22 | =cut |
23 | |
24 | $VERSION = '3.17'; |
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 | # Avoid circular refs |
315 | $self->{_next} = sub {return} |
316 | if $] >= 5.006; |
317 | |
318 | # If we have a subprocess we need to wait for it to terminate |
319 | if ( defined $self->{pid} ) { |
320 | if ( $self->{pid} == waitpid( $self->{pid}, 0 ) ) { |
321 | $status = $?; |
322 | } |
323 | } |
324 | |
325 | ( delete $self->{out} )->close if $self->{out}; |
326 | |
327 | # If we have an IO::Select we also have an error handle to close. |
328 | if ( $self->{sel} ) { |
329 | ( delete $self->{err} )->close; |
330 | delete $self->{sel}; |
331 | } |
332 | else { |
333 | $status = $?; |
334 | } |
335 | |
336 | # Sometimes we get -1 on Windows. Presumably that means status not |
337 | # available. |
338 | $status = 0 if $IS_WIN32 && $status == -1; |
339 | |
340 | $self->{wait} = $status; |
341 | $self->{exit} = $self->_wait2exit($status); |
342 | |
343 | if ( my $teardown = $self->{teardown} ) { |
344 | $teardown->(); |
345 | } |
346 | |
347 | return $self; |
348 | } |
349 | |
350 | =head3 C<get_select_handles> |
351 | |
352 | Return a list of filehandles that may be used upstream in a select() |
353 | call to signal that this Iterator is ready. Iterators that are not |
354 | handle based should return an empty list. |
355 | |
356 | =cut |
357 | |
358 | sub get_select_handles { |
359 | my $self = shift; |
360 | return grep $_, ( $self->{out}, $self->{err} ); |
361 | } |
362 | |
363 | 1; |
364 | |
365 | =head1 ATTRIBUTION |
366 | |
367 | Originally ripped off from L<Test::Harness>. |
368 | |
369 | =head1 SEE ALSO |
370 | |
371 | L<TAP::Object>, |
372 | L<TAP::Parser>, |
373 | L<TAP::Parser::Iterator>, |
374 | L<TAP::Parser::IteratorFactory>, |
375 | |
376 | =cut |
377 | |