← Index
NYTProf Performance Profile   « line view »
For webmerge/scripts/webmerge.pl
  Run on Mon Oct 7 02:42:42 2013
Reported on Mon Oct 7 03:03:23 2013

Filename/usr/lib64/perl5/vendor_perl/5.16.0/IPC/Run3.pm
StatementsExecuted 31 statements in 16.3ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11135.6ms67.2msIPC::Run3::::BEGIN@55IPC::Run3::BEGIN@55
11120.2ms53.9msIPC::Run3::::BEGIN@56IPC::Run3::BEGIN@56
11195µs95µsIPC::Run3::::BEGIN@2IPC::Run3::BEGIN@2
11161µs249µsIPC::Run3::::BEGIN@43IPC::Run3::BEGIN@43
11159µs293µsIPC::Run3::::BEGIN@41IPC::Run3::BEGIN@41
11156µs163µsIPC::Run3::::BEGIN@36IPC::Run3::BEGIN@36
11156µs274µsIPC::Run3::::BEGIN@42IPC::Run3::BEGIN@42
11155µs365µsIPC::Run3::::BEGIN@54IPC::Run3::BEGIN@54
11151µs148µsIPC::Run3::::BEGIN@3IPC::Run3::BEGIN@3
11128µs28µsIPC::Run3::::BEGIN@67IPC::Run3::BEGIN@67
11122µs22µsIPC::Run3::::BEGIN@45IPC::Run3::BEGIN@45
11110µs10µsIPC::Run3::::ENDIPC::Run3::END
0000s0sIPC::Run3::::_binmodeIPC::Run3::_binmode
0000s0sIPC::Run3::::_fh_for_child_outputIPC::Run3::_fh_for_child_output
0000s0sIPC::Run3::::_max_fdIPC::Run3::_max_fd
0000s0sIPC::Run3::::_profilerIPC::Run3::_profiler
0000s0sIPC::Run3::::_read_child_output_fhIPC::Run3::_read_child_output_fh
0000s0sIPC::Run3::::_spool_data_to_childIPC::Run3::_spool_data_to_child
0000s0sIPC::Run3::::_typeIPC::Run3::_type
0000s0sIPC::Run3::::run3IPC::Run3::run3
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package IPC::Run3;
21188µs195µ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
BEGIN { require 5.006_000; } # i.e. 5.6.0
# spent 95µs making 1 call to IPC::Run3::BEGIN@2
32271µs2244µ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
use strict;
# 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
7IPC::Run3 - run a subprocess with input/ouput redirection
8
9=head1 VERSION
10
11version 0.045
12
13=cut
14
1514µsour $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
25This module allows you to run a subprocess and redirect stdin, stdout,
26and/or stderr to files and perl data structures. It aims to satisfy 99% of the
27need for using C<system>, C<qx>, and C<open3>
28with a simple, extremely Perlish API.
29
30Speed, simplicity, and portability are paramount. (That's speed of Perl code;
31which is often much slower than the kind of buffered I/O that this module uses
32to spool input to and output from the child command.)
33
34=cut
35
362416µs2270µ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
use Exporter;
# spent 163µs making 1 call to IPC::Run3::BEGIN@36 # spent 107µs making 1 call to Exporter::import
37139µsour @ISA = qw(Exporter);
3816µsour @EXPORT = qw( run3 );
39110µsour %EXPORT_TAGS = ( all => \@EXPORT );
40
412219µs2527µ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
use constant debugging => $ENV{IPCRUN3DEBUG} || $ENV{IPCRUNDEBUG} || 0;
# spent 293µs making 1 call to IPC::Run3::BEGIN@41 # spent 234µs making 1 call to constant::import
422217µs2492µ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
use constant profiling => $ENV{IPCRUN3PROFILE} || $ENV{IPCRUNPROFILE} || 0;
# spent 274µs making 1 call to IPC::Run3::BEGIN@42 # spent 218µs making 1 call to constant::import
432296µs2437µ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
use constant is_win32 => 0 <= index $^O, "Win32";
# 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
BEGIN {
46124µs if ( is_win32 ) {
47 eval "use Win32 qw( GetOSName ); 1" or die $@;
48 }
491118µs122µ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
542160µs2676µ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
use Carp qw( croak );
# spent 365µs making 1 call to IPC::Run3::BEGIN@54 # spent 310µs making 1 call to Exporter::import
5521.07ms267.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
use File::Temp qw( tempfile );
# spent 67.2ms making 1 call to IPC::Run3::BEGIN@55 # spent 515µs making 1 call to Exporter::import
5621.93ms268.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
use POSIX qw( dup dup2 );
# 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
6012µsmy %fh_cache;
6116µsmy $fh_cache_pid = $$;
62
631500nsmy $profiler;
64
65sub _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
BEGIN {
68130µ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 }
88111.2ms128µ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
END {
92124µs $profiler->app_exit( scalar gettimeofday() ) if profiling;
93}
94
95sub _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
110sub _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
182sub _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
219sub _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
285sub _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
297sub _max_fd {
298 my $fd = dup(0);
299 POSIX::close $fd;
300 return $fd;
301}
302
3031500nsmy $run_call_time;
3041600nsmy $sys_call_time;
3051600nsmy $sys_exit_time;
306
307sub 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
467128µs1;
468
469__END__
Report produced by the NYTProf 5.05 Perl profiler, developed by Tim Bunce and Adam Kaplan.