Commit | Line | Data |
b965d173 |
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 | |
69f36734 |
22 | Version 3.06 |
b965d173 |
23 | |
24 | =cut |
25 | |
69f36734 |
26 | $VERSION = '3.06'; |
b965d173 |
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; |