Filename | /usr/lib64/perl5/vendor_perl/5.16.0/IPC/Run3.pm |
Statements | Executed 31 statements in 16.3ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 35.6ms | 67.2ms | BEGIN@55 | IPC::Run3::
1 | 1 | 1 | 20.2ms | 53.9ms | BEGIN@56 | IPC::Run3::
1 | 1 | 1 | 95µs | 95µs | BEGIN@2 | IPC::Run3::
1 | 1 | 1 | 61µs | 249µs | BEGIN@43 | IPC::Run3::
1 | 1 | 1 | 59µs | 293µs | BEGIN@41 | IPC::Run3::
1 | 1 | 1 | 56µs | 163µs | BEGIN@36 | IPC::Run3::
1 | 1 | 1 | 56µs | 274µs | BEGIN@42 | IPC::Run3::
1 | 1 | 1 | 55µs | 365µs | BEGIN@54 | IPC::Run3::
1 | 1 | 1 | 51µs | 148µs | BEGIN@3 | IPC::Run3::
1 | 1 | 1 | 28µs | 28µs | BEGIN@67 | IPC::Run3::
1 | 1 | 1 | 22µs | 22µs | BEGIN@45 | IPC::Run3::
1 | 1 | 1 | 10µs | 10µs | END | IPC::Run3::
0 | 0 | 0 | 0s | 0s | _binmode | IPC::Run3::
0 | 0 | 0 | 0s | 0s | _fh_for_child_output | IPC::Run3::
0 | 0 | 0 | 0s | 0s | _max_fd | IPC::Run3::
0 | 0 | 0 | 0s | 0s | _profiler | IPC::Run3::
0 | 0 | 0 | 0s | 0s | _read_child_output_fh | IPC::Run3::
0 | 0 | 0 | 0s | 0s | _spool_data_to_child | IPC::Run3::
0 | 0 | 0 | 0s | 0s | _type | IPC::Run3::
0 | 0 | 0 | 0s | 0s | run3 | IPC::Run3::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package IPC::Run3; | ||||
2 | 1 | 188µs | 1 | 95µs | # spent 95µs within IPC::Run3::BEGIN@2 which was called:
# once (95µs+0s) by RTP::Webmerge::Compile::JS::BEGIN@26 at line 2 # spent 95µs making 1 call to IPC::Run3::BEGIN@2 |
3 | 2 | 271µs | 2 | 244µs | # spent 148µs (51+96) within IPC::Run3::BEGIN@3 which was called:
# once (51µs+96µs) by RTP::Webmerge::Compile::JS::BEGIN@26 at line 3 # spent 148µs making 1 call to IPC::Run3::BEGIN@3
# spent 96µs making 1 call to strict::import |
4 | |||||
5 | =head1 NAME | ||||
6 | |||||
7 | IPC::Run3 - run a subprocess with input/ouput redirection | ||||
8 | |||||
9 | =head1 VERSION | ||||
10 | |||||
11 | version 0.045 | ||||
12 | |||||
13 | =cut | ||||
14 | |||||
15 | 1 | 4µs | our $VERSION = '0.045'; | ||
16 | |||||
17 | =head1 SYNOPSIS | ||||
18 | |||||
19 | use IPC::Run3; # Exports run3() by default | ||||
20 | |||||
21 | run3 \@cmd, \$in, \$out, \$err; | ||||
22 | |||||
23 | =head1 DESCRIPTION | ||||
24 | |||||
25 | This module allows you to run a subprocess and redirect stdin, stdout, | ||||
26 | and/or stderr to files and perl data structures. It aims to satisfy 99% of the | ||||
27 | need for using C<system>, C<qx>, and C<open3> | ||||
28 | with a simple, extremely Perlish API. | ||||
29 | |||||
30 | Speed, simplicity, and portability are paramount. (That's speed of Perl code; | ||||
31 | which is often much slower than the kind of buffered I/O that this module uses | ||||
32 | to spool input to and output from the child command.) | ||||
33 | |||||
34 | =cut | ||||
35 | |||||
36 | 2 | 416µs | 2 | 270µs | # spent 163µs (56+107) within IPC::Run3::BEGIN@36 which was called:
# once (56µs+107µs) by RTP::Webmerge::Compile::JS::BEGIN@26 at line 36 # spent 163µs making 1 call to IPC::Run3::BEGIN@36
# spent 107µs making 1 call to Exporter::import |
37 | 1 | 39µs | our @ISA = qw(Exporter); | ||
38 | 1 | 6µs | our @EXPORT = qw( run3 ); | ||
39 | 1 | 10µs | our %EXPORT_TAGS = ( all => \@EXPORT ); | ||
40 | |||||
41 | 2 | 219µs | 2 | 527µs | # spent 293µs (59+234) within IPC::Run3::BEGIN@41 which was called:
# once (59µs+234µs) by RTP::Webmerge::Compile::JS::BEGIN@26 at line 41 # spent 293µs making 1 call to IPC::Run3::BEGIN@41
# spent 234µs making 1 call to constant::import |
42 | 2 | 217µs | 2 | 492µs | # spent 274µs (56+218) within IPC::Run3::BEGIN@42 which was called:
# once (56µs+218µs) by RTP::Webmerge::Compile::JS::BEGIN@26 at line 42 # spent 274µs making 1 call to IPC::Run3::BEGIN@42
# spent 218µs making 1 call to constant::import |
43 | 2 | 296µs | 2 | 437µs | # spent 249µs (61+188) within IPC::Run3::BEGIN@43 which was called:
# once (61µs+188µs) by RTP::Webmerge::Compile::JS::BEGIN@26 at line 43 # spent 249µs making 1 call to IPC::Run3::BEGIN@43
# spent 188µs making 1 call to constant::import |
44 | |||||
45 | # spent 22µs within IPC::Run3::BEGIN@45 which was called:
# once (22µs+0s) by RTP::Webmerge::Compile::JS::BEGIN@26 at line 49 | ||||
46 | 1 | 24µs | if ( is_win32 ) { | ||
47 | eval "use Win32 qw( GetOSName ); 1" or die $@; | ||||
48 | } | ||||
49 | 1 | 118µs | 1 | 22µs | } # spent 22µs making 1 call to IPC::Run3::BEGIN@45 |
50 | |||||
51 | #use constant is_win2k => is_win32 && GetOSName() =~ /Win2000/i; | ||||
52 | #use constant is_winXP => is_win32 && GetOSName() =~ /WinXP/i; | ||||
53 | |||||
54 | 2 | 160µs | 2 | 676µs | # spent 365µs (55+310) within IPC::Run3::BEGIN@54 which was called:
# once (55µs+310µs) by RTP::Webmerge::Compile::JS::BEGIN@26 at line 54 # spent 365µs making 1 call to IPC::Run3::BEGIN@54
# spent 310µs making 1 call to Exporter::import |
55 | 2 | 1.07ms | 2 | 67.7ms | # spent 67.2ms (35.6+31.6) within IPC::Run3::BEGIN@55 which was called:
# once (35.6ms+31.6ms) by RTP::Webmerge::Compile::JS::BEGIN@26 at line 55 # spent 67.2ms making 1 call to IPC::Run3::BEGIN@55
# spent 515µs making 1 call to Exporter::import |
56 | 2 | 1.93ms | 2 | 68.0ms | # spent 53.9ms (20.2+33.7) within IPC::Run3::BEGIN@56 which was called:
# once (20.2ms+33.7ms) by RTP::Webmerge::Compile::JS::BEGIN@26 at line 56 # spent 53.9ms making 1 call to IPC::Run3::BEGIN@56
# spent 14.1ms making 1 call to POSIX::import |
57 | |||||
58 | # We cache the handles of our temp files in order to | ||||
59 | # keep from having to incur the (largish) overhead of File::Temp | ||||
60 | 1 | 2µs | my %fh_cache; | ||
61 | 1 | 6µs | my $fh_cache_pid = $$; | ||
62 | |||||
63 | 1 | 500ns | my $profiler; | ||
64 | |||||
65 | sub _profiler { $profiler } # test suite access | ||||
66 | |||||
67 | # spent 28µs within IPC::Run3::BEGIN@67 which was called:
# once (28µs+0s) by RTP::Webmerge::Compile::JS::BEGIN@26 at line 88 | ||||
68 | 1 | 30µs | if ( profiling ) { | ||
69 | eval "use Time::HiRes qw( gettimeofday ); 1" or die $@; | ||||
70 | if ( $ENV{IPCRUN3PROFILE} =~ /\A\d+\z/ ) { | ||||
71 | require IPC::Run3::ProfPP; | ||||
72 | IPC::Run3::ProfPP->import; | ||||
73 | $profiler = IPC::Run3::ProfPP->new(Level => $ENV{IPCRUN3PROFILE}); | ||||
74 | } else { | ||||
75 | my ( $dest, undef, $class ) = | ||||
76 | reverse split /(=)/, $ENV{IPCRUN3PROFILE}, 2; | ||||
77 | $class = "IPC::Run3::ProfLogger" | ||||
78 | unless defined $class && length $class; | ||||
79 | if ( not eval "require $class" ) { | ||||
80 | my $e = $@; | ||||
81 | $class = "IPC::Run3::$class"; | ||||
82 | eval "require IPC::Run3::$class" or die $e; | ||||
83 | } | ||||
84 | $profiler = $class->new( Destination => $dest ); | ||||
85 | } | ||||
86 | $profiler->app_call( [ $0, @ARGV ], scalar gettimeofday() ); | ||||
87 | } | ||||
88 | 1 | 11.2ms | 1 | 28µs | } # spent 28µs making 1 call to IPC::Run3::BEGIN@67 |
89 | |||||
90 | |||||
91 | # spent 10µs within IPC::Run3::END which was called:
# once (10µs+0s) by main::RUNTIME at line 0 of webmerge/scripts/webmerge.pl | ||||
92 | 1 | 24µs | $profiler->app_exit( scalar gettimeofday() ) if profiling; | ||
93 | } | ||||
94 | |||||
95 | sub _binmode { | ||||
96 | my ( $fh, $mode, $what ) = @_; | ||||
97 | # if $mode is not given, then default to ":raw", except on Windows, | ||||
98 | # where we default to ":crlf"; | ||||
99 | # otherwise if a proper layer string was given, use that, | ||||
100 | # else use ":raw" | ||||
101 | my $layer = !$mode | ||||
102 | ? (is_win32 ? ":crlf" : ":raw") | ||||
103 | : ($mode =~ /^:/ ? $mode : ":raw"); | ||||
104 | warn "binmode $what, $layer\n" if debugging >= 2; | ||||
105 | |||||
106 | binmode $fh, ":raw" unless $layer eq ":raw"; # remove all layers first | ||||
107 | binmode $fh, $layer or croak "binmode $layer failed: $!"; | ||||
108 | } | ||||
109 | |||||
110 | sub _spool_data_to_child { | ||||
111 | my ( $type, $source, $binmode_it ) = @_; | ||||
112 | |||||
113 | # If undef (not \undef) passed, they want the child to inherit | ||||
114 | # the parent's STDIN. | ||||
115 | return undef unless defined $source; | ||||
116 | |||||
117 | my $fh; | ||||
118 | if ( ! $type ) { | ||||
119 | open $fh, "<", $source or croak "$!: $source"; | ||||
120 | _binmode($fh, $binmode_it, "STDIN"); | ||||
121 | warn "run3(): feeding file '$source' to child STDIN\n" | ||||
122 | if debugging >= 2; | ||||
123 | } elsif ( $type eq "FH" ) { | ||||
124 | $fh = $source; | ||||
125 | warn "run3(): feeding filehandle '$source' to child STDIN\n" | ||||
126 | if debugging >= 2; | ||||
127 | } else { | ||||
128 | $fh = $fh_cache{in} ||= tempfile; | ||||
129 | truncate $fh, 0; | ||||
130 | seek $fh, 0, 0; | ||||
131 | _binmode($fh, $binmode_it, "STDIN"); | ||||
132 | my $seekit; | ||||
133 | if ( $type eq "SCALAR" ) { | ||||
134 | |||||
135 | # When the run3()'s caller asks to feed an empty file | ||||
136 | # to the child's stdin, we want to pass a live file | ||||
137 | # descriptor to an empty file (like /dev/null) so that | ||||
138 | # they don't get surprised by invalid fd errors and get | ||||
139 | # normal EOF behaviors. | ||||
140 | return $fh unless defined $$source; # \undef passed | ||||
141 | |||||
142 | warn "run3(): feeding SCALAR to child STDIN", | ||||
143 | debugging >= 3 | ||||
144 | ? ( ": '", $$source, "' (", length $$source, " chars)" ) | ||||
145 | : (), | ||||
146 | "\n" | ||||
147 | if debugging >= 2; | ||||
148 | |||||
149 | $seekit = length $$source; | ||||
150 | print $fh $$source or die "$! writing to temp file"; | ||||
151 | |||||
152 | } elsif ( $type eq "ARRAY" ) { | ||||
153 | warn "run3(): feeding ARRAY to child STDIN", | ||||
154 | debugging >= 3 ? ( ": '", @$source, "'" ) : (), | ||||
155 | "\n" | ||||
156 | if debugging >= 2; | ||||
157 | |||||
158 | print $fh @$source or die "$! writing to temp file"; | ||||
159 | $seekit = grep length, @$source; | ||||
160 | } elsif ( $type eq "CODE" ) { | ||||
161 | warn "run3(): feeding output of CODE ref '$source' to child STDIN\n" | ||||
162 | if debugging >= 2; | ||||
163 | my $parms = []; # TODO: get these from $options | ||||
164 | while (1) { | ||||
165 | my $data = $source->( @$parms ); | ||||
166 | last unless defined $data; | ||||
167 | print $fh $data or die "$! writing to temp file"; | ||||
168 | $seekit = length $data; | ||||
169 | } | ||||
170 | } | ||||
171 | |||||
172 | seek $fh, 0, 0 or croak "$! seeking on temp file for child's stdin" | ||||
173 | if $seekit; | ||||
174 | } | ||||
175 | |||||
176 | croak "run3() can't redirect $type to child stdin" | ||||
177 | unless defined $fh; | ||||
178 | |||||
179 | return $fh; | ||||
180 | } | ||||
181 | |||||
182 | sub _fh_for_child_output { | ||||
183 | my ( $what, $type, $dest, $options ) = @_; | ||||
184 | |||||
185 | my $fh; | ||||
186 | if ( $type eq "SCALAR" && $dest == \undef ) { | ||||
187 | warn "run3(): redirecting child $what to oblivion\n" | ||||
188 | if debugging >= 2; | ||||
189 | |||||
190 | $fh = $fh_cache{nul} ||= do { | ||||
191 | open $fh, ">", File::Spec->devnull; | ||||
192 | $fh; | ||||
193 | }; | ||||
194 | } elsif ( $type eq "FH" ) { | ||||
195 | $fh = $dest; | ||||
196 | warn "run3(): redirecting $what to filehandle '$dest'\n" | ||||
197 | if debugging >= 3; | ||||
198 | } elsif ( !$type ) { | ||||
199 | warn "run3(): feeding child $what to file '$dest'\n" | ||||
200 | if debugging >= 2; | ||||
201 | |||||
202 | open $fh, $options->{"append_$what"} ? ">>" : ">", $dest | ||||
203 | or croak "$!: $dest"; | ||||
204 | } else { | ||||
205 | warn "run3(): capturing child $what\n" | ||||
206 | if debugging >= 2; | ||||
207 | |||||
208 | $fh = $fh_cache{$what} ||= tempfile; | ||||
209 | seek $fh, 0, 0; | ||||
210 | truncate $fh, 0; | ||||
211 | } | ||||
212 | |||||
213 | my $binmode_it = $options->{"binmode_$what"}; | ||||
214 | _binmode($fh, $binmode_it, uc $what); | ||||
215 | |||||
216 | return $fh; | ||||
217 | } | ||||
218 | |||||
219 | sub _read_child_output_fh { | ||||
220 | my ( $what, $type, $dest, $fh, $options ) = @_; | ||||
221 | |||||
222 | return if $type eq "SCALAR" && $dest == \undef; | ||||
223 | |||||
224 | seek $fh, 0, 0 or croak "$! seeking on temp file for child $what"; | ||||
225 | |||||
226 | if ( $type eq "SCALAR" ) { | ||||
227 | warn "run3(): reading child $what to SCALAR\n" | ||||
228 | if debugging >= 3; | ||||
229 | |||||
230 | # two read()s are used instead of 1 so that the first will be | ||||
231 | # logged even it reads 0 bytes; the second won't. | ||||
232 | my $count = read $fh, $$dest, 10_000, | ||||
233 | $options->{"append_$what"} ? length $$dest : 0; | ||||
234 | while (1) { | ||||
235 | croak "$! reading child $what from temp file" | ||||
236 | unless defined $count; | ||||
237 | |||||
238 | last unless $count; | ||||
239 | |||||
240 | warn "run3(): read $count bytes from child $what", | ||||
241 | debugging >= 3 ? ( ": '", substr( $$dest, -$count ), "'" ) : (), | ||||
242 | "\n" | ||||
243 | if debugging >= 2; | ||||
244 | |||||
245 | $count = read $fh, $$dest, 10_000, length $$dest; | ||||
246 | } | ||||
247 | } elsif ( $type eq "ARRAY" ) { | ||||
248 | if ($options->{"append_$what"}) { | ||||
249 | push @$dest, <$fh>; | ||||
250 | } else { | ||||
251 | @$dest = <$fh>; | ||||
252 | } | ||||
253 | if ( debugging >= 2 ) { | ||||
254 | my $count = 0; | ||||
255 | $count += length for @$dest; | ||||
256 | warn | ||||
257 | "run3(): read ", | ||||
258 | scalar @$dest, | ||||
259 | " records, $count bytes from child $what", | ||||
260 | debugging >= 3 ? ( ": '", @$dest, "'" ) : (), | ||||
261 | "\n"; | ||||
262 | } | ||||
263 | } elsif ( $type eq "CODE" ) { | ||||
264 | warn "run3(): capturing child $what to CODE ref\n" | ||||
265 | if debugging >= 3; | ||||
266 | |||||
267 | local $_; | ||||
268 | while ( <$fh> ) { | ||||
269 | warn | ||||
270 | "run3(): read ", | ||||
271 | length, | ||||
272 | " bytes from child $what", | ||||
273 | debugging >= 3 ? ( ": '", $_, "'" ) : (), | ||||
274 | "\n" | ||||
275 | if debugging >= 2; | ||||
276 | |||||
277 | $dest->( $_ ); | ||||
278 | } | ||||
279 | } else { | ||||
280 | croak "run3() can't redirect child $what to a $type"; | ||||
281 | } | ||||
282 | |||||
283 | } | ||||
284 | |||||
285 | sub _type { | ||||
286 | my ( $redir ) = @_; | ||||
287 | |||||
288 | return "FH" if eval { | ||||
289 | local $SIG{'__DIE__'}; | ||||
290 | $redir->isa("IO::Handle") | ||||
291 | }; | ||||
292 | |||||
293 | my $type = ref $redir; | ||||
294 | return $type eq "GLOB" ? "FH" : $type; | ||||
295 | } | ||||
296 | |||||
297 | sub _max_fd { | ||||
298 | my $fd = dup(0); | ||||
299 | POSIX::close $fd; | ||||
300 | return $fd; | ||||
301 | } | ||||
302 | |||||
303 | 1 | 500ns | my $run_call_time; | ||
304 | 1 | 600ns | my $sys_call_time; | ||
305 | 1 | 600ns | my $sys_exit_time; | ||
306 | |||||
307 | sub run3 { | ||||
308 | $run_call_time = gettimeofday() if profiling; | ||||
309 | |||||
310 | my $options = @_ && ref $_[-1] eq "HASH" ? pop : {}; | ||||
311 | |||||
312 | my ( $cmd, $stdin, $stdout, $stderr ) = @_; | ||||
313 | |||||
314 | print STDERR "run3(): running ", | ||||
315 | join( " ", map "'$_'", ref $cmd ? @$cmd : $cmd ), | ||||
316 | "\n" | ||||
317 | if debugging; | ||||
318 | |||||
319 | if ( ref $cmd ) { | ||||
320 | croak "run3(): empty command" unless @$cmd; | ||||
321 | croak "run3(): undefined command" unless defined $cmd->[0]; | ||||
322 | croak "run3(): command name ('')" unless length $cmd->[0]; | ||||
323 | } else { | ||||
324 | croak "run3(): missing command" unless @_; | ||||
325 | croak "run3(): undefined command" unless defined $cmd; | ||||
326 | croak "run3(): command ('')" unless length $cmd; | ||||
327 | } | ||||
328 | |||||
329 | foreach (qw/binmode_stdin binmode_stdout binmode_stderr/) { | ||||
330 | if (my $mode = $options->{$_}) { | ||||
331 | croak qq[option $_ must be a number or a proper layer string: "$mode"] | ||||
332 | unless $mode =~ /^(:|\d+$)/; | ||||
333 | } | ||||
334 | } | ||||
335 | |||||
336 | my $in_type = _type $stdin; | ||||
337 | my $out_type = _type $stdout; | ||||
338 | my $err_type = _type $stderr; | ||||
339 | |||||
340 | if ($fh_cache_pid != $$) { | ||||
341 | # fork detected, close all cached filehandles and clear the cache | ||||
342 | close $_ foreach values %fh_cache; | ||||
343 | %fh_cache = (); | ||||
344 | $fh_cache_pid = $$; | ||||
345 | } | ||||
346 | |||||
347 | # This routine procedes in stages so that a failure in an early | ||||
348 | # stage prevents later stages from running, and thus from needing | ||||
349 | # cleanup. | ||||
350 | |||||
351 | my $in_fh = _spool_data_to_child $in_type, $stdin, | ||||
352 | $options->{binmode_stdin} if defined $stdin; | ||||
353 | |||||
354 | my $out_fh = _fh_for_child_output "stdout", $out_type, $stdout, | ||||
355 | $options if defined $stdout; | ||||
356 | |||||
357 | my $tie_err_to_out = | ||||
358 | defined $stderr && defined $stdout && $stderr eq $stdout; | ||||
359 | |||||
360 | my $err_fh = $tie_err_to_out | ||||
361 | ? $out_fh | ||||
362 | : _fh_for_child_output "stderr", $err_type, $stderr, | ||||
363 | $options if defined $stderr; | ||||
364 | |||||
365 | # this should make perl close these on exceptions | ||||
366 | # local *STDIN_SAVE; | ||||
367 | local *STDOUT_SAVE; | ||||
368 | local *STDERR_SAVE; | ||||
369 | |||||
370 | my $saved_fd0 = dup( 0 ) if defined $in_fh; | ||||
371 | |||||
372 | # open STDIN_SAVE, "<&STDIN"# or croak "run3(): $! saving STDIN" | ||||
373 | # if defined $in_fh; | ||||
374 | open STDOUT_SAVE, ">&STDOUT" or croak "run3(): $! saving STDOUT" | ||||
375 | if defined $out_fh; | ||||
376 | open STDERR_SAVE, ">&STDERR" or croak "run3(): $! saving STDERR" | ||||
377 | if defined $err_fh; | ||||
378 | |||||
379 | my $errno; | ||||
380 | my $ok = eval { | ||||
381 | # The open() call here seems to not force fd 0 in some cases; | ||||
382 | # I ran in to trouble when using this in VCP, not sure why. | ||||
383 | # the dup2() seems to work. | ||||
384 | dup2( fileno $in_fh, 0 ) | ||||
385 | # open STDIN, "<&=" . fileno $in_fh | ||||
386 | or croak "run3(): $! redirecting STDIN" | ||||
387 | if defined $in_fh; | ||||
388 | |||||
389 | # close $in_fh or croak "$! closing STDIN temp file" | ||||
390 | # if ref $stdin; | ||||
391 | |||||
392 | open STDOUT, ">&" . fileno $out_fh | ||||
393 | or croak "run3(): $! redirecting STDOUT" | ||||
394 | if defined $out_fh; | ||||
395 | |||||
396 | open STDERR, ">&" . fileno $err_fh | ||||
397 | or croak "run3(): $! redirecting STDERR" | ||||
398 | if defined $err_fh; | ||||
399 | |||||
400 | $sys_call_time = gettimeofday() if profiling; | ||||
401 | |||||
402 | my $r = ref $cmd | ||||
403 | ? system { $cmd->[0] } | ||||
404 | is_win32 | ||||
405 | ? map { | ||||
406 | # Probably need to offer a win32 escaping | ||||
407 | # option, every command may be different. | ||||
408 | ( my $s = $_ ) =~ s/"/"""/g; | ||||
409 | $s = qq{"$s"}; | ||||
410 | $s; | ||||
411 | } @$cmd | ||||
412 | : @$cmd | ||||
413 | : system $cmd; | ||||
414 | |||||
415 | $errno = $!; # save $!, because later failures will overwrite it | ||||
416 | $sys_exit_time = gettimeofday() if profiling; | ||||
417 | if ( debugging ) { | ||||
418 | my $err_fh = defined $err_fh ? \*STDERR_SAVE : \*STDERR; | ||||
419 | if ( defined $r && $r != -1 ) { | ||||
420 | print $err_fh "run3(): \$? is $?\n"; | ||||
421 | } else { | ||||
422 | print $err_fh "run3(): \$? is $?, \$! is $errno\n"; | ||||
423 | } | ||||
424 | } | ||||
425 | |||||
426 | die $! if defined $r && $r == -1 && !$options->{return_if_system_error}; | ||||
427 | |||||
428 | 1; | ||||
429 | }; | ||||
430 | my $x = $@; | ||||
431 | |||||
432 | my @errs; | ||||
433 | |||||
434 | if ( defined $saved_fd0 ) { | ||||
435 | dup2( $saved_fd0, 0 ); | ||||
436 | POSIX::close( $saved_fd0 ); | ||||
437 | } | ||||
438 | |||||
439 | # open STDIN, "<&STDIN_SAVE"# or push @errs, "run3(): $! restoring STDIN" | ||||
440 | # if defined $in_fh; | ||||
441 | open STDOUT, ">&STDOUT_SAVE" or push @errs, "run3(): $! restoring STDOUT" | ||||
442 | if defined $out_fh; | ||||
443 | open STDERR, ">&STDERR_SAVE" or push @errs, "run3(): $! restoring STDERR" | ||||
444 | if defined $err_fh; | ||||
445 | |||||
446 | croak join ", ", @errs if @errs; | ||||
447 | |||||
448 | die $x unless $ok; | ||||
449 | |||||
450 | _read_child_output_fh "stdout", $out_type, $stdout, $out_fh, $options | ||||
451 | if defined $out_fh && $out_type && $out_type ne "FH"; | ||||
452 | _read_child_output_fh "stderr", $err_type, $stderr, $err_fh, $options | ||||
453 | if defined $err_fh && $err_type && $err_type ne "FH" && !$tie_err_to_out; | ||||
454 | $profiler->run_exit( | ||||
455 | $cmd, | ||||
456 | $run_call_time, | ||||
457 | $sys_call_time, | ||||
458 | $sys_exit_time, | ||||
459 | scalar gettimeofday() | ||||
460 | ) if profiling; | ||||
461 | |||||
462 | $! = $errno; # restore $! from system() | ||||
463 | |||||
464 | return 1; | ||||
465 | } | ||||
466 | |||||
467 | 1 | 28µs | 1; | ||
468 | |||||
469 | __END__ |