← Index
NYTProf Performance Profile   « line view »
For split.pl
  Run on Thu Apr 20 02:05:47 2023
Reported on Thu Apr 20 18:31:09 2023

Filename/usr/lib/x86_64-linux-gnu/perl-base/IPC/Open3.pm
StatementsExecuted 20 statements in 1.39ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
1119µs11µsIPC::Open3::::BEGIN@3IPC::Open3::BEGIN@3
1116µs20µsIPC::Open3::::BEGIN@295IPC::Open3::BEGIN@295
1116µs26µsIPC::Open3::::BEGIN@74IPC::Open3::BEGIN@74
1115µs28µsIPC::Open3::::BEGIN@73IPC::Open3::BEGIN@73
1114µs18µsIPC::Open3::::BEGIN@9IPC::Open3::BEGIN@9
1114µs9µsIPC::Open3::::BEGIN@4IPC::Open3::BEGIN@4
1114µs8µsIPC::Open3::::BEGIN@6IPC::Open3::BEGIN@6
1113µs19µsIPC::Open3::::BEGIN@8IPC::Open3::BEGIN@8
0000s0sIPC::Open3::::_open3IPC::Open3::_open3
0000s0sIPC::Open3::::open3IPC::Open3::open3
0000s0sIPC::Open3::::spawn_with_handlesIPC::Open3::spawn_with_handles
0000s0sIPC::Open3::::xcloseIPC::Open3::xclose
0000s0sIPC::Open3::::xfilenoIPC::Open3::xfileno
0000s0sIPC::Open3::::xopenIPC::Open3::xopen
0000s0sIPC::Open3::::xpipeIPC::Open3::xpipe
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package IPC::Open3;
2
3224µs213µs
# spent 11µs (9+2) within IPC::Open3::BEGIN@3 which was called: # once (9µs+2µs) by IPC::Cmd::BEGIN@5 at line 3
use strict;
# spent 11µs making 1 call to IPC::Open3::BEGIN@3 # spent 2µs making 1 call to strict::import
4220µs214µs
# spent 9µs (4+5) within IPC::Open3::BEGIN@4 which was called: # once (4µs+5µs) by IPC::Cmd::BEGIN@5 at line 4
no strict 'refs'; # because users pass me bareword filehandles
# spent 9µs making 1 call to IPC::Open3::BEGIN@4 # spent 5µs making 1 call to strict::unimport
5
6212µs211µs
# spent 8µs (4+4) within IPC::Open3::BEGIN@6 which was called: # once (4µs+4µs) by IPC::Cmd::BEGIN@5 at line 6
use Exporter 'import';
# spent 8µs making 1 call to IPC::Open3::BEGIN@6 # spent 4µs making 1 call to Exporter::import
7
8215µs234µs
# spent 19µs (3+15) within IPC::Open3::BEGIN@8 which was called: # once (3µs+15µs) by IPC::Cmd::BEGIN@5 at line 8
use Carp;
# spent 19µs making 1 call to IPC::Open3::BEGIN@8 # spent 15µs making 1 call to Exporter::import
92230µs232µs
# spent 18µs (4+14) within IPC::Open3::BEGIN@9 which was called: # once (4µs+14µs) by IPC::Cmd::BEGIN@5 at line 9
use Symbol qw(gensym qualify);
# spent 18µs making 1 call to IPC::Open3::BEGIN@9 # spent 14µs making 1 call to Exporter::import
10
111400nsour $VERSION = '1.22';
121500nsour @EXPORT = qw(open3);
13
14# &open3: Marc Horowitz <marc@mit.edu>
15# derived mostly from &open2 by tom christiansen, <tchrist@convex.com>
16# fixed for 5.001 by Ulrich Kunitz <kunitz@mai-koeln.com>
17# ported to Win32 by Ron Schmidt, Merrill Lynch almost ended my career
18# fixed for autovivving FHs, tchrist again
19# allow fd numbers to be used, by Frank Tobin
20# allow '-' as command (c.f. open "-|"), by Adam Spiers <perl@adamspiers.org>
21#
22# usage: $pid = open3('wtr', 'rdr', 'err' 'some cmd and args', 'optarg', ...);
23#
24# spawn the given $cmd and connect rdr for
25# reading, wtr for writing, and err for errors.
26# if err is '', or the same as rdr, then stdout and
27# stderr of the child are on the same fh. returns pid
28# of child (or dies on failure).
29
30# if wtr begins with '<&', then wtr will be closed in the parent, and
31# the child will read from it directly. if rdr or err begins with
32# '>&', then the child will send output directly to that fd. In both
33# cases, there will be a dup() instead of a pipe() made.
34
35# WARNING: this is dangerous, as you may block forever
36# unless you are very careful.
37#
38# $wtr is left unbuffered.
39#
40# abort program if
41# rdr or wtr are null
42# a system call fails
43
4410sour $Me = 'open3 (bug)'; # you should never see this, it's always localized
45
46# Fatal.pm needs to be fixed WRT prototypes.
47
48sub xpipe {
49 pipe $_[0], $_[1] or croak "$Me: pipe($_[0], $_[1]) failed: $!";
50}
51
52# I tried using a * prototype character for the filehandle but it still
53# disallows a bareword while compiling under strict subs.
54
55sub xopen {
56 open $_[0], $_[1], @_[2..$#_] and return;
57 local $" = ', ';
58 carp "$Me: open(@_) failed: $!";
59}
60
61sub xclose {
62 $_[0] =~ /\A=?(\d+)\z/
63 ? do { my $fh; open($fh, $_[1] . '&=' . $1) and close($fh); }
64 : close $_[0]
65 or croak "$Me: close($_[0]) failed: $!";
66}
67
68sub xfileno {
69 return $1 if $_[0] =~ /\A=?(\d+)\z/; # deal with fh just being an fd
70 return fileno $_[0];
71}
72
73225µs251µs
# spent 28µs (5+23) within IPC::Open3::BEGIN@73 which was called: # once (5µs+23µs) by IPC::Cmd::BEGIN@5 at line 73
use constant FORCE_DEBUG_SPAWN => 0;
# spent 28µs making 1 call to IPC::Open3::BEGIN@73 # spent 23µs making 1 call to constant::import
742903µs245µs
# spent 26µs (6+19) within IPC::Open3::BEGIN@74 which was called: # once (6µs+19µs) by IPC::Cmd::BEGIN@5 at line 74
use constant DO_SPAWN => $^O eq 'os2' || $^O eq 'MSWin32' || FORCE_DEBUG_SPAWN;
# spent 26µs making 1 call to IPC::Open3::BEGIN@74 # spent 19µs making 1 call to constant::import
75
76sub _open3 {
77 local $Me = shift;
78
79 # simulate autovivification of filehandles because
80 # it's too ugly to use @_ throughout to make perl do it for us
81 # tchrist 5-Mar-00
82
83 # Historically, open3(undef...) has silently worked, so keep
84 # it working.
85 splice @_, 0, 1, undef if \$_[0] == \undef;
86 splice @_, 1, 1, undef if \$_[1] == \undef;
87 unless (eval {
88 $_[0] = gensym unless defined $_[0] && length $_[0];
89 $_[1] = gensym unless defined $_[1] && length $_[1];
90 1; })
91 {
92 # must strip crud for croak to add back, or looks ugly
93 $@ =~ s/(?<=value attempted) at .*//s;
94 croak "$Me: $@";
95 }
96
97 my @handles = ({ mode => '<', handle => \*STDIN },
98 { mode => '>', handle => \*STDOUT },
99 { mode => '>', handle => \*STDERR },
100 );
101
102 foreach (@handles) {
103 $_->{parent} = shift;
104 $_->{open_as} = gensym;
105 }
106
107 if (@_ > 1 and $_[0] eq '-') {
108 croak "Arguments don't make sense when the command is '-'"
109 }
110
111 $handles[2]{parent} ||= $handles[1]{parent};
112 $handles[2]{dup_of_out} = $handles[1]{parent} eq $handles[2]{parent};
113
114 my $package;
115 foreach (@handles) {
116 $_->{dup} = ($_->{parent} =~ s/^[<>]&//);
117
118 if ($_->{parent} !~ /\A=?(\d+)\z/) {
119 # force unqualified filehandles into caller's package
120 $package //= caller 1;
121 $_->{parent} = qualify $_->{parent}, $package;
122 }
123
124 next if $_->{dup} or $_->{dup_of_out};
125 if ($_->{mode} eq '<') {
126 xpipe $_->{open_as}, $_->{parent};
127 } else {
128 xpipe $_->{parent}, $_->{open_as};
129 }
130 }
131
132 my $kidpid;
133 if (!DO_SPAWN) {
134 # Used to communicate exec failures.
135 xpipe my $stat_r, my $stat_w;
136
137 $kidpid = fork;
138 croak "$Me: fork failed: $!" unless defined $kidpid;
139 if ($kidpid == 0) { # Kid
140 eval {
141 # A tie in the parent should not be allowed to cause problems.
142 untie *STDIN;
143 untie *STDOUT;
144 untie *STDERR;
145
146 close $stat_r;
147 require Fcntl;
148 my $flags = fcntl $stat_w, &Fcntl::F_GETFD, 0;
149 croak "$Me: fcntl failed: $!" unless $flags;
150 fcntl $stat_w, &Fcntl::F_SETFD, $flags|&Fcntl::FD_CLOEXEC
151 or croak "$Me: fcntl failed: $!";
152
153 # If she wants to dup the kid's stderr onto her stdout I need to
154 # save a copy of her stdout before I put something else there.
155 if (!$handles[2]{dup_of_out} && $handles[2]{dup}
156 && xfileno($handles[2]{parent}) == fileno \*STDOUT) {
157 my $tmp = gensym;
158 xopen($tmp, '>&', $handles[2]{parent});
159 $handles[2]{parent} = $tmp;
160 }
161
162 foreach (@handles) {
163 if ($_->{dup_of_out}) {
164 xopen \*STDERR, ">&STDOUT"
165 if defined fileno STDERR && fileno STDERR != fileno STDOUT;
166 } elsif ($_->{dup}) {
167 xopen $_->{handle}, $_->{mode} . '&', $_->{parent}
168 if fileno $_->{handle} != xfileno($_->{parent});
169 } else {
170 xclose $_->{parent}, $_->{mode};
171 xopen $_->{handle}, $_->{mode} . '&=',
172 fileno $_->{open_as};
173 }
174 }
175 return 1 if ($_[0] eq '-');
176 exec @_ or do {
177 local($")=(" ");
178 croak "$Me: exec of @_ failed: $!";
179 };
180 } and do {
181 close $stat_w;
182 return 0;
183 };
184
185 my $bang = 0+$!;
186 my $err = $@;
187 utf8::encode $err if $] >= 5.008;
188 print $stat_w pack('IIa*', $bang, length($err), $err);
189 close $stat_w;
190
191 eval { require POSIX; POSIX::_exit(255); };
192 exit 255;
193 }
194 else { # Parent
195 close $stat_w;
19612µs my $to_read = length(pack('I', 0)) * 2;
# spent 2µs making 1 call to main::CORE:pack
197 my $bytes_read = read($stat_r, my $buf = '', $to_read);
198 if ($bytes_read) {
199 (my $bang, $to_read) = unpack('II', $buf);
200 read($stat_r, my $err = '', $to_read);
201 waitpid $kidpid, 0; # Reap child which should have exited
202 if ($err) {
203 utf8::decode $err if $] >= 5.008;
204 } else {
205 $err = "$Me: " . ($! = $bang);
206 }
207 $! = $bang;
208 die($err);
209 }
210 }
211 }
212 else { # DO_SPAWN
213 # All the bookkeeping of coincidence between handles is
214 # handled in spawn_with_handles.
215
216 my @close;
217
218 foreach (@handles) {
219 if ($_->{dup_of_out}) {
220 $_->{open_as} = $handles[1]{open_as};
221 } elsif ($_->{dup}) {
222 $_->{open_as} = $_->{parent} =~ /\A[0-9]+\z/
223 ? $_->{parent} : \*{$_->{parent}};
224 push @close, $_->{open_as};
225 } else {
226 push @close, \*{$_->{parent}}, $_->{open_as};
227 }
228 }
229 require IO::Pipe;
230 $kidpid = eval {
231 spawn_with_handles(\@handles, \@close, @_);
232 };
233 die "$Me: $@" if $@;
234 }
235
236 foreach (@handles) {
237 next if $_->{dup} or $_->{dup_of_out};
238 xclose $_->{open_as}, $_->{mode};
239 }
240
241 # If the write handle is a dup give it away entirely, close my copy
242 # of it.
243 xclose $handles[0]{parent}, $handles[0]{mode} if $handles[0]{dup};
244
245 select((select($handles[0]{parent}), $| = 1)[0]); # unbuffer pipe
246 $kidpid;
247}
248
249sub open3 {
250 if (@_ < 4) {
251 local $" = ', ';
252 croak "open3(@_): not enough arguments";
253 }
254 return _open3 'open3', @_
255}
256
257sub spawn_with_handles {
258 my $fds = shift; # Fields: handle, mode, open_as
259 my $close_in_child = shift;
260 my ($fd, %saved, @errs);
261
262 foreach $fd (@$fds) {
263 $fd->{tmp_copy} = IO::Handle->new_from_fd($fd->{handle}, $fd->{mode});
264 $saved{fileno $fd->{handle}} = $fd->{tmp_copy} if $fd->{tmp_copy};
265 }
266 foreach $fd (@$fds) {
267 bless $fd->{handle}, 'IO::Handle'
268 unless eval { $fd->{handle}->isa('IO::Handle') } ;
269 # If some of handles to redirect-to coincide with handles to
270 # redirect, we need to use saved variants:
271 my $open_as = $fd->{open_as};
272 my $fileno = fileno($open_as);
273 $fd->{handle}->fdopen(defined($fileno)
274 ? $saved{$fileno} || $open_as
275 : $open_as,
276 $fd->{mode});
277 }
278 unless ($^O eq 'MSWin32') {
279 require Fcntl;
280 # Stderr may be redirected below, so we save the err text:
281 foreach $fd (@$close_in_child) {
282 next unless fileno $fd;
283 fcntl($fd, Fcntl::F_SETFD(), 1) or push @errs, "fcntl $fd: $!"
284 unless $saved{fileno $fd}; # Do not close what we redirect!
285 }
286 }
287
288 my $pid;
289 unless (@errs) {
290 if (FORCE_DEBUG_SPAWN) {
291 pipe my $r, my $w or die "Pipe failed: $!";
292 $pid = fork;
293 die "Fork failed: $!" unless defined $pid;
294 if (!$pid) {
2952162µs233µs
# spent 20µs (6+14) within IPC::Open3::BEGIN@295 which was called: # once (6µs+14µs) by IPC::Cmd::BEGIN@5 at line 295
{ no warnings; exec @_ }
# spent 20µs making 1 call to IPC::Open3::BEGIN@295 # spent 14µs making 1 call to warnings::unimport
296 print $w 0 + $!;
297 close $w;
298 require POSIX;
299 POSIX::_exit(255);
300 }
301 close $w;
302 my $bad = <$r>;
303 if (defined $bad) {
304 $! = $bad;
305 undef $pid;
306 }
307 } else {
308 $pid = eval { system 1, @_ }; # 1 == P_NOWAIT
309 }
310 if($@) {
311 push @errs, "IO::Pipe: Can't spawn-NOWAIT: $@";
312 } elsif(!$pid || $pid < 0) {
313 push @errs, "IO::Pipe: Can't spawn-NOWAIT: $!";
314 }
315 }
316
317 # Do this in reverse, so that STDERR is restored first:
318 foreach $fd (reverse @$fds) {
319 $fd->{handle}->fdopen($fd->{tmp_copy}, $fd->{mode});
320 }
321 foreach (values %saved) {
322 $_->close or croak "Can't close: $!";
323 }
324 croak join "\n", @errs if @errs;
325 return $pid;
326}
327
32813µs1; # so require is happy
Report produced by the NYTProf 6.12 Perl profiler, developed by Tim Bunce based on work by Adam Kaplan and Salvador Fandiño García.