← 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/home/hejohns/perl5/lib/perl5/IPC/Run.pm
StatementsExecuted 94039753 statements in 53403s
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
14676862137888s37888sIPC::Run::::CORE:sselectIPC::Run::CORE:sselect (opcode)
13303611104s15370sIPC::Run::::_spawnIPC::Run::_spawn
1330361131.1s38059sIPC::Run::::_select_loopIPC::Run::_select_loop
18681952128.2s51.1sIPC::Run::::reap_nbIPC::Run::reap_nb
5321444218.7s33.2sIPC::Run::::_closeIPC::Run::_close
17323545118.4s200sIPC::Run::::pumpableIPC::Run::pumpable
1330361112.5s15460sIPC::Run::::startIPC::Run::start
1330361112.0s24.9sIPC::Run::::harnessIPC::Run::harness
1330362211.5s53558sIPC::Run::::runIPC::Run::run
1330361110.3s45.7sIPC::Run::::_open_pipesIPC::Run::_open_pipes
133036119.92s15.4sIPC::Run::::_cleanupIPC::Run::_cleanup
133036117.60s15.8sIPC::Run::::_pipe_nbIPC::Run::_pipe_nb
133036116.05s11.2sIPC::Run::::_search_pathIPC::Run::_search_path
266092115.69s31.3sIPC::Run::::__ANON__[:2514]IPC::Run::__ANON__[:2514]
2261613915.50s5.50sIPC::Run::::CORE:matchIPC::Run::CORE:match (opcode)
1735159115.29s5.29sIPC::Run::::CORE:waitpidIPC::Run::CORE:waitpid (opcode)
532164225.11s33.9sIPC::Run::::get_more_inputIPC::Run::get_more_input (recurses: max depth 1, inclusive time 6.56s)
133036114.32s13.4sIPC::Run::::_clobberIPC::Run::_clobber
133036114.24s38084sIPC::Run::::finishIPC::Run::finish
133036113.85s15226sIPC::Run::::_readIPC::Run::_read
133036112.86s2.86sIPC::Run::::DESTROYIPC::Run::DESTROY
1868195212.79s2.79sIPC::Run::::_running_kidsIPC::Run::_running_kids
266072112.16s4.60sIPC::Run::::_dupIPC::Run::_dup
133036111.69s3.51sIPC::Run::::_pipeIPC::Run::_pipe
133056111.30s4.01sIPC::Run::::_writeIPC::Run::_write
532144321.26s1.26sIPC::Run::::_emptyIPC::Run::_empty
133036111.11s1.40sIPC::Run::::full_resultIPC::Run::full_result
13303611793ms1.70sIPC::Run::::_debug_fdIPC::Run::_debug_fd
13303621619ms619msIPC::Run::::CORE:fteexecIPC::Run::CORE:fteexec (opcode)
13303511483ms483msIPC::Run::::CORE:ftisIPC::Run::CORE:ftis (opcode)
13303611424ms424msIPC::Run::::CORE:fcntlIPC::Run::CORE:fcntl (opcode)
13303611291ms291msIPC::Run::::_assert_finishedIPC::Run::_assert_finished
13304221238ms238msIPC::Run::::CORE:ftfileIPC::Run::CORE:ftfile (opcode)
53214421205ms205msIPC::Run::::CORE:selectIPC::Run::CORE:select (opcode)
13303941125ms125msIPC::Run::::CORE:regcompIPC::Run::CORE:regcomp (opcode)
1330361184.2ms84.2msIPC::Run::::F_SETFLIPC::Run::F_SETFL (xsub)
1330361143.7ms43.7msIPC::Run::::CORE:sortIPC::Run::CORE:sort (opcode)
111845µs967µsIPC::Run::::BEGIN@1052IPC::Run::BEGIN@1052
111184µs215µsIPC::Run::::BEGIN@2IPC::Run::BEGIN@2
11131µs52µsIPC::Run::::BEGIN@1068IPC::Run::BEGIN@1068
11113µs13µsIPC::Run::::BEGIN@1018IPC::Run::BEGIN@1018
11112µs28µsIPC::Run::::BEGIN@1089IPC::Run::BEGIN@1089
3319µs9µsIPC::Run::::CORE:qrIPC::Run::CORE:qr (opcode)
1119µs40µsIPC::Run::::BEGIN@3688IPC::Run::BEGIN@3688
1118µs33µsIPC::Run::::BEGIN@1066IPC::Run::BEGIN@1066
1116µs20µsIPC::Run::::BEGIN@1515IPC::Run::BEGIN@1515
1116µs116µsIPC::Run::::BEGIN@1054IPC::Run::BEGIN@1054
1116µs43µsIPC::Run::::BEGIN@1016IPC::Run::BEGIN@1016
1115µs10µsIPC::Run::::BEGIN@1062IPC::Run::BEGIN@1062
1115µs6µsIPC::Run::::BEGIN@1013IPC::Run::BEGIN@1013
1114µs9µsIPC::Run::::BEGIN@1053IPC::Run::BEGIN@1053
1114µs119µsIPC::Run::::BEGIN@1087IPC::Run::BEGIN@1087
1114µs13µsIPC::Run::::BEGIN@1123IPC::Run::BEGIN@1123
1113µs17µsIPC::Run::::BEGIN@1051IPC::Run::BEGIN@1051
1113µs16µsIPC::Run::::BEGIN@1086IPC::Run::BEGIN@1086
1113µs19µsIPC::Run::::BEGIN@1014IPC::Run::BEGIN@1014
1113µs18µsIPC::Run::::BEGIN@1060IPC::Run::BEGIN@1060
1113µs4µsIPC::Run::::BEGIN@1050IPC::Run::BEGIN@1050
1112µs2µsIPC::Run::::BEGIN@1015IPC::Run::BEGIN@1015
1112µs2µsIPC::Run::::BEGIN@1055IPC::Run::BEGIN@1055
1112µs2µsIPC::Run::::BEGIN@1061IPC::Run::BEGIN@1061
1112µs2µsIPC::Run::::BEGIN@1057IPC::Run::BEGIN@1057
0000s0sIPC::Run::::__ANON__[:2469]IPC::Run::__ANON__[:2469]
0000s0sIPC::Run::::__ANON__[:3728]IPC::Run::__ANON__[:3728]
0000s0sIPC::Run::::__ANON__[:3801]IPC::Run::__ANON__[:3801]
0000s0sIPC::Run::::__ANON__[:3842]IPC::Run::__ANON__[:3842]
0000s0sIPC::Run::::__ANON__[:3876]IPC::Run::__ANON__[:3876]
0000s0sIPC::Run::::__ANON__[:3887]IPC::Run::__ANON__[:3887]
0000s0sIPC::Run::::__ANON__[:3909]IPC::Run::__ANON__[:3909]
0000s0sIPC::Run::::_child_resultIPC::Run::_child_result
0000s0sIPC::Run::::_debugstringsIPC::Run::_debugstrings
0000s0sIPC::Run::::_do_kid_and_exitIPC::Run::_do_kid_and_exit
0000s0sIPC::Run::::_dup2_gentlyIPC::Run::_dup2_gently
0000s0sIPC::Run::::_dup2_rudelyIPC::Run::_dup2_rudely
0000s0sIPC::Run::::_execIPC::Run::_exec
0000s0sIPC::Run::::_ptyIPC::Run::_pty
0000s0sIPC::Run::::_sysopenIPC::Run::_sysopen
0000s0sIPC::Run::::adoptIPC::Run::adopt
0000s0sIPC::Run::::binaryIPC::Run::binary
0000s0sIPC::Run::::close_terminalIPC::Run::close_terminal
0000s0sIPC::Run::::full_resultsIPC::Run::full_results
0000s0sIPC::Run::::input_availIPC::Run::input_avail
0000s0sIPC::Run::::ioIPC::Run::io
0000s0sIPC::Run::::kill_killIPC::Run::kill_kill
0000s0sIPC::Run::::new_appenderIPC::Run::new_appender
0000s0sIPC::Run::::new_chunkerIPC::Run::new_chunker
0000s0sIPC::Run::::new_string_sinkIPC::Run::new_string_sink
0000s0sIPC::Run::::new_string_sourceIPC::Run::new_string_source
0000s0sIPC::Run::::pumpIPC::Run::pump
0000s0sIPC::Run::::pump_nbIPC::Run::pump_nb
0000s0sIPC::Run::::resultIPC::Run::result
0000s0sIPC::Run::::resultsIPC::Run::results
0000s0sIPC::Run::::signalIPC::Run::signal
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package IPC::Run;
22386µs2217µs
# spent 215µs (184+32) within IPC::Run::BEGIN@2 which was called: # once (184µs+32µs) by main::BEGIN@29 at line 2
use bytes;
# spent 215µs making 1 call to IPC::Run::BEGIN@2 # spent 1µs making 1 call to bytes::import
3
4=pod
5
6=head1 NAME
7
8IPC::Run - system() and background procs w/ piping, redirs, ptys (Unix, Win32)
9
10=head1 SYNOPSIS
11
12 ## First,a command to run:
13 my @cat = qw( cat );
14
15 ## Using run() instead of system():
16 use IPC::Run qw( run timeout );
17
18 run \@cat, \$in, \$out, \$err, timeout( 10 ) or die "cat: $?";
19
20 # Can do I/O to sub refs and filenames, too:
21 run \@cat, '<', "in.txt", \&out, \&err or die "cat: $?";
22 run \@cat, '<', "in.txt", '>>', "out.txt", '2>>', "err.txt";
23
24
25 # Redirecting using pseudo-terminals instead of pipes.
26 run \@cat, '<pty<', \$in, '>pty>', \$out_and_err;
27
28 ## Scripting subprocesses (like Expect):
29
30 use IPC::Run qw( start pump finish timeout );
31
32 # Incrementally read from / write to scalars.
33 # $in is drained as it is fed to cat's stdin,
34 # $out accumulates cat's stdout
35 # $err accumulates cat's stderr
36 # $h is for "harness".
37 my $h = start \@cat, \$in, \$out, \$err, timeout( 10 );
38
39 $in .= "some input\n";
40 pump $h until $out =~ /input\n/g;
41
42 $in .= "some more input\n";
43 pump $h until $out =~ /\G.*more input\n/;
44
45 $in .= "some final input\n";
46 finish $h or die "cat returned $?";
47
48 warn $err if $err;
49 print $out; ## All of cat's output
50
51 # Piping between children
52 run \@cat, '|', \@gzip;
53
54 # Multiple children simultaneously (run() blocks until all
55 # children exit, use start() for background execution):
56 run \@foo1, '&', \@foo2;
57
58 # Calling \&set_up_child in the child before it executes the
59 # command (only works on systems with true fork() & exec())
60 # exceptions thrown in set_up_child() will be propagated back
61 # to the parent and thrown from run().
62 run \@cat, \$in, \$out,
63 init => \&set_up_child;
64
65 # Read from / write to file handles you open and close
66 open IN, '<in.txt' or die $!;
67 open OUT, '>out.txt' or die $!;
68 print OUT "preamble\n";
69 run \@cat, \*IN, \*OUT or die "cat returned $?";
70 print OUT "postamble\n";
71 close IN;
72 close OUT;
73
74 # Create pipes for you to read / write (like IPC::Open2 & 3).
75 $h = start
76 \@cat,
77 '<pipe', \*IN, # may also be a lexical filehandle e.g. \my $infh
78 '>pipe', \*OUT,
79 '2>pipe', \*ERR
80 or die "cat returned $?";
81 print IN "some input\n";
82 close IN;
83 print <OUT>, <ERR>;
84 finish $h;
85
86 # Mixing input and output modes
87 run \@cat, 'in.txt', \&catch_some_out, \*ERR_LOG;
88
89 # Other redirection constructs
90 run \@cat, '>&', \$out_and_err;
91 run \@cat, '2>&1';
92 run \@cat, '0<&3';
93 run \@cat, '<&-';
94 run \@cat, '3<', \$in3;
95 run \@cat, '4>', \$out4;
96 # etc.
97
98 # Passing options:
99 run \@cat, 'in.txt', debug => 1;
100
101 # Call this system's shell, returns TRUE on 0 exit code
102 # THIS IS THE OPPOSITE SENSE OF system()'s RETURN VALUE
103 run "cat a b c" or die "cat returned $?";
104
105 # Launch a sub process directly, no shell. Can't do redirection
106 # with this form, it's here to behave like system() with an
107 # inverted result.
108 $r = run "cat a b c";
109
110 # Read from a file in to a scalar
111 run io( "filename", 'r', \$recv );
112 run io( \*HANDLE, 'r', \$recv );
113
114=head1 DESCRIPTION
115
116IPC::Run allows you to run and interact with child processes using files, pipes,
117and pseudo-ttys. Both system()-style and scripted usages are supported and
118may be mixed. Likewise, functional and OO API styles are both supported and
119may be mixed.
120
121Various redirection operators reminiscent of those seen on common Unix and DOS
122command lines are provided.
123
124Before digging in to the details a few LIMITATIONS are important enough
125to be mentioned right up front:
126
127=over
128
129=item Win32 Support
130
131Win32 support is working but B<EXPERIMENTAL>, but does pass all relevant tests
132on NT 4.0. See L</Win32 LIMITATIONS>.
133
134=item pty Support
135
136If you need pty support, IPC::Run should work well enough most of the
137time, but IO::Pty is being improved, and IPC::Run will be improved to
138use IO::Pty's new features when it is released.
139
140The basic problem is that the pty needs to initialize itself before the
141parent writes to the master pty, or the data written gets lost. So
142IPC::Run does a sleep(1) in the parent after forking to (hopefully) give
143the child a chance to run. This is a kludge that works well on non
144heavily loaded systems :(.
145
146ptys are not supported yet under Win32, but will be emulated...
147
148=item Debugging Tip
149
150You may use the environment variable C<IPCRUNDEBUG> to see what's going on
151under the hood:
152
153 $ IPCRUNDEBUG=basic myscript # prints minimal debugging
154 $ IPCRUNDEBUG=data myscript # prints all data reads/writes
155 $ IPCRUNDEBUG=details myscript # prints lots of low-level details
156 $ IPCRUNDEBUG=gory myscript # (Win32 only) prints data moving through
157 # the helper processes.
158
159=back
160
161We now return you to your regularly scheduled documentation.
162
163=head2 Harnesses
164
165Child processes and I/O handles are gathered in to a harness, then
166started and run until the processing is finished or aborted.
167
168=head2 run() vs. start(); pump(); finish();
169
170There are two modes you can run harnesses in: run() functions as an
171enhanced system(), and start()/pump()/finish() allow for background
172processes and scripted interactions with them.
173
174When using run(), all data to be sent to the harness is set up in
175advance (though one can feed subprocesses input from subroutine refs to
176get around this limitation). The harness is run and all output is
177collected from it, then any child processes are waited for:
178
179 run \@cmd, \<<IN, \$out;
180 blah
181 IN
182
183 ## To precompile harnesses and run them later:
184 my $h = harness \@cmd, \<<IN, \$out;
185 blah
186 IN
187
188 run $h;
189
190The background and scripting API is provided by start(), pump(), and
191finish(): start() creates a harness if need be (by calling harness())
192and launches any subprocesses, pump() allows you to poll them for
193activity, and finish() then monitors the harnessed activities until they
194complete.
195
196 ## Build the harness, open all pipes, and launch the subprocesses
197 my $h = start \@cat, \$in, \$out;
198 $in = "first input\n";
199
200 ## Now do I/O. start() does no I/O.
201 pump $h while length $in; ## Wait for all input to go
202
203 ## Now do some more I/O.
204 $in = "second input\n";
205 pump $h until $out =~ /second input/;
206
207 ## Clean up
208 finish $h or die "cat returned $?";
209
210You can optionally compile the harness with harness() prior to
211start()ing or run()ing, and you may omit start() between harness() and
212pump(). You might want to do these things if you compile your harnesses
213ahead of time.
214
215=head2 Using regexps to match output
216
217As shown in most of the scripting examples, the read-to-scalar facility
218for gathering subcommand's output is often used with regular expressions
219to detect stopping points. This is because subcommand output often
220arrives in dribbles and drabs, often only a character or line at a time.
221This output is input for the main program and piles up in variables like
222the C<$out> and C<$err> in our examples.
223
224Regular expressions can be used to wait for appropriate output in
225several ways. The C<cat> example in the previous section demonstrates
226how to pump() until some string appears in the output. Here's an
227example that uses C<smb> to fetch files from a remote server:
228
229 $h = harness \@smbclient, \$in, \$out;
230
231 $in = "cd /src\n";
232 $h->pump until $out =~ /^smb.*> \Z/m;
233 die "error cding to /src:\n$out" if $out =~ "ERR";
234 $out = '';
235
236 $in = "mget *\n";
237 $h->pump until $out =~ /^smb.*> \Z/m;
238 die "error retrieving files:\n$out" if $out =~ "ERR";
239
240 $in = "quit\n";
241 $h->finish;
242
243Notice that we carefully clear $out after the first command/response
244cycle? That's because IPC::Run does not delete $out when we continue,
245and we don't want to trip over the old output in the second
246command/response cycle.
247
248Say you want to accumulate all the output in $out and analyze it
249afterwards. Perl offers incremental regular expression matching using
250the C<m//gc> and pattern matching idiom and the C<\G> assertion.
251IPC::Run is careful not to disturb the current C<pos()> value for
252scalars it appends data to, so we could modify the above so as not to
253destroy $out by adding a couple of C</gc> modifiers. The C</g> keeps us
254from tripping over the previous prompt and the C</c> keeps us from
255resetting the prior match position if the expected prompt doesn't
256materialize immediately:
257
258 $h = harness \@smbclient, \$in, \$out;
259
260 $in = "cd /src\n";
261 $h->pump until $out =~ /^smb.*> \Z/mgc;
262 die "error cding to /src:\n$out" if $out =~ "ERR";
263
264 $in = "mget *\n";
265 $h->pump until $out =~ /^smb.*> \Z/mgc;
266 die "error retrieving files:\n$out" if $out =~ "ERR";
267
268 $in = "quit\n";
269 $h->finish;
270
271 analyze( $out );
272
273When using this technique, you may want to preallocate $out to have
274plenty of memory or you may find that the act of growing $out each time
275new input arrives causes an C<O(length($out)^2)> slowdown as $out grows.
276Say we expect no more than 10,000 characters of input at the most. To
277preallocate memory to $out, do something like:
278
279 my $out = "x" x 10_000;
280 $out = "";
281
282C<perl> will allocate at least 10,000 characters' worth of space, then
283mark the $out as having 0 length without freeing all that yummy RAM.
284
285=head2 Timeouts and Timers
286
287More than likely, you don't want your subprocesses to run forever, and
288sometimes it's nice to know that they're going a little slowly.
289Timeouts throw exceptions after a some time has elapsed, timers merely
290cause pump() to return after some time has elapsed. Neither is
291reset/restarted automatically.
292
293Timeout objects are created by calling timeout( $interval ) and passing
294the result to run(), start() or harness(). The timeout period starts
295ticking just after all the child processes have been fork()ed or
296spawn()ed, and are polled for expiration in run(), pump() and finish().
297If/when they expire, an exception is thrown. This is typically useful
298to keep a subprocess from taking too long.
299
300If a timeout occurs in run(), all child processes will be terminated and
301all file/pipe/ptty descriptors opened by run() will be closed. File
302descriptors opened by the parent process and passed in to run() are not
303closed in this event.
304
305If a timeout occurs in pump(), pump_nb(), or finish(), it's up to you to
306decide whether to kill_kill() all the children or to implement some more
307graceful fallback. No I/O will be closed in pump(), pump_nb() or
308finish() by such an exception (though I/O is often closed down in those
309routines during the natural course of events).
310
311Often an exception is too harsh. timer( $interval ) creates timer
312objects that merely prevent pump() from blocking forever. This can be
313useful for detecting stalled I/O or printing a soothing message or "."
314to pacify an anxious user.
315
316Timeouts and timers can both be restarted at any time using the timer's
317start() method (this is not the start() that launches subprocesses). To
318restart a timer, you need to keep a reference to the timer:
319
320 ## Start with a nice long timeout to let smbclient connect. If
321 ## pump or finish take too long, an exception will be thrown.
322
323 my $h;
324 eval {
325 $h = harness \@smbclient, \$in, \$out, \$err, ( my $t = timeout 30 );
326 sleep 11; # No effect: timer not running yet
327
328 start $h;
329 $in = "cd /src\n";
330 pump $h until ! length $in;
331
332 $in = "ls\n";
333 ## Now use a short timeout, since this should be faster
334 $t->start( 5 );
335 pump $h until ! length $in;
336
337 $t->start( 10 ); ## Give smbclient a little while to shut down.
338 $h->finish;
339 };
340 if ( $@ ) {
341 my $x = $@; ## Preserve $@ in case another exception occurs
342 $h->kill_kill; ## kill it gently, then brutally if need be, or just
343 ## brutally on Win32.
344 die $x;
345 }
346
347Timeouts and timers are I<not> checked once the subprocesses are shut
348down; they will not expire in the interval between the last valid
349process and when IPC::Run scoops up the processes' result codes, for
350instance.
351
352=head2 Spawning synchronization, child exception propagation
353
354start() pauses the parent until the child executes the command or CODE
355reference and propagates any exceptions thrown (including exec()
356failure) back to the parent. This has several pleasant effects: any
357exceptions thrown in the child, including exec() failure, come flying
358out of start() or run() as though they had occurred in the parent.
359
360This includes exceptions your code thrown from init subs. In this
361example:
362
363 eval {
364 run \@cmd, init => sub { die "blast it! foiled again!" };
365 };
366 print $@;
367
368the exception "blast it! foiled again" will be thrown from the child
369process (preventing the exec()) and printed by the parent.
370
371In situations like
372
373 run \@cmd1, "|", \@cmd2, "|", \@cmd3;
374
375@cmd1 will be initted and exec()ed before @cmd2, and @cmd2 before @cmd3.
376This can save time and prevent oddball errors emitted by later commands
377when earlier commands fail to execute. Note that IPC::Run doesn't start
378any commands unless it can find the executables referenced by all
379commands. These executables must pass both the C<-f> and C<-x> tests
380described in L<perlfunc>.
381
382Another nice effect is that init() subs can take their time doing things
383and there will be no problems caused by a parent continuing to execute
384before a child's init() routine is complete. Say the init() routine
385needs to open a socket or a temp file that the parent wants to connect
386to; without this synchronization, the parent will need to implement a
387retry loop to wait for the child to run, since often, the parent gets a
388lot of things done before the child's first timeslice is allocated.
389
390This is also quite necessary for pseudo-tty initialization, which needs
391to take place before the parent writes to the child via pty. Writes
392that occur before the pty is set up can get lost.
393
394A final, minor, nicety is that debugging output from the child will be
395emitted before the parent continues on, making for much clearer debugging
396output in complex situations.
397
398The only drawback I can conceive of is that the parent can't continue to
399operate while the child is being initted. If this ever becomes a
400problem in the field, we can implement an option to avoid this behavior,
401but I don't expect it to.
402
403B<Win32>: executing CODE references isn't supported on Win32, see
404L</Win32 LIMITATIONS> for details.
405
406=head2 Syntax
407
408run(), start(), and harness() can all take a harness specification
409as input. A harness specification is either a single string to be passed
410to the systems' shell:
411
412 run "echo 'hi there'";
413
414or a list of commands, io operations, and/or timers/timeouts to execute.
415Consecutive commands must be separated by a pipe operator '|' or an '&'.
416External commands are passed in as array references or L<IPC::Run::Win32Process>
417objects. On systems supporting fork(), Perl code may be passed in as subs:
418
419 run \@cmd;
420 run \@cmd1, '|', \@cmd2;
421 run \@cmd1, '&', \@cmd2;
422 run \&sub1;
423 run \&sub1, '|', \&sub2;
424 run \&sub1, '&', \&sub2;
425
426'|' pipes the stdout of \@cmd1 the stdin of \@cmd2, just like a
427shell pipe. '&' does not. Child processes to the right of a '&'
428will have their stdin closed unless it's redirected-to.
429
430L<IPC::Run::IO> objects may be passed in as well, whether or not
431child processes are also specified:
432
433 run io( "infile", ">", \$in ), io( "outfile", "<", \$in );
434
435as can L<IPC::Run::Timer> objects:
436
437 run \@cmd, io( "outfile", "<", \$in ), timeout( 10 );
438
439Commands may be followed by scalar, sub, or i/o handle references for
440redirecting
441child process input & output:
442
443 run \@cmd, \undef, \$out;
444 run \@cmd, \$in, \$out;
445 run \@cmd1, \&in, '|', \@cmd2, \*OUT;
446 run \@cmd1, \*IN, '|', \@cmd2, \&out;
447
448This is known as succinct redirection syntax, since run(), start()
449and harness(), figure out which file descriptor to redirect and how.
450File descriptor 0 is presumed to be an input for
451the child process, all others are outputs. The assumed file
452descriptor always starts at 0, unless the command is being piped to,
453in which case it starts at 1.
454
455To be explicit about your redirects, or if you need to do more complex
456things, there's also a redirection operator syntax:
457
458 run \@cmd, '<', \undef, '>', \$out;
459 run \@cmd, '<', \undef, '>&', \$out_and_err;
460 run(
461 \@cmd1,
462 '<', \$in,
463 '|', \@cmd2,
464 \$out
465 );
466
467Operator syntax is required if you need to do something other than simple
468redirection to/from scalars or subs, like duping or closing file descriptors
469or redirecting to/from a named file. The operators are covered in detail
470below.
471
472After each \@cmd (or \&foo), parsing begins in succinct mode and toggles to
473operator syntax mode when an operator (ie plain scalar, not a ref) is seen.
474Once in
475operator syntax mode, parsing only reverts to succinct mode when a '|' or
476'&' is seen.
477
478In succinct mode, each parameter after the \@cmd specifies what to
479do with the next highest file descriptor. These File descriptor start
480with 0 (stdin) unless stdin is being piped to (C<'|', \@cmd>), in which
481case they start with 1 (stdout). Currently, being on the left of
482a pipe (C<\@cmd, \$out, \$err, '|'>) does I<not> cause stdout to be
483skipped, though this may change since it's not as DWIMerly as it
484could be. Only stdin is assumed to be an
485input in succinct mode, all others are assumed to be outputs.
486
487If no piping or redirection is specified for a child, it will inherit
488the parent's open file handles as dictated by your system's
489close-on-exec behavior and the $^F flag, except that processes after a
490'&' will not inherit the parent's stdin. Also note that $^F does not
491affect file descriptors obtained via POSIX, since it only applies to
492full-fledged Perl file handles. Such processes will have their stdin
493closed unless it has been redirected-to.
494
495If you want to close a child processes stdin, you may do any of:
496
497 run \@cmd, \undef;
498 run \@cmd, \"";
499 run \@cmd, '<&-';
500 run \@cmd, '0<&-';
501
502Redirection is done by placing redirection specifications immediately
503after a command or child subroutine:
504
505 run \@cmd1, \$in, '|', \@cmd2, \$out;
506 run \@cmd1, '<', \$in, '|', \@cmd2, '>', \$out;
507
508If you omit the redirection operators, descriptors are counted
509starting at 0. Descriptor 0 is assumed to be input, all others
510are outputs. A leading '|' consumes descriptor 0, so this
511works as expected.
512
513 run \@cmd1, \$in, '|', \@cmd2, \$out;
514
515The parameter following a redirection operator can be a scalar ref,
516a subroutine ref, a file name, an open filehandle, or a closed
517filehandle.
518
519If it's a scalar ref, the child reads input from or sends output to
520that variable:
521
522 $in = "Hello World.\n";
523 run \@cat, \$in, \$out;
524 print $out;
525
526Scalars used in incremental (start()/pump()/finish()) applications are treated
527as queues: input is removed from input scalers, resulting in them dwindling
528to '', and output is appended to output scalars. This is not true of
529harnesses run() in batch mode.
530
531It's usually wise to append new input to be sent to the child to the input
532queue, and you'll often want to zap output queues to '' before pumping.
533
534 $h = start \@cat, \$in;
535 $in = "line 1\n";
536 pump $h;
537 $in .= "line 2\n";
538 pump $h;
539 $in .= "line 3\n";
540 finish $h;
541
542The final call to finish() must be there: it allows the child process(es)
543to run to completion and waits for their exit values.
544
545=head1 OBSTINATE CHILDREN
546
547Interactive applications are usually optimized for human use. This
548can help or hinder trying to interact with them through modules like
549IPC::Run. Frequently, programs alter their behavior when they detect
550that stdin, stdout, or stderr are not connected to a tty, assuming that
551they are being run in batch mode. Whether this helps or hurts depends
552on which optimizations change. And there's often no way of telling
553what a program does in these areas other than trial and error and
554occasionally, reading the source. This includes different versions
555and implementations of the same program.
556
557All hope is not lost, however. Most programs behave in reasonably
558tractable manners, once you figure out what it's trying to do.
559
560Here are some of the issues you might need to be aware of.
561
562=over
563
564=item *
565
566fflush()ing stdout and stderr
567
568This lets the user see stdout and stderr immediately. Many programs
569undo this optimization if stdout is not a tty, making them harder to
570manage by things like IPC::Run.
571
572Many programs decline to fflush stdout or stderr if they do not
573detect a tty there. Some ftp commands do this, for instance.
574
575If this happens to you, look for a way to force interactive behavior,
576like a command line switch or command. If you can't, you will
577need to use a pseudo terminal ('<pty<' and '>pty>').
578
579=item *
580
581false prompts
582
583Interactive programs generally do not guarantee that output from user
584commands won't contain a prompt string. For example, your shell prompt
585might be a '$', and a file named '$' might be the only file in a directory
586listing.
587
588This can make it hard to guarantee that your output parser won't be fooled
589into early termination of results.
590
591To help work around this, you can see if the program can alter it's
592prompt, and use something you feel is never going to occur in actual
593practice.
594
595You should also look for your prompt to be the only thing on a line:
596
597 pump $h until $out =~ /^<SILLYPROMPT>\s?\z/m;
598
599(use C<(?!\n)\Z> in place of C<\z> on older perls).
600
601You can also take the approach that IPC::ChildSafe takes and emit a
602command with known output after each 'real' command you issue, then
603look for this known output. See new_appender() and new_chunker() for
604filters that can help with this task.
605
606If it's not convenient or possibly to alter a prompt or use a known
607command/response pair, you might need to autodetect the prompt in case
608the local version of the child program is different then the one
609you tested with, or if the user has control over the look & feel of
610the prompt.
611
612=item *
613
614Refusing to accept input unless stdin is a tty.
615
616Some programs, for security reasons, will only accept certain types
617of input from a tty. su, notable, will not prompt for a password unless
618it's connected to a tty.
619
620If this is your situation, use a pseudo terminal ('<pty<' and '>pty>').
621
622=item *
623
624Not prompting unless connected to a tty.
625
626Some programs don't prompt unless stdin or stdout is a tty. See if you can
627turn prompting back on. If not, see if you can come up with a command that
628you can issue after every real command and look for it's output, as
629IPC::ChildSafe does. There are two filters included with IPC::Run that
630can help with doing this: appender and chunker (see new_appender() and
631new_chunker()).
632
633=item *
634
635Different output format when not connected to a tty.
636
637Some commands alter their formats to ease machine parsability when they
638aren't connected to a pipe. This is actually good, but can be surprising.
639
640=back
641
642=head1 PSEUDO TERMINALS
643
644On systems providing pseudo terminals under /dev, IPC::Run can use IO::Pty
645(available on CPAN) to provide a terminal environment to subprocesses.
646This is necessary when the subprocess really wants to think it's connected
647to a real terminal.
648
649=head2 CAVEATS
650
651Pseudo-terminals are not pipes, though they are similar. Here are some
652differences to watch out for.
653
654=over
655
656=item Echoing
657
658Sending to stdin will cause an echo on stdout, which occurs before each
659line is passed to the child program. There is currently no way to
660disable this, although the child process can and should disable it for
661things like passwords.
662
663=item Shutdown
664
665IPC::Run cannot close a pty until all output has been collected. This
666means that it is not possible to send an EOF to stdin by half-closing
667the pty, as we can when using a pipe to stdin.
668
669This means that you need to send the child process an exit command or
670signal, or run() / finish() will time out. Be careful not to expect a
671prompt after sending the exit command.
672
673=item Command line editing
674
675Some subprocesses, notable shells that depend on the user's prompt
676settings, will reissue the prompt plus the command line input so far
677once for each character.
678
679=item '>pty>' means '&>pty>', not '1>pty>'
680
681The pseudo terminal redirects both stdout and stderr unless you specify
682a file descriptor. If you want to grab stderr separately, do this:
683
684 start \@cmd, '<pty<', \$in, '>pty>', \$out, '2>', \$err;
685
686=item stdin, stdout, and stderr not inherited
687
688Child processes harnessed to a pseudo terminal have their stdin, stdout,
689and stderr completely closed before any redirection operators take
690effect. This casts of the bonds of the controlling terminal. This is
691not done when using pipes.
692
693Right now, this affects all children in a harness that has a pty in use,
694even if that pty would not affect a particular child. That's a bug and
695will be fixed. Until it is, it's best not to mix-and-match children.
696
697=back
698
699=head2 Redirection Operators
700
701 Operator SHNP Description
702 ======== ==== ===========
703 <, N< SHN Redirects input to a child's fd N (0 assumed)
704
705 >, N> SHN Redirects output from a child's fd N (1 assumed)
706 >>, N>> SHN Like '>', but appends to scalars or named files
707 >&, &> SHN Redirects stdout & stderr from a child process
708
709 <pty, N<pty S Like '<', but uses a pseudo-tty instead of a pipe
710 >pty, N>pty S Like '>', but uses a pseudo-tty instead of a pipe
711
712 N<&M Dups input fd N to input fd M
713 M>&N Dups output fd N to input fd M
714 N<&- Closes fd N
715
716 <pipe, N<pipe P Pipe opens H for caller to read, write, close.
717 >pipe, N>pipe P Pipe opens H for caller to read, write, close.
718
719'N' and 'M' are placeholders for integer file descriptor numbers. The
720terms 'input' and 'output' are from the child process's perspective.
721
722The SHNP field indicates what parameters an operator can take:
723
724 S: \$scalar or \&function references. Filters may be used with
725 these operators (and only these).
726 H: \*HANDLE or IO::Handle for caller to open, and close
727 N: "file name".
728 P: \*HANDLE or lexical filehandle opened by IPC::Run as the parent end of a pipe, but read
729 and written to and closed by the caller (like IPC::Open3).
730
731=over
732
733=item Redirecting input: [n]<, [n]<pipe
734
735You can input the child reads on file descriptor number n to come from a
736scalar variable, subroutine, file handle, or a named file. If stdin
737is not redirected, the parent's stdin is inherited.
738
739 run \@cat, \undef ## Closes child's stdin immediately
740 or die "cat returned $?";
741
742 run \@cat, \$in;
743
744 run \@cat, \<<TOHERE;
745 blah
746 TOHERE
747
748 run \@cat, \&input; ## Calls &input, feeding data returned
749 ## to child's. Closes child's stdin
750 ## when undef is returned.
751
752Redirecting from named files requires you to use the input
753redirection operator:
754
755 run \@cat, '<.profile';
756 run \@cat, '<', '.profile';
757
758 open IN, "<foo";
759 run \@cat, \*IN;
760 run \@cat, *IN{IO};
761
762The form used second example here is the safest,
763since filenames like "0" and "&more\n" won't confuse &run:
764
765You can't do either of
766
767 run \@a, *IN; ## INVALID
768 run \@a, '<', *IN; ## BUGGY: Reads file named like "*main::A"
769
770because perl passes a scalar containing a string that
771looks like "*main::A" to &run, and &run can't tell the difference
772between that and a redirection operator or a file name. &run guarantees
773that any scalar you pass after a redirection operator is a file name.
774
775If your child process will take input from file descriptors other
776than 0 (stdin), you can use a redirection operator with any of the
777valid input forms (scalar ref, sub ref, etc.):
778
779 run \@cat, '3<', \$in3;
780
781When redirecting input from a scalar ref, the scalar ref is
782used as a queue. This allows you to use &harness and pump() to
783feed incremental bits of input to a coprocess. See L</Coprocesses>
784below for more information.
785
786The <pipe operator opens the write half of a pipe on the filehandle
787glob reference it takes as an argument:
788
789 $h = start \@cat, '<pipe', \*IN;
790 print IN "hello world\n";
791 pump $h;
792 close IN;
793 finish $h;
794
795Unlike the other '<' operators, IPC::Run does nothing further with
796it: you are responsible for it. The previous example is functionally
797equivalent to:
798
799 pipe( \*R, \*IN ) or die $!;
800 $h = start \@cat, '<', \*IN;
801 print IN "hello world\n";
802 pump $h;
803 close IN;
804 finish $h;
805
806This is like the behavior of IPC::Open2 and IPC::Open3.
807
808B<Win32>: The handle returned is actually a socket handle, so you can
809use select() on it.
810
811=item Redirecting output: [n]>, [n]>>, [n]>&[m], [n]>pipe
812
813You can redirect any output the child emits
814to a scalar variable, subroutine, file handle, or file name. You
815can have &run truncate or append to named files or scalars. If
816you are redirecting stdin as well, or if the command is on the
817receiving end of a pipeline ('|'), you can omit the redirection
818operator:
819
820 @ls = ( 'ls' );
821 run \@ls, \undef, \$out
822 or die "ls returned $?";
823
824 run \@ls, \undef, \&out; ## Calls &out each time some output
825 ## is received from the child's
826 ## when undef is returned.
827
828 run \@ls, \undef, '2>ls.err';
829 run \@ls, '2>', 'ls.err';
830
831The two parameter form guarantees that the filename
832will not be interpreted as a redirection operator:
833
834 run \@ls, '>', "&more";
835 run \@ls, '2>', ">foo\n";
836
837You can pass file handles you've opened for writing:
838
839 open( *OUT, ">out.txt" );
840 open( *ERR, ">err.txt" );
841 run \@cat, \*OUT, \*ERR;
842
843Passing a scalar reference and a code reference requires a little
844more work, but allows you to capture all of the output in a scalar
845or each piece of output by a callback:
846
847These two do the same things:
848
849 run( [ 'ls' ], '2>', sub { $err_out .= $_[0] } );
850
851does the same basic thing as:
852
853 run( [ 'ls' ], '2>', \$err_out );
854
855The subroutine will be called each time some data is read from the child.
856
857The >pipe operator is different in concept than the other '>' operators,
858although it's syntax is similar:
859
860 $h = start \@cat, $in, '>pipe', \*OUT, '2>pipe', \*ERR;
861 $in = "hello world\n";
862 finish $h;
863 print <OUT>;
864 print <ERR>;
865 close OUT;
866 close ERR;
867
868causes two pipe to be created, with one end attached to cat's stdout
869and stderr, respectively, and the other left open on OUT and ERR, so
870that the script can manually
871read(), select(), etc. on them. This is like
872the behavior of IPC::Open2 and IPC::Open3.
873
874B<Win32>: The handle returned is actually a socket handle, so you can
875use select() on it.
876
877=item Duplicating output descriptors: >&m, n>&m
878
879This duplicates output descriptor number n (default is 1 if n is omitted)
880from descriptor number m.
881
882=item Duplicating input descriptors: <&m, n<&m
883
884This duplicates input descriptor number n (default is 0 if n is omitted)
885from descriptor number m
886
887=item Closing descriptors: <&-, 3<&-
888
889This closes descriptor number n (default is 0 if n is omitted). The
890following commands are equivalent:
891
892 run \@cmd, \undef;
893 run \@cmd, '<&-';
894 run \@cmd, '<in.txt', '<&-';
895
896Doing
897
898 run \@cmd, \$in, '<&-'; ## SIGPIPE recipe.
899
900is dangerous: the parent will get a SIGPIPE if $in is not empty.
901
902=item Redirecting both stdout and stderr: &>, >&, &>pipe, >pipe&
903
904The following pairs of commands are equivalent:
905
906 run \@cmd, '>&', \$out; run \@cmd, '>', \$out, '2>&1';
907 run \@cmd, '>&', 'out.txt'; run \@cmd, '>', 'out.txt', '2>&1';
908
909etc.
910
911File descriptor numbers are not permitted to the left or the right of
912these operators, and the '&' may occur on either end of the operator.
913
914The '&>pipe' and '>pipe&' variants behave like the '>pipe' operator, except
915that both stdout and stderr write to the created pipe.
916
917=item Redirection Filters
918
919Both input redirections and output redirections that use scalars or
920subs as endpoints may have an arbitrary number of filter subs placed
921between them and the child process. This is useful if you want to
922receive output in chunks, or if you want to massage each chunk of
923data sent to the child. To use this feature, you must use operator
924syntax:
925
926 run(
927 \@cmd
928 '<', \&in_filter_2, \&in_filter_1, $in,
929 '>', \&out_filter_1, \&in_filter_2, $out,
930 );
931
932This capability is not provided for IO handles or named files.
933
934Two filters are provided by IPC::Run: appender and chunker. Because
935these may take an argument, you need to use the constructor functions
936new_appender() and new_chunker() rather than using \& syntax:
937
938 run(
939 \@cmd
940 '<', new_appender( "\n" ), $in,
941 '>', new_chunker, $out,
942 );
943
944=back
945
946=head2 Just doing I/O
947
948If you just want to do I/O to a handle or file you open yourself, you
949may specify a filehandle or filename instead of a command in the harness
950specification:
951
952 run io( "filename", '>', \$recv );
953
954 $h = start io( $io, '>', \$recv );
955
956 $h = harness \@cmd, '&', io( "file", '<', \$send );
957
958=head2 Options
959
960Options are passed in as name/value pairs:
961
962 run \@cat, \$in, debug => 1;
963
964If you pass the debug option, you may want to pass it in first, so you
965can see what parsing is going on:
966
967 run debug => 1, \@cat, \$in;
968
969=over
970
971=item debug
972
973Enables debugging output in parent and child. Debugging info is emitted
974to the STDERR that was present when IPC::Run was first C<use()>ed (it's
975C<dup()>ed out of the way so that it can be redirected in children without
976having debugging output emitted on it).
977
978=back
979
980=head1 RETURN VALUES
981
982harness() and start() return a reference to an IPC::Run harness. This is
983blessed in to the IPC::Run package, so you may make later calls to
984functions as members if you like:
985
986 $h = harness( ... );
987 $h->start;
988 $h->pump;
989 $h->finish;
990
991 $h = start( .... );
992 $h->pump;
993 ...
994
995Of course, using method call syntax lets you deal with any IPC::Run
996subclasses that might crop up, but don't hold your breath waiting for
997any.
998
999run() and finish() return TRUE when all subcommands exit with a 0 result
1000code. B<This is the opposite of perl's system() command>.
1001
1002All routines raise exceptions (via die()) when error conditions are
1003recognized. A non-zero command result is not treated as an error
1004condition, since some commands are tests whose results are reported
1005in their exit codes.
1006
1007=head1 ROUTINES
1008
1009=over
1010
1011=cut
1012
1013218µs27µs
# spent 6µs (5+1) within IPC::Run::BEGIN@1013 which was called: # once (5µs+1µs) by main::BEGIN@29 at line 1013
use strict;
# spent 6µs making 1 call to IPC::Run::BEGIN@1013 # spent 1µs making 1 call to strict::import
1014212µs235µs
# spent 19µs (3+16) within IPC::Run::BEGIN@1014 which was called: # once (3µs+16µs) by main::BEGIN@29 at line 1014
use warnings;
# spent 19µs making 1 call to IPC::Run::BEGIN@1014 # spent 16µs making 1 call to warnings::import
1015215µs12µs
# spent 2µs within IPC::Run::BEGIN@1015 which was called: # once (2µs+0s) by main::BEGIN@29 at line 1015
use Exporter ();
# spent 2µs making 1 call to IPC::Run::BEGIN@1015
1016278µs280µs
# spent 43µs (6+37) within IPC::Run::BEGIN@1016 which was called: # once (6µs+37µs) by main::BEGIN@29 at line 1016
use vars qw{$VERSION @ISA @FILTER_IMP @FILTERS @API @EXPORT_OK %EXPORT_TAGS};
# spent 43µs making 1 call to IPC::Run::BEGIN@1016 # spent 37µs making 1 call to vars::import
1017
1018
# spent 13µs within IPC::Run::BEGIN@1018 which was called: # once (13µs+0s) by main::BEGIN@29 at line 1048
BEGIN {
10191200ns $VERSION = '20220807.0';
102016µs @ISA = qw{ Exporter };
1021
1022 ## We use @EXPORT for the end user's convenience: there's only one function
1023 ## exported, it's homonymous with the module, it's an unusual name, and
1024 ## it can be suppressed by "use IPC::Run ();".
10251500ns @FILTER_IMP = qw( input_avail get_more_input );
10261600ns @FILTERS = qw(
1027 new_appender
1028 new_chunker
1029 new_string_source
1030 new_string_sink
1031 );
103211µs @API = qw(
1033 run
1034 harness start pump pumpable finish
1035 signal kill_kill reap_nb
1036 io timer timeout
1037 close_terminal
1038 binary
1039 );
104012µs @EXPORT_OK = ( @API, @FILTER_IMP, @FILTERS, qw( Win32_MODE ) );
104113µs %EXPORT_TAGS = (
1042 'filter_imp' => \@FILTER_IMP,
1043 'all' => \@EXPORT_OK,
1044 'filters' => \@FILTERS,
1045 'api' => \@API,
1046 );
1047
1048116µs113µs}
# spent 13µs making 1 call to IPC::Run::BEGIN@1018
1049
1050213µs25µs
# spent 4µs (3+1) within IPC::Run::BEGIN@1050 which was called: # once (3µs+1µs) by main::BEGIN@29 at line 1050
use strict;
# spent 4µs making 1 call to IPC::Run::BEGIN@1050 # spent 1µs making 1 call to strict::import
1051213µs231µs
# spent 17µs (3+14) within IPC::Run::BEGIN@1051 which was called: # once (3µs+14µs) by main::BEGIN@29 at line 1051
use warnings;
# spent 17µs making 1 call to IPC::Run::BEGIN@1051 # spent 14µs making 1 call to warnings::import
10522105µs2994µs
# spent 967µs (845+122) within IPC::Run::BEGIN@1052 which was called: # once (845µs+122µs) by main::BEGIN@29 at line 1052
use IPC::Run::Debug;
# spent 967µs making 1 call to IPC::Run::BEGIN@1052 # spent 27µs making 1 call to Exporter::import
1053213µs214µs
# spent 9µs (4+5) within IPC::Run::BEGIN@1053 which was called: # once (4µs+5µs) by main::BEGIN@29 at line 1053
use Exporter;
# spent 9µs making 1 call to IPC::Run::BEGIN@1053 # spent 5µs making 1 call to Exporter::import
1054214µs2227µs
# spent 116µs (6+111) within IPC::Run::BEGIN@1054 which was called: # once (6µs+111µs) by main::BEGIN@29 at line 1054
use Fcntl;
# spent 116µs making 1 call to IPC::Run::BEGIN@1054 # spent 111µs making 1 call to Exporter::import
1055221µs12µs
# spent 2µs within IPC::Run::BEGIN@1055 which was called: # once (2µs+0s) by main::BEGIN@29 at line 1055
use POSIX ();
# spent 2µs making 1 call to IPC::Run::BEGIN@1055
1056
1057
# spent 2µs within IPC::Run::BEGIN@1057 which was called: # once (2µs+0s) by main::BEGIN@29 at line 1059
BEGIN {
105811µs if ( $] < 5.008 ) { require Symbol; }
1059110µs12µs}
# spent 2µs making 1 call to IPC::Run::BEGIN@1057
1060212µs234µs
# spent 18µs (3+15) within IPC::Run::BEGIN@1060 which was called: # once (3µs+15µs) by main::BEGIN@29 at line 1060
use Carp;
# spent 18µs making 1 call to IPC::Run::BEGIN@1060 # spent 15µs making 1 call to Exporter::import
1061210µs12µs
# spent 2µs within IPC::Run::BEGIN@1061 which was called: # once (2µs+0s) by main::BEGIN@29 at line 1061
use File::Spec ();
# spent 2µs making 1 call to IPC::Run::BEGIN@1061
1062241µs215µs
# spent 10µs (5+5) within IPC::Run::BEGIN@1062 which was called: # once (5µs+5µs) by main::BEGIN@29 at line 1062
use IO::Handle;
# spent 10µs making 1 call to IPC::Run::BEGIN@1062 # spent 5µs making 1 call to Exporter::import
1063198µsrequire IPC::Run::IO;
10641102µsrequire IPC::Run::Timer;
1065
1066245µs359µs
# spent 33µs (8+26) within IPC::Run::BEGIN@1066 which was called: # once (8µs+26µs) by main::BEGIN@29 at line 1066
use constant Win32_MODE => $^O =~ /os2|Win32/i;
# spent 33µs making 1 call to IPC::Run::BEGIN@1066 # spent 23µs making 1 call to constant::import # spent 2µs making 1 call to IPC::Run::CORE:match
1067
1068
# spent 52µs (31+22) within IPC::Run::BEGIN@1068 which was called: # once (31µs+22µs) by main::BEGIN@29 at line 1077
BEGIN {
106912µs1700ns if (Win32_MODE) {
# spent 700ns making 1 call to constant::__ANON__[constant.pm:192]
1070 eval "use IPC::Run::Win32Helper; 1;"
1071 or ( $@ && die )
1072 or die "$!";
1073 }
1074 else {
1075122µs eval "use File::Basename; 1;" or die $!;
# spent 11µs executing statements in string eval
# includes 6µs spent executing 1 call to 1 sub defined therein.
1076 }
1077124µs152µs}
# spent 52µs making 1 call to IPC::Run::BEGIN@1068
1078
1079sub input_avail();
1080sub get_more_input();
1081
1082###############################################################################
1083
1084##
1085## Error constants, not too locale-dependent
1086214µs229µs
# spent 16µs (3+13) within IPC::Run::BEGIN@1086 which was called: # once (3µs+13µs) by main::BEGIN@29 at line 1086
use vars qw( $_EIO $_EAGAIN );
# spent 16µs making 1 call to IPC::Run::BEGIN@1086 # spent 13µs making 1 call to vars::import
1087253µs2234µs
# spent 119µs (4+115) within IPC::Run::BEGIN@1087 which was called: # once (4µs+115µs) by main::BEGIN@29 at line 1087
use Errno qw( EIO EAGAIN );
# spent 119µs making 1 call to IPC::Run::BEGIN@1087 # spent 115µs making 1 call to Exporter::import
1088
1089
# spent 28µs (12+16) within IPC::Run::BEGIN@1089 which was called: # once (12µs+16µs) by main::BEGIN@29 at line 1095
BEGIN {
109011µs local $!;
10911500ns $! = EIO;
1092116µs212µs $_EIO = qr/^$!/;
# spent 11µs making 1 call to IPC::Run::CORE:regcomp # spent 800ns making 1 call to IPC::Run::CORE:qr
10931200ns $! = EAGAIN;
109418µs24µs $_EAGAIN = qr/^$!/;
# spent 4µs making 1 call to IPC::Run::CORE:regcomp # spent 200ns making 1 call to IPC::Run::CORE:qr
1095158µs128µs}
# spent 28µs making 1 call to IPC::Run::BEGIN@1089
1096
1097##
1098## State machine states, set in $self->{STATE}
1099##
1100## These must be in ascending order numerically
1101##
1102sub _newed() { 0 }
1103sub _harnessed() { 1 }
1104sub _finished() { 2 } ## _finished behave almost exactly like _harnessed
1105sub _started() { 3 }
1106
1107##
1108## Which fds have been opened in the parent. This may have extra fds, since
1109## we aren't all that rigorous about closing these off, but that's ok. This
1110## is used on Unixish OSs to close all fds in the child that aren't needed
1111## by that particular child.
11121300nsmy %fds;
1113
1114## There's a bit of hackery going on here.
1115##
1116## We want to have any code anywhere be able to emit
1117## debugging statements without knowing what harness the code is
1118## being called in/from, since we'd need to pass a harness around to
1119## everything.
1120##
1121## Thus, $cur_self was born.
1122
112321.51ms223µs
# spent 13µs (4+9) within IPC::Run::BEGIN@1123 which was called: # once (4µs+9µs) by main::BEGIN@29 at line 1123
use vars qw( $cur_self );
# spent 13µs making 1 call to IPC::Run::BEGIN@1123 # spent 9µs making 1 call to vars::import
1124
1125
# spent 1.70s (793ms+912ms) within IPC::Run::_debug_fd which was called 133036 times, avg 13µs/call: # 133036 times (793ms+912ms) by IPC::Run::_open_pipes at line 2178, avg 13µs/call
sub _debug_fd {
112613303636.9ms return fileno STDERR unless defined $cur_self;
1127
112813303688.0ms133036912ms if ( _debugging && !defined $cur_self->{DEBUG_FD} ) {
# spent 912ms making 133036 calls to IPC::Run::Debug::_debugging, avg 7µs/call
1129 my $fd = select STDERR;
1130 $| = 1;
1131 select $fd;
1132 $cur_self->{DEBUG_FD} = POSIX::dup fileno STDERR;
1133 _debug("debugging fd is $cur_self->{DEBUG_FD}\n")
1134 if _debugging_details;
1135 }
1136
1137133036467ms return fileno STDERR unless defined $cur_self->{DEBUG_FD};
1138
1139 return $cur_self->{DEBUG_FD};
1140}
1141
1142
# spent 2.86s within IPC::Run::DESTROY which was called 133036 times, avg 22µs/call: # 133036 times (2.86s+0s) by IPC::Run::run at line 1529, avg 22µs/call
sub DESTROY {
1143 ## We absolutely do not want to do anything else here. We are likely
1144 ## to be in a child process and we don't want to do things like kill_kill
1145 ## ourself or cause other destruction.
114613303619.4ms my IPC::Run $self = shift;
114713303657.7ms POSIX::close $self->{DEBUG_FD} if defined $self->{DEBUG_FD};
114813303654.4ms $self->{DEBUG_FD} = undef;
1149
1150133036869ms for my $kid ( @{$self->{KIDS}} ) {
115113303678.4ms for my $op ( @{$kid->{OPS}} ) {
11521330362.09s delete $op->{FILTERS};
1153 }
1154 }
1155}
1156
1157##
1158## Support routines (NOT METHODS)
1159##
1160my %cmd_cache;
1161
1162
# spent 11.2s (6.05+5.19) within IPC::Run::_search_path which was called 133036 times, avg 84µs/call: # 133036 times (6.05s+5.19s) by IPC::Run::_open_pipes at line 2132, avg 84µs/call
sub _search_path {
1163133036244ms my ($cmd_name) = @_;
1164133036593ms1330361.88s if ( File::Spec->file_name_is_absolute($cmd_name) && -x $cmd_name ) {
# spent 1.88s making 133036 calls to File::Spec::Unix::file_name_is_absolute, avg 14µs/call
1165 _debug "'", $cmd_name, "' is absolute"
1166 if _debugging_details;
1167 return $cmd_name;
1168 }
1169
11701330361.53s399108598ms my $dirsep = (
# spent 555ms making 266072 calls to IPC::Run::CORE:match, avg 2µs/call # spent 42.7ms making 133036 calls to constant::__ANON__[constant.pm:192], avg 321ns/call
1171 Win32_MODE ? '[/\\\\]'
1172 : $^O =~ /MacOS/ ? ':'
1173 : $^O =~ /VMS/ ? '[\[\]]'
1174 : '/'
1175 );
1176
117713303694.0ms13303630.4ms if ( Win32_MODE
# spent 30.4ms making 133036 calls to constant::__ANON__[constant.pm:192], avg 228ns/call
1178 && ( $cmd_name =~ /$dirsep/ )
1179 && ( $cmd_name !~ m!\.[^\\/\.]+$! ) ) {
1180
1181 _debug "no extension(.exe), checking ENV{PATHEXT}" if _debugging;
1182 for ( split /;/, $ENV{PATHEXT} || ".COM;.BAT;.EXE" ) {
1183 my $name = "$cmd_name$_";
1184 $cmd_name = $name, last if -f $name && -x _;
1185 }
1186 _debug "cmd_name is now '$cmd_name'" if _debugging;
1187 }
1188
1189133036927ms266072259ms if ( $cmd_name =~ /($dirsep)/ ) {
# spent 133ms making 133036 calls to IPC::Run::CORE:match, avg 1µs/call # spent 125ms making 133036 calls to IPC::Run::CORE:regcomp, avg 942ns/call
1190133035108ms1330351.08s _debug "'$cmd_name' contains '$1'" if _debugging;
# spent 1.08s making 133035 calls to IPC::Run::Debug::_debugging, avg 8µs/call
11911330351.08s133035483ms croak "file not found: $cmd_name" unless -e $cmd_name;
# spent 483ms making 133035 calls to IPC::Run::CORE:ftis, avg 4µs/call
1192133035611ms133035238ms croak "not a file: $cmd_name" unless -f $cmd_name;
# spent 238ms making 133035 calls to IPC::Run::CORE:ftfile, avg 2µs/call
1193133035986ms133035619ms croak "permission denied: $cmd_name" unless -x $cmd_name;
# spent 619ms making 133035 calls to IPC::Run::CORE:fteexec, avg 5µs/call
1194133035465ms return $cmd_name;
1195 }
1196
11971900ns if ( exists $cmd_cache{$cmd_name} ) {
1198 _debug "'$cmd_name' found in cache: '$cmd_cache{$cmd_name}'"
1199 if _debugging;
1200 return $cmd_cache{$cmd_name} if -x $cmd_cache{$cmd_name};
1201 _debug "'$cmd_cache{$cmd_name}' no longer executable, searching..."
1202 if _debugging;
1203 delete $cmd_cache{$cmd_name};
1204 }
1205
12061200ns my @searched_in;
1207
1208 ## This next bit is Unix/Win32 specific, unfortunately.
1209 ## There's been some conversation about extending File::Spec to provide
1210 ## a universal interface to PATH, but I haven't seen it yet.
1211111µs28µs my $re = Win32_MODE ? qr/;/ : qr/:/;
# spent 8µs making 1 call to IPC::Run::CORE:qr # spent 200ns making 1 call to constant::__ANON__[constant.pm:192]
1212
1213 LOOP:
1214122µs11µs for ( split( $re, $ENV{PATH} || '', -1 ) ) {
# spent 1µs making 1 call to IPC::Run::CORE:regcomp
121572µs $_ = "." unless length $_;
121674µs push @searched_in, $_;
1217
12187110µs28122µs my $prospect = File::Spec->catfile( $_, $cmd_name );
# spent 84µs making 7 calls to File::Spec::Unix::catfile, avg 12µs/call # spent 28µs making 7 calls to File::Spec::Unix::catdir, avg 4µs/call # spent 10µs making 14 calls to File::Spec::Unix::canonpath, avg 714ns/call
12197800ns my @prospects;
1220
1221 @prospects =
1222 ( Win32_MODE && !( -f $prospect && -x _ ) )
1223710µs74µs ? map "$prospect$_", split /;/, $ENV{PATHEXT} || ".COM;.BAT;.EXE"
# spent 4µs making 7 calls to constant::__ANON__[constant.pm:192], avg 643ns/call
1224 : ($prospect);
1225
1226711µs for my $found (@prospects) {
1227784µs862µs if ( -f $found && -x _ ) {
# spent 52µs making 7 calls to IPC::Run::CORE:ftfile, avg 7µs/call # spent 11µs making 1 call to IPC::Run::CORE:fteexec
122814µs $cmd_cache{$cmd_name} = $found;
122914µs last LOOP;
1230 }
1231 }
1232 }
1233
12341600ns if ( exists $cmd_cache{$cmd_name} ) {
123512µs18µs _debug "'", $cmd_name, "' added to cache: '", $cmd_cache{$cmd_name}, "'"
# spent 8µs making 1 call to IPC::Run::Debug::_debugging_details
1236 if _debugging_details;
123718µs return $cmd_cache{$cmd_name};
1238 }
1239
1240 croak "Command '$cmd_name' not found in " . join( ", ", @searched_in );
1241}
1242
1243# Translate a command or CODE reference (a $kid->{VAL}) to a list of strings
1244# suitable for passing to _debug().
1245sub _debugstrings {
1246 my $operand = shift;
1247 if ( !defined $operand ) {
1248 return '<undef>';
1249 }
1250
1251 my $ref = ref $operand;
1252 if ( !$ref ) {
1253 return length $operand < 50
1254 ? "'$operand'"
1255 : join( '', "'", substr( $operand, 0, 10 ), "...'" );
1256 }
1257 elsif ( $ref eq 'ARRAY' ) {
1258 return (
1259 '[ ',
1260 join( " ", map /[^\w.-]/ ? "'$_'" : $_, @$operand ),
1261 ' ]'
1262 );
1263 }
1264 elsif ( UNIVERSAL::isa( $operand, 'IPC::Run::Win32Process' ) ) {
1265 return "$operand";
1266 }
1267 return $ref;
1268}
1269
12705321441.98s
# spent 1.26s within IPC::Run::_empty which was called 532144 times, avg 2µs/call: # 266072 times (852ms+0s) by IPC::Run::IO::__ANON__[/home/hejohns/perl5/lib/perl5/IPC/Run/IO.pm:216] at line 207 of IPC/Run/IO.pm, avg 3µs/call # 133036 times (293ms+0s) by IPC::Run::harness at line 1906, avg 2µs/call # 133036 times (118ms+0s) by IPC::Run::IO::_new_internal at line 173 of IPC/Run/IO.pm, avg 884ns/call
sub _empty($) { !( defined $_[0] && length $_[0] ) }
1271
1272## 'safe' versions of otherwise fun things to do. See also IPC::Run::Win32Helper.
1273
# spent 33.2s (18.7+14.5) within IPC::Run::_close which was called 532144 times, avg 62µs/call: # 133036 times (8.93s+6.58s) by IPC::Run::_spawn at line 1456, avg 117µs/call # 133036 times (3.97s+3.74s) by IPC::Run::_spawn at line 1458, avg 58µs/call # 133036 times (3.08s+2.44s) by IPC::Run::IO::close at line 372 of IPC/Run/IO.pm, avg 42µs/call # 133036 times (2.70s+1.71s) by IPC::Run::start at line 2907, avg 33µs/call
sub _close {
1274532144145ms confess 'undef' unless defined $_[0];
12755321445.14s5321443.05s my $fd = $_[0] =~ /^\d+$/ ? $_[0] : fileno $_[0];
# spent 3.05s making 532144 calls to IPC::Run::CORE:match, avg 6µs/call
12765321441.64s5321441.45s if (Win32_MODE) {
# spent 1.45s making 532144 calls to constant::__ANON__[constant.pm:192], avg 3µs/call
1277
1278 # Perl close() or POSIX::close() on the read end of a pipe hangs if
1279 # another process is in a read attempt on the same pipe
1280 # (https://github.com/Perl/perl5/issues/19963). Since IPC::Run creates
1281 # pipes and shares them with user-defined kids, it's affected. Work
1282 # around that by first using dup2() to replace the FD with a non-pipe.
1283 # Unfortunately, for socket FDs, dup2() closes the SOCKET with
1284 # CloseHandle(). CloseHandle() documentation leaves its behavior
1285 # undefined for sockets. However, tests on Windows Server 2022 did not
1286 # leak memory, leak ports, or reveal any other obvious trouble.
1287 #
1288 # No failure here is fatal. (_close() has worked that way, either due
1289 # to a principle or just due to a history of callers passing closed
1290 # FDs.) croak() on EMFILE would be a bad user experience. Better to
1291 # proceed and hope that $fd is not a being-read pipe.
1292 #
1293 # Since start() and other user-facing methods _close() many FDs, we
1294 # could optimize this by opening and closing the non-pipe FD just once
1295 # per method call. The overhead of this simple approach was in the
1296 # noise, however.
1297 my $nul_fd = POSIX::open 'NUL';
1298 if ( !defined $nul_fd ) {
1299 _debug "open( NUL ) = ERROR $!" if _debugging_details;
1300 }
1301 else {
1302 my $r = POSIX::dup2( $nul_fd, $fd );
1303 _debug "dup2( $nul_fd, $fd ) = ERROR $!"
1304 if _debugging_details && !defined $r;
1305 $r = POSIX::close $nul_fd;
1306 _debug "close( $nul_fd (NUL) ) = ERROR $!"
1307 if _debugging_details && !defined $r;
1308 }
1309 }
13105321445.72s5321442.77s my $r = POSIX::close $fd;
# spent 2.77s making 532144 calls to POSIX::close, avg 5µs/call
1311532144239ms $r = $r ? '' : " ERROR $!";
13125321445.47s delete $fds{$fd};
13135321442.40s5321447.20s _debug "close( $fd ) = " . ( $r || 0 ) if _debugging_details;
# spent 7.20s making 532144 calls to IPC::Run::Debug::_debugging_details, avg 14µs/call
1314}
1315
1316
# spent 4.60s (2.16+2.44) within IPC::Run::_dup which was called 266072 times, avg 17µs/call: # 266072 times (2.16s+2.44s) by IPC::Run::_pipe_nb at line 1407, avg 17µs/call
sub _dup {
131726607253.6ms confess 'undef' unless defined $_[0];
13182660721.16s266072473ms my $r = POSIX::dup( $_[0] );
# spent 473ms making 266072 calls to POSIX::dup, avg 2µs/call
131926607234.6ms croak "$!: dup( $_[0] )" unless defined $r;
132026607266.6ms $r = 0 if $r eq '0 but true';
1321266072144ms2660721.97s _debug "dup( $_[0] ) = $r" if _debugging_details;
# spent 1.97s making 266072 calls to IPC::Run::Debug::_debugging_details, avg 7µs/call
1322266072167ms $fds{$r} = {};
1323266072664ms return $r;
1324}
1325
1326sub _dup2_rudely {
1327 confess 'undef' unless defined $_[0] && defined $_[1];
1328 my $r = POSIX::dup2( $_[0], $_[1] );
1329 croak "$!: dup2( $_[0], $_[1] )" unless defined $r;
1330 $r = 0 if $r eq '0 but true';
1331 _debug "dup2( $_[0], $_[1] ) = $r" if _debugging_details;
1332 $fds{$r} = {};
1333 return $r;
1334}
1335
1336sub _exec {
1337 confess 'undef passed' if grep !defined, @_;
1338
1339 # exec @_ or croak "$!: exec( " . join( ', ', @_ ) . " )";
1340 _debug 'exec()ing ', join " ", map "'$_'", @_ if _debugging_details;
1341
1342 # {
1343## Commented out since we don't call this on Win32.
1344 # # This works around the bug where 5.6.1 complains
1345 # # "Can't exec ...: No error" after an exec on NT, where
1346 # # exec() is simulated and actually returns in Perl's C
1347 # # code, though Perl's &exec does not...
1348 # no warnings "exec";
1349 #
1350 # # Just in case the no warnings workaround
1351 # # stops being a workaround, we don't want
1352 # # old values of $! causing spurious strerr()
1353 # # messages to appear in the "Can't exec" message
1354 # undef $!;
1355 exec { $_[0] } @_;
1356
1357 # }
1358 # croak "$!: exec( " . join( ', ', map "'$_'", @_ ) . " )";
1359 ## Fall through so $! can be reported to parent.
1360}
1361
1362sub _sysopen {
1363 confess 'undef' unless defined $_[0] && defined $_[1];
1364 _debug sprintf( "O_RDONLY=0x%02x ", O_RDONLY ),
1365 sprintf( "O_WRONLY=0x%02x ", O_WRONLY ),
1366 sprintf( "O_RDWR=0x%02x ", O_RDWR ),
1367 sprintf( "O_TRUNC=0x%02x ", O_TRUNC ),
1368 sprintf( "O_CREAT=0x%02x ", O_CREAT ),
1369 sprintf( "O_APPEND=0x%02x ", O_APPEND ),
1370 if _debugging_details;
1371 my $r = POSIX::open( $_[0], $_[1], 0666 );
1372 croak "$!: open( $_[0], ", sprintf( "0x%03x", $_[1] ), " )" unless defined $r;
1373 _debug "open( $_[0], ", sprintf( "0x%03x", $_[1] ), " ) = $r"
1374 if _debugging_data;
1375 $fds{$r} = {};
1376 return $r;
1377}
1378
1379
# spent 3.51s (1.69+1.82) within IPC::Run::_pipe which was called 133036 times, avg 26µs/call: # 133036 times (1.69s+1.82s) by IPC::Run::_spawn at line 1444, avg 26µs/call
sub _pipe {
1380 ## Normal, blocking write for pipes that we read and the child writes,
1381 ## since most children expect writes to stdout to block rather than
1382 ## do a partial write.
13831330361.28s133036859ms my ( $r, $w ) = POSIX::pipe;
# spent 859ms making 133036 calls to POSIX::pipe, avg 6µs/call
138413303637.9ms croak "$!: pipe()" unless defined $r;
138513303683.6ms133036966ms _debug "pipe() = ( $r, $w ) " if _debugging_details;
# spent 966ms making 133036 calls to IPC::Run::Debug::_debugging_details, avg 7µs/call
1386133036203ms @fds{$r, $w} = ( {}, {} );
1387133036368ms return ( $r, $w );
1388}
1389
1390
# spent 15.8s (7.60+8.23) within IPC::Run::_pipe_nb which was called 133036 times, avg 119µs/call: # 133036 times (7.60s+8.23s) by IPC::Run::IO::_do_open at line 315 of IPC/Run/IO.pm, avg 119µs/call
sub _pipe_nb {
1391 ## For pipes that we write, unblock the write side, so we can fill a buffer
1392 ## and continue to select().
1393 ## Contributed by Borislav Deianov <borislav@ensim.com>, with minor
1394 ## bugfix on fcntl result by me.
1395133036377ms local ( *R, *W );
13961330362.34s my $f = pipe( R, W );
139713303637.8ms croak "$!: pipe()" unless defined $f;
1398133036514ms my ( $r, $w ) = ( fileno R, fileno W );
1399133036106ms1330361.12s _debug "pipe_nb pipe() = ( $r, $w )" if _debugging_details;
# spent 1.12s making 133036 calls to IPC::Run::Debug::_debugging_details, avg 8µs/call
1400133036131ms13303651.0ms unless (Win32_MODE) {
# spent 51.0ms making 133036 calls to constant::__ANON__[constant.pm:192], avg 383ns/call
1401 ## POSIX::fcntl doesn't take fd numbers, so gotta use Perl's and
1402 ## then _dup the originals (which get closed on leaving this block)
14031330361.23s266072508ms my $fres = fcntl( W, &F_SETFL, O_WRONLY | O_NONBLOCK );
# spent 424ms making 133036 calls to IPC::Run::CORE:fcntl, avg 3µs/call # spent 84.2ms making 133036 calls to IPC::Run::F_SETFL, avg 633ns/call
140413303618.4ms croak "$!: fcntl( $w, F_SETFL, O_NONBLOCK )" unless $fres;
140513303689.6ms133036968ms _debug "fcntl( $w, F_SETFL, O_NONBLOCK )" if _debugging_details;
# spent 968ms making 133036 calls to IPC::Run::Debug::_debugging_details, avg 7µs/call
1406 }
1407133036394ms2660724.60s ( $r, $w ) = ( _dup($r), _dup($w) );
# spent 4.60s making 266072 calls to IPC::Run::_dup, avg 17µs/call
140813303681.2ms133036988ms _debug "pipe_nb() = ( $r, $w )" if _debugging_details;
# spent 988ms making 133036 calls to IPC::Run::Debug::_debugging_details, avg 7µs/call
1409133036886ms return ( $r, $w );
1410}
1411
1412sub _pty {
1413 require IO::Pty;
1414 my $pty = IO::Pty->new();
1415 croak "$!: pty ()" unless $pty;
1416 $pty->autoflush();
1417 $pty->blocking(0) or croak "$!: pty->blocking ( 0 )";
1418 _debug "pty() = ( ", $pty->fileno, ", ", $pty->slave->fileno, " )"
1419 if _debugging_details;
1420 @fds{ $pty->fileno, $pty->slave->fileno } = ( {}, {} );
1421 return $pty;
1422}
1423
1424
# spent 15226s (3.85+15222) within IPC::Run::_read which was called 133036 times, avg 114ms/call: # 133036 times (3.85s+15222s) by IPC::Run::_spawn at line 1457, avg 114ms/call
sub _read {
142513303639.2ms confess 'undef' unless defined $_[0];
1426133036524ms my $s = '';
142713303615221s13303615219s my $r = POSIX::read( $_[0], $s, 10_000 );
# spent 15219s making 133036 calls to POSIX::read, avg 114ms/call
142813303656.6ms croak "$!: read( $_[0] )" if not($r) and !$!{EINTR};
142913303623.2ms $r ||= 0;
1430133036406ms1330362.65s _debug "read( $_[0] ) = $r chars '$s'" if _debugging_data;
# spent 2.65s making 133036 calls to IPC::Run::Debug::_debugging_data, avg 20µs/call
1431133036573ms return $s;
1432}
1433
1434## A METHOD, not a function.
1435
# spent 15370s (104+15266) within IPC::Run::_spawn which was called 133036 times, avg 116ms/call: # 133036 times (104s+15266s) by IPC::Run::start at line 2849, avg 116ms/call
sub _spawn {
143613303643.6ms my IPC::Run $self = shift;
143713303640.5ms my ($kid) = @_;
1438
1439 croak "Can't spawn IPC::Run::Win32Process except on Win32"
1440133036389ms13303659.6ms if UNIVERSAL::isa( $kid->{VAL}, 'IPC::Run::Win32Process' );
# spent 59.6ms making 133036 calls to UNIVERSAL::isa, avg 448ns/call
1441
144213303670.7ms133036990ms _debug "opening sync pipe ", $kid->{PID} if _debugging_details;
# spent 990ms making 133036 calls to IPC::Run::Debug::_debugging_details, avg 7µs/call
144313303624.8ms my $sync_reader_fd;
1444133036688ms1330363.51s ( $sync_reader_fd, $self->{SYNC_WRITER_FD} ) = _pipe;
# spent 3.51s making 133036 calls to IPC::Run::_pipe, avg 26µs/call
144513303698.0s132930616ms $kid->{PID} = fork();
# spent 616ms making 132930 calls to Encode::utf8::encode, avg 5µs/call
144613303681.6ms croak "$! during fork" unless defined $kid->{PID};
1447
144813303647.6ms unless ( $kid->{PID} ) {
1449 ## _do_kid_and_exit closes sync_reader_fd since it closes all unwanted and
1450 ## unloved fds.
1451 $self->_do_kid_and_exit($kid);
1452 }
14531330366.73s13303611.8s _debug "fork() = ", $kid->{PID} if _debugging_details;
# spent 11.8s making 133036 calls to IPC::Run::Debug::_debugging_details, avg 89µs/call
1454
1455 ## Wait for kid to get to it's exec() and see if it fails.
14561330362.05s13303615.5s _close $self->{SYNC_WRITER_FD};
# spent 15.5s making 133036 calls to IPC::Run::_close, avg 117µs/call
14571330361.63s13303615226s my $sync_pulse = _read $sync_reader_fd;
# spent 15226s making 133036 calls to IPC::Run::_read, avg 114ms/call
1458133036264ms1330367.71s _close $sync_reader_fd;
# spent 7.71s making 133036 calls to IPC::Run::_close, avg 58µs/call
1459
146013303686.7ms if ( !defined $sync_pulse || length $sync_pulse ) {
1461 if ( waitpid( $kid->{PID}, 0 ) >= 0 ) {
1462 $kid->{RESULT} = $?;
1463 }
1464 else {
1465 $kid->{RESULT} = -1;
1466 }
1467 $sync_pulse = "error reading synchronization pipe for $kid->{NUM}, pid $kid->{PID}"
1468 unless length $sync_pulse;
1469 croak $sync_pulse;
1470 }
14711330361.39s return $kid->{PID};
1472
1473## Wait for pty to get set up. This is a hack until we get synchronous
1474## selects.
1475 if ( keys %{ $self->{PTYS} } && $IO::Pty::VERSION < 0.9 ) {
1476 _debug "sleeping to give pty a chance to init, will fix when newer IO::Pty arrives.";
1477 sleep 1;
1478 }
1479}
1480
1481
# spent 4.01s (1.30+2.71) within IPC::Run::_write which was called 133056 times, avg 30µs/call: # 133056 times (1.30s+2.71s) by IPC::Run::__ANON__[/home/hejohns/perl5/lib/perl5/IPC/Run.pm:2514] at line 2505, avg 30µs/call
sub _write {
148213305658.1ms confess 'undef' unless defined $_[0] && defined $_[1];
14831330561.37s133056915ms my $r = POSIX::write( $_[0], $_[1], length $_[1] );
# spent 915ms making 133056 calls to POSIX::write, avg 7µs/call
148413305632.5ms croak "$!: write( $_[0], '$_[1]' )" unless $r;
1485133056214ms1330561.79s _debug "write( $_[0], '$_[1]' ) = $r" if _debugging_data;
# spent 1.79s making 133056 calls to IPC::Run::Debug::_debugging_data, avg 13µs/call
1486133056486ms return $r;
1487}
1488
1489=pod
1490
1491=over
1492
1493=item run
1494
1495Run takes a harness or harness specification and runs it, pumping
1496all input to the child(ren), closing the input pipes when no more
1497input is available, collecting all output that arrives, until the
1498pipes delivering output are closed, then waiting for the children to
1499exit and reaping their result codes.
1500
1501You may think of C<run( ... )> as being like
1502
1503 start( ... )->finish();
1504
1505, though there is one subtle difference: run() does not
1506set \$input_scalars to '' like finish() does. If an exception is thrown
1507from run(), all children will be killed off "gently", and then "annihilated"
1508if they do not go gently (in to that dark night. sorry).
1509
1510If any exceptions are thrown, this does a L</kill_kill> before propagating
1511them.
1512
1513=cut
1514
151526.18ms234µs
# spent 20µs (6+14) within IPC::Run::BEGIN@1515 which was called: # once (6µs+14µs) by main::BEGIN@29 at line 1515
use vars qw( $in_run ); ## No, not Enron;)
# spent 20µs making 1 call to IPC::Run::BEGIN@1515 # spent 14µs making 1 call to vars::import
1516
1517
# spent 53558s (11.5+53547) within IPC::Run::run which was called 133036 times, avg 403ms/call: # 133035 times (11.5s+53546s) by main::__ANON__[split.pl:88] at line 87 of /home/hejohns/documentsNoSync/22f/490/gradescope-utils/bin/split.pl, avg 403ms/call # once (218µs+831ms) by Gradescope::Color::color_print at line 34 of /home/hejohns/documentsNoSync/22f/490/gradescope-utils/lib/Gradescope/Color.pm
sub run {
151813303651.8ms local $in_run = 1; ## Allow run()-only optimizations.
1519133036420ms13303615460s my IPC::Run $self = start(@_);
# spent 15460s making 133036 calls to IPC::Run::start, avg 116ms/call
152013303689.2ms my $r = eval {
1521133036153ms $self->{clear_ins} = 0;
1522133036623ms13303638084s $self->finish;
# spent 38084s making 133036 calls to IPC::Run::finish, avg 286ms/call
1523 };
152413303638.8ms if ($@) {
1525 my $x = $@;
1526 $self->kill_kill;
1527 die $x;
1528 }
15291330369.68s1330362.86s return $r;
# spent 2.86s making 133036 calls to IPC::Run::DESTROY, avg 22µs/call
1530}
1531
1532=pod
1533
1534=item signal
1535
1536 ## To send it a specific signal by name ("USR1"):
1537 signal $h, "USR1";
1538 $h->signal ( "USR1" );
1539
1540If $signal is provided and defined, sends a signal to all child processes. Try
1541not to send numeric signals, use C<"KILL"> instead of C<9>, for instance.
1542Numeric signals aren't portable.
1543
1544Throws an exception if $signal is undef.
1545
1546This will I<not> clean up the harness, C<finish> it if you kill it.
1547
1548Normally TERM kills a process gracefully (this is what the command line utility
1549C<kill> does by default), INT is sent by one of the keys C<^C>, C<Backspace> or
1550C<E<lt>DelE<gt>>, and C<QUIT> is used to kill a process and make it coredump.
1551
1552The C<HUP> signal is often used to get a process to "restart", rereading
1553config files, and C<USR1> and C<USR2> for really application-specific things.
1554
1555Often, running C<kill -l> (that's a lower case "L") on the command line will
1556list the signals present on your operating system.
1557
1558B<WARNING>: The signal subsystem is not at all portable. We *may* offer
1559to simulate C<TERM> and C<KILL> on some operating systems, submit code
1560to me if you want this.
1561
1562B<WARNING 2>: Up to and including perl v5.6.1, doing almost anything in a
1563signal handler could be dangerous. The most safe code avoids all
1564mallocs and system calls, usually by preallocating a flag before
1565entering the signal handler, altering the flag's value in the
1566handler, and responding to the changed value in the main system:
1567
1568 my $got_usr1 = 0;
1569 sub usr1_handler { ++$got_signal }
1570
1571 $SIG{USR1} = \&usr1_handler;
1572 while () { sleep 1; print "GOT IT" while $got_usr1--; }
1573
1574Even this approach is perilous if ++ and -- aren't atomic on your system
1575(I've never heard of this on any modern CPU large enough to run perl).
1576
1577=cut
1578
1579sub signal {
1580 my IPC::Run $self = shift;
1581
1582 local $cur_self = $self;
1583
1584 $self->_kill_kill_kill_pussycat_kill unless @_;
1585
1586 Carp::cluck "Ignoring extra parameters passed to kill()" if @_ > 1;
1587
1588 my ($signal) = @_;
1589 croak "Undefined signal passed to signal" unless defined $signal;
1590 for ( grep $_->{PID} && !defined $_->{RESULT}, @{ $self->{KIDS} } ) {
1591 _debug "sending $signal to $_->{PID}"
1592 if _debugging;
1593 kill $signal, $_->{PID}
1594 or _debugging && _debug "$! sending $signal to $_->{PID}";
1595 }
1596
1597 return;
1598}
1599
1600=pod
1601
1602=item kill_kill
1603
1604 ## To kill off a process:
1605 $h->kill_kill;
1606 kill_kill $h;
1607
1608 ## To specify the grace period other than 30 seconds:
1609 kill_kill $h, grace => 5;
1610
1611 ## To send QUIT instead of KILL if a process refuses to die:
1612 kill_kill $h, coup_d_grace => "QUIT";
1613
1614Sends a C<TERM>, waits for all children to exit for up to 30 seconds, then
1615sends a C<KILL> to any that survived the C<TERM>.
1616
1617Will wait for up to 30 more seconds for the OS to successfully C<KILL> the
1618processes.
1619
1620The 30 seconds may be overridden by setting the C<grace> option, this
1621overrides both timers.
1622
1623The harness is then cleaned up.
1624
1625The doubled name indicates that this function may kill again and avoids
1626colliding with the core Perl C<kill> function.
1627
1628Returns a 1 if the C<TERM> was sufficient, or a 0 if C<KILL> was
1629required. Throws an exception if C<KILL> did not permit the children
1630to be reaped.
1631
1632B<NOTE>: The grace period is actually up to 1 second longer than that
1633given. This is because the granularity of C<time> is 1 second. Let me
1634know if you need finer granularity, we can leverage Time::HiRes here.
1635
1636B<Win32>: Win32 does not know how to send real signals, so C<TERM> is
1637a full-force kill on Win32. Thus all talk of grace periods, etc. do
1638not apply to Win32.
1639
1640=cut
1641
1642sub kill_kill {
1643 my IPC::Run $self = shift;
1644
1645 my %options = @_;
1646 my $grace = $options{grace};
1647 $grace = 30 unless defined $grace;
1648 ++$grace; ## Make grace time a _minimum_
1649
1650 my $coup_d_grace = $options{coup_d_grace};
1651 $coup_d_grace = "KILL" unless defined $coup_d_grace;
1652
1653 delete $options{$_} for qw( grace coup_d_grace );
1654 Carp::cluck "Ignoring unknown options for kill_kill: ",
1655 join " ", keys %options
1656 if keys %options;
1657
1658 if (Win32_MODE) {
1659 # immediate brutal death for Win32
1660 # TERM has unfortunate side-effects
1661 $self->signal("KILL")
1662 }
1663 else {
1664 $self->signal("TERM");
1665 }
1666
1667 my $quitting_time = time + $grace;
1668 my $delay = 0.01;
1669 my $accum_delay;
1670
1671 my $have_killed_before;
1672
1673 while () {
1674 ## delay first to yield to other processes
1675 select undef, undef, undef, $delay;
1676 $accum_delay += $delay;
1677
1678 $self->reap_nb;
1679 last unless $self->_running_kids;
1680
1681 if ( $accum_delay >= $grace * 0.8 ) {
1682 ## No point in checking until delay has grown some.
1683 if ( time >= $quitting_time ) {
1684 if ( !$have_killed_before ) {
1685 $self->signal($coup_d_grace);
1686 $have_killed_before = 1;
1687 $quitting_time += $grace;
1688 $delay = 0.01;
1689 $accum_delay = 0;
1690 next;
1691 }
1692 croak "Unable to reap all children, even after KILLing them";
1693 }
1694 }
1695
1696 $delay *= 2;
1697 $delay = 0.5 if $delay >= 0.5;
1698 }
1699
1700 $self->_cleanup;
1701 return $have_killed_before;
1702}
1703
1704=pod
1705
1706=item harness
1707
1708Takes a harness specification and returns a harness. This harness is
1709blessed in to IPC::Run, allowing you to use method call syntax for
1710run(), start(), et al if you like.
1711
1712harness() is provided so that you can pre-build harnesses if you
1713would like to, but it's not required..
1714
1715You may proceed to run(), start() or pump() after calling harness() (pump()
1716calls start() if need be). Alternatively, you may pass your
1717harness specification to run() or start() and let them harness() for
1718you. You can't pass harness specifications to pump(), though.
1719
1720=cut
1721
1722##
1723## Notes: I've avoided handling a scalar that doesn't look like an
1724## opcode as a here document or as a filename, though I could DWIM
1725## those. I'm not sure that the advantages outweigh the danger when
1726## the DWIMer guesses wrong.
1727##
1728## TODO: allow user to spec default shell. Hmm, globally, in the
1729## lexical scope hash, or per instance? 'Course they can do that
1730## now by using a [...] to hold the command.
1731##
17321200nsmy $harness_id = 0;
1733
1734
# spent 24.9s (12.0+12.9) within IPC::Run::harness which was called 133036 times, avg 187µs/call: # 133036 times (12.0s+12.9s) by IPC::Run::start at line 2799, avg 187µs/call
sub harness {
173513303619.0ms my $options;
173613303660.3ms if ( @_ && ref $_[-1] eq 'HASH' ) {
1737 $options = pop;
1738 require Data::Dumper;
1739 carp "Passing in options as a hash is deprecated:\n", Data::Dumper::Dumper($options);
1740 }
1741
1742 # local $IPC::Run::debug = $options->{debug}
1743 # if $options && defined $options->{debug};
1744
174513303629.1ms my @args;
1746133036268ms if ( @_ == 1 && !ref $_[0] ) {
1747 if (Win32_MODE) {
1748 my $command = $ENV{ComSpec} || 'cmd';
1749 @args = ( [ $command, '/c', win32_parse_cmd_line $_[0] ] );
1750 }
1751 else {
1752 @args = ( [ qw( sh -c ), @_ ] );
1753 }
1754 }
1755 elsif ( @_ > 1 && !grep ref $_, @_ ) {
1756 @args = ( [@_] );
1757 }
1758 else {
1759532144449ms @args = map { !defined $_ ? bless(\$_, 'IPC::Run::Undef') : $_ } @_;
1760 }
1761
176213303638.9ms my @errs; # Accum errors, emit them when done.
1763
1764 my $succinct; # set if no redir ops are required yet. Cleared
1765 # if an op is seen.
1766
1767 my $cur_kid; # references kid or handle being parsed
176813303631.6ms my $next_kid_close_stdin = 0;
1769
177013303620.3ms my $assumed_fd = 0; # fd to assume in succinct mode (no redir ops)
177113303619.0ms my $handle_num = 0; # 1... is which handle we're parsing
1772
1773133036554ms my IPC::Run $self = bless {}, __PACKAGE__;
1774
177513303635.6ms local $cur_self = $self;
1776
1777133036133ms $self->{ID} = ++$harness_id;
177813303677.1ms $self->{IOS} = [];
177913303670.8ms $self->{KIDS} = [];
178013303661.7ms $self->{PIPES} = [];
178113303669.7ms $self->{PTYS} = {};
178213303670.0ms $self->{STATE} = _newed;
1783
178413303624.1ms if ($options) {
1785 $self->{$_} = $options->{$_} for keys %$options;
1786 }
1787
1788133036181ms1330361.40s _debug "****** harnessing *****" if _debugging;
# spent 1.40s making 133036 calls to IPC::Run::Debug::_debugging, avg 11µs/call
1789
1790133036214ms my $first_parse;
179113303626.2ms local $_;
179213303646.1ms my $arg_count = @args;
179313303649.0ms while (@args) {
1794266072198ms for ( shift @args ) {
179526607283.4ms eval {
179626607233.5ms $first_parse = 1;
1797266072154ms2660722.03s _debug( "parsing ", _debugstrings($_) ) if _debugging;
# spent 2.03s making 266072 calls to IPC::Run::Debug::_debugging, avg 8µs/call
1798
1799 REPARSE:
18002660725.18s11973242.21s if ( ref eq 'ARRAY'
# spent 1.52s making 399108 calls to UNIVERSAL::isa, avg 4µs/call # spent 690ms making 798216 calls to IPC::Run::CORE:match, avg 865ns/call
1801 || UNIVERSAL::isa( $_, 'IPC::Run::Win32Process' )
1802 || ( !$cur_kid && ref eq 'CODE' ) ) {
180313303625.5ms croak "Process control symbol ('|', '&') missing" if $cur_kid;
1804133036176ms133036117ms croak "Can't spawn a subroutine on Win32"
# spent 117ms making 133036 calls to constant::__ANON__[constant.pm:192], avg 878ns/call
1805 if Win32_MODE && ref eq "CODE";
1806 $cur_kid = {
1807 TYPE => 'cmd',
1808 VAL => $_,
1809133036426ms NUM => @{ $self->{KIDS} } + 1,
1810 OPS => [],
1811 PID => '',
1812 RESULT => undef,
1813 };
1814
181513303624.8ms unshift @{ $cur_kid->{OPS} }, {
1816 TYPE => 'close',
1817 KFD => 0,
1818 } if $next_kid_close_stdin;
181913303620.2ms $next_kid_close_stdin = 0;
1820
182113303693.6ms push @{ $self->{KIDS} }, $cur_kid;
182213303636.7ms $succinct = 1;
1823 }
1824
1825 elsif ( UNIVERSAL::isa( $_, 'IPC::Run::IO' ) ) {
1826 push @{ $self->{IOS} }, $_;
1827 $cur_kid = undef;
1828 $succinct = 1;
1829 }
1830
1831 elsif ( UNIVERSAL::isa( $_, 'IPC::Run::Timer' ) ) {
1832 push @{ $self->{TIMERS} }, $_;
1833 $cur_kid = undef;
1834 $succinct = 1;
1835 }
1836
1837 elsif (/^(\d*)>&(\d+)$/) {
1838 croak "No command before '$_'" unless $cur_kid;
1839 push @{ $cur_kid->{OPS} }, {
1840 TYPE => 'dup',
1841 KFD1 => $2,
1842 KFD2 => length $1 ? $1 : 1,
1843 };
1844 _debug "redirect operators now required" if _debugging_details;
1845 $succinct = !$first_parse;
1846 }
1847
1848 elsif (/^(\d*)<&(\d+)$/) {
1849 croak "No command before '$_'" unless $cur_kid;
1850 push @{ $cur_kid->{OPS} }, {
1851 TYPE => 'dup',
1852 KFD1 => $2,
1853 KFD2 => length $1 ? $1 : 0,
1854 };
1855 $succinct = !$first_parse;
1856 }
1857
1858 elsif (/^(\d*)<&-$/) {
1859 croak "No command before '$_'" unless $cur_kid;
1860 push @{ $cur_kid->{OPS} }, {
1861 TYPE => 'close',
1862 KFD => length $1 ? $1 : 0,
1863 };
1864 $succinct = !$first_parse;
1865 }
1866
1867 elsif (/^(\d*) (<pipe)() () () $/x
1868 || /^(\d*) (<pty) ((?:\s+\S+)?) (<) () $/x
1869 || /^(\d*) (<) () () (.*)$/x ) {
187013303630.2ms croak "No command before '$_'" unless $cur_kid;
1871
187213303644.6ms $succinct = !$first_parse;
1873
1874133036659ms my $type = $2 . $4;
1875
187613303689.2ms my $kfd = length $1 ? $1 : 0;
1877
187813303624.6ms my $pty_id;
187913303645.6ms if ( $type eq '<pty<' ) {
1880 $pty_id = length $3 ? $3 : '0';
1881 ## do the require here to cause early error reporting
1882 require IO::Pty;
1883 ## Just flag the pyt's existence for now. It'll be
1884 ## converted to a real IO::Pty by _open_pipes.
1885 $self->{PTYS}->{$pty_id} = undef;
1886 }
1887
1888133036247ms my $source = $5;
1889
189013303628.4ms my @filters;
1891 my $binmode;
1892
189313303655.4ms unless ( length $source ) {
189413303699.3ms if ( !$succinct ) {
1895 while ( @args > 1
1896 && ( ( ref $args[1] && !UNIVERSAL::isa $args[1], "IPC::Run::Timer" ) || UNIVERSAL::isa $args[0], "IPC::Run::binmode_pseudo_filter" ) ) {
1897 if ( UNIVERSAL::isa $args[0], "IPC::Run::binmode_pseudo_filter" ) {
1898 $binmode = shift(@args)->();
1899 }
1900 else {
1901 push @filters, shift @args;
1902 }
1903 }
1904 }
190513303664.7ms $source = shift @args;
1906133036178ms133036293ms croak "'$_' missing a source" if _empty $source;
# spent 293ms making 133036 calls to IPC::Run::_empty, avg 2µs/call
1907
1908 _debug(
1909133036125ms1330361.12s 'Kid ', $cur_kid->{NUM}, "'s input fd ", $kfd,
# spent 1.12s making 133036 calls to IPC::Run::Debug::_debugging_details, avg 8µs/call
1910 ' has ', scalar(@filters), ' filters.'
1911 ) if _debugging_details && @filters;
1912 }
1913
1914133036486ms1330365.69s my IPC::Run::IO $pipe = IPC::Run::IO->_new_internal( $type, $kfd, $pty_id, $source, $binmode, @filters );
# spent 5.69s making 133036 calls to IPC::Run::IO::_new_internal, avg 43µs/call
1915
1916133036410ms13303637.4ms if ( ( ref $source eq 'GLOB' || UNIVERSAL::isa $source, 'IO::Handle' )
# spent 37.4ms making 133036 calls to UNIVERSAL::isa, avg 281ns/call
1917 && $type !~ /^<p(ty<|ipe)$/ ) {
1918 _debug "setting DONT_CLOSE" if _debugging_details;
1919 $pipe->{DONT_CLOSE} = 1; ## this FD is not closed by us.
1920 _dont_inherit($source) if Win32_MODE;
1921 }
1922
1923133036123ms push @{ $cur_kid->{OPS} }, $pipe;
1924 }
1925
1926 elsif (
1927 /^() (>>?) (&) () (.*)$/x
1928 || /^() (&) (>pipe) () () $/x
1929 || /^() (>pipe)(&) () () $/x
1930 || /^(\d*)() (>pipe) () () $/x
1931 || /^() (&) (>pty) ( \w*)> () $/x
1932## TODO: || /^() (>pty) (\d*)> (&) () $/x
1933 || /^(\d*)() (>pty) ( \w*)> () $/x
1934 || /^() (&) (>>?) () (.*)$/x || /^(\d*)() (>>?) () (.*)$/x
1935 ) {
1936 croak "No command before '$_'" unless $cur_kid;
1937
1938 $succinct = !$first_parse;
1939
1940 my $type = (
1941 $2 eq '>pipe' || $3 eq '>pipe' ? '>pipe'
1942 : $2 eq '>pty' || $3 eq '>pty' ? '>pty>'
1943 : '>'
1944 );
1945 my $kfd = length $1 ? $1 : 1;
1946 my $trunc = !( $2 eq '>>' || $3 eq '>>' );
1947 my $pty_id = (
1948 $2 eq '>pty' || $3 eq '>pty'
1949 ? length $4
1950 ? $4
1951 : 0
1952 : undef
1953 );
1954
1955 my $stderr_too =
1956 $2 eq '&'
1957 || $3 eq '&'
1958 || ( !length $1 && substr( $type, 0, 4 ) eq '>pty' );
1959
1960 my $dest = $5;
1961 my @filters;
1962 my $binmode = 0;
1963 unless ( length $dest ) {
1964 if ( !$succinct ) {
1965 ## unshift...shift: '>' filters source...sink left...right
1966 while ( @args > 1
1967 && ( ( ref $args[1] && !UNIVERSAL::isa $args[1], "IPC::Run::Timer" ) || UNIVERSAL::isa $args[0], "IPC::Run::binmode_pseudo_filter" ) ) {
1968 if ( UNIVERSAL::isa $args[0], "IPC::Run::binmode_pseudo_filter" ) {
1969 $binmode = shift(@args)->();
1970 }
1971 else {
1972 unshift @filters, shift @args;
1973 }
1974 }
1975 }
1976
1977 if ( @args && ref $args[0] eq 'IPC::Run::Undef' ) {
1978 require Symbol;
1979 ${ $args[0] } = $dest = Symbol::gensym();
1980 shift @args;
1981 }
1982 else {
1983 $dest = shift @args;
1984 }
1985
1986 _debug(
1987 'Kid ', $cur_kid->{NUM}, "'s output fd ", $kfd,
1988 ' has ', scalar(@filters), ' filters.'
1989 ) if _debugging_details && @filters;
1990
1991 if ( $type eq '>pty>' ) {
1992 ## do the require here to cause early error reporting
1993 require IO::Pty;
1994 ## Just flag the pyt's existence for now. _open_pipes()
1995 ## will new an IO::Pty for each key.
1996 $self->{PTYS}->{$pty_id} = undef;
1997 }
1998 }
1999
2000 croak "'$_' missing a destination" if _empty $dest;
2001 my $pipe = IPC::Run::IO->_new_internal( $type, $kfd, $pty_id, $dest, $binmode, @filters );
2002 $pipe->{TRUNC} = $trunc;
2003
2004 if ( ( UNIVERSAL::isa( $dest, 'GLOB' ) || UNIVERSAL::isa( $dest, 'IO::Handle' ) )
2005 && $type !~ /^>(pty>|pipe)$/ ) {
2006 _debug "setting DONT_CLOSE" if _debugging_details;
2007 $pipe->{DONT_CLOSE} = 1; ## this FD is not closed by us.
2008 }
2009 push @{ $cur_kid->{OPS} }, $pipe;
2010 push @{ $cur_kid->{OPS} }, {
2011 TYPE => 'dup',
2012 KFD1 => 1,
2013 KFD2 => 2,
2014 } if $stderr_too;
2015 }
2016
2017 elsif ( $_ eq "|" ) {
2018 croak "No command before '$_'" unless $cur_kid;
2019 unshift @{ $cur_kid->{OPS} }, {
2020 TYPE => '|',
2021 KFD => 1,
2022 };
2023 $succinct = 1;
2024 $assumed_fd = 1;
2025 $cur_kid = undef;
2026 }
2027
2028 elsif ( $_ eq "&" ) {
2029 croak "No command before '$_'" unless $cur_kid;
2030 $next_kid_close_stdin = 1;
2031 $succinct = 1;
2032 $assumed_fd = 0;
2033 $cur_kid = undef;
2034 }
2035
2036 elsif ( $_ eq 'init' ) {
2037 croak "No command before '$_'" unless $cur_kid;
2038 push @{ $cur_kid->{OPS} }, {
2039 TYPE => 'init',
2040 SUB => shift @args,
2041 };
2042 }
2043
2044 elsif ( !ref $_ ) {
2045 $self->{$_} = shift @args;
2046 }
2047
2048 elsif ( $_ eq 'init' ) {
2049 croak "No command before '$_'" unless $cur_kid;
2050 push @{ $cur_kid->{OPS} }, {
2051 TYPE => 'init',
2052 SUB => shift @args,
2053 };
2054 }
2055
2056 elsif ( $succinct && $first_parse ) {
2057 ## It's not an opcode, and no explicit opcodes have been
2058 ## seen yet, so assume it's a file name.
2059 unshift @args, $_;
2060 if ( !$assumed_fd ) {
2061 $_ = "$assumed_fd<",
2062 }
2063 else {
2064 $_ = "$assumed_fd>",
2065 }
2066 _debug "assuming '", $_, "'" if _debugging_details;
2067 ++$assumed_fd;
2068 $first_parse = 0;
2069 goto REPARSE;
2070 }
2071
2072 else {
2073 croak join(
2074 '',
2075 'Unexpected ',
2076 ( ref() ? $_ : 'scalar' ),
2077 ' in harness() parameter ',
2078 $arg_count - @args
2079 );
2080 }
2081 };
2082266072114ms if ($@) {
2083 push @errs, $@;
2084 _debug 'caught ', $@ if _debugging;
2085 }
2086 }
2087 }
2088
208913303632.9ms die join( '', @errs ) if @errs;
2090
209113303657.4ms $self->{STATE} = _harnessed;
2092
2093 # $self->timeout( $options->{timeout} ) if exists $options->{timeout};
2094133036366ms return $self;
2095}
2096
2097
# spent 45.7s (10.3+35.4) within IPC::Run::_open_pipes which was called 133036 times, avg 343µs/call: # 133036 times (10.3s+35.4s) by IPC::Run::start at line 2828, avg 343µs/call
sub _open_pipes {
209813303639.0ms my IPC::Run $self = shift;
2099
2100133036425ms my @errs;
2101
2102 my @close_on_fail;
2103
2104 ## When a pipe character is seen, a pipe is created. $pipe_read_fd holds
2105 ## the dangling read end of the pipe until we get to the next process.
2106 my $pipe_read_fd;
2107
2108 ## Output descriptors for the last command are shared by all children.
2109 ## @output_fds_accum accumulates the current set of output fds.
2110 my @output_fds_accum;
2111
2112133036553ms13303643.7ms for ( sort keys %{ $self->{PTYS} } ) {
# spent 43.7ms making 133036 calls to IPC::Run::CORE:sort, avg 328ns/call
2113 _debug "opening pty '", $_, "'" if _debugging_details;
2114 my $pty = _pty;
2115 $self->{PTYS}->{$_} = $pty;
2116 }
2117
211813303694.8ms for ( @{ $self->{IOS} } ) {
2119 eval { $_->init; };
2120 if ($@) {
2121 push @errs, $@;
2122 _debug 'caught ', $@ if _debugging;
2123 }
2124 else {
2125 push @close_on_fail, $_;
2126 }
2127 }
2128
2129 ## Loop through the kids and their OPS, interpreting any that require
2130 ## parent-side actions.
2131133036469ms for my $kid ( @{ $self->{KIDS} } ) {
2132133036578ms13303611.2s if ( ref $kid->{VAL} eq 'ARRAY' ) {
# spent 11.2s making 133036 calls to IPC::Run::_search_path, avg 84µs/call
2133 $kid->{PATH} = _search_path $kid->{VAL}->[0];
2134 }
213513303641.3ms if ( defined $pipe_read_fd ) {
2136 _debug "placing write end of pipe on kid $kid->{NUM}'s stdin"
2137 if _debugging_details;
2138 unshift @{ $kid->{OPS} }, {
2139 TYPE => 'PIPE', ## Prevent next loop from triggering on this
2140 KFD => 0,
2141 TFD => $pipe_read_fd,
2142 };
2143 $pipe_read_fd = undef;
2144 }
214513303644.4ms @output_fds_accum = ();
2146133036330ms for my $op ( @{ $kid->{OPS} } ) {
2147
2148 # next if $op->{IS_DEBUG};
214913303644.3ms my $ok = eval {
215013303693.0ms if ( $op->{TYPE} eq '<' ) {
215113303660.6ms my $source = $op->{SOURCE};
21521330361.16s399108120ms if ( !ref $source ) {
# spent 120ms making 399108 calls to UNIVERSAL::isa, avg 302ns/call
2153 _debug(
2154 "kid ", $kid->{NUM}, " to read ", $op->{KFD},
2155 " from '" . $source, "' (read only)"
2156 ) if _debugging_details;
2157 croak "simulated open failure"
2158 if $self->{_simulate_open_failure};
2159 $op->{TFD} = _sysopen( $source, O_RDONLY );
2160 push @close_on_fail, $op->{TFD};
2161 }
2162 elsif (UNIVERSAL::isa( $source, 'GLOB' )
2163 || UNIVERSAL::isa( $source, 'IO::Handle' ) ) {
2164 croak "Unopened filehandle in input redirect for $op->{KFD}"
2165 unless defined fileno $source;
2166 $op->{TFD} = fileno $source;
2167 _debug(
2168 "kid ", $kid->{NUM}, " to read ", $op->{KFD},
2169 " from fd ", $op->{TFD}
2170 ) if _debugging_details;
2171 }
2172 elsif ( UNIVERSAL::isa( $source, 'SCALAR' ) ) {
2173 _debug(
2174 "kid ", $kid->{NUM}, " to read ", $op->{KFD},
217513303690.6ms133036931ms " from SCALAR"
# spent 931ms making 133036 calls to IPC::Run::Debug::_debugging_details, avg 7µs/call
2176 ) if _debugging_details;
2177
2178133036632ms26607220.3s $op->open_pipe( $self->_debug_fd );
# spent 18.6s making 133036 calls to IPC::Run::IO::open_pipe, avg 140µs/call # spent 1.70s making 133036 calls to IPC::Run::_debug_fd, avg 13µs/call
2179133036135ms push @close_on_fail, $op->{KFD}, $op->{FD};
2180
218113303650.4ms my $s = '';
2182133036107ms $op->{KIN_REF} = \$s;
2183 }
2184 elsif ( UNIVERSAL::isa( $source, 'CODE' ) ) {
2185 _debug( 'kid ', $kid->{NUM}, ' to read ', $op->{KFD}, ' from CODE' ) if _debugging_details;
2186
2187 $op->open_pipe( $self->_debug_fd );
2188 push @close_on_fail, $op->{KFD}, $op->{FD};
2189
2190 my $s = '';
2191 $op->{KIN_REF} = \$s;
2192 }
2193 else {
2194 croak( "'" . ref($source) . "' not allowed as a source for input redirection" );
2195 }
2196133036194ms1330361.28s $op->_init_filters;
# spent 1.28s making 133036 calls to IPC::Run::IO::_init_filters, avg 10µs/call
2197 }
2198 elsif ( $op->{TYPE} eq '<pipe' ) {
2199 _debug(
2200 'kid to read ', $op->{KFD},
2201 ' from a pipe IPC::Run opens and returns',
2202 ) if _debugging_details;
2203
2204 my ( $r, $w ) = $op->open_pipe( $self->_debug_fd, $op->{SOURCE} );
2205 _debug "caller will write to ", fileno $op->{SOURCE}
2206 if _debugging_details;
2207
2208 $op->{TFD} = $r;
2209 $op->{FD} = undef; # we don't manage this fd
2210 $op->_init_filters;
2211 }
2212 elsif ( $op->{TYPE} eq '<pty<' ) {
2213 _debug(
2214 'kid to read ', $op->{KFD}, " from pty '", $op->{PTY_ID}, "'",
2215 ) if _debugging_details;
2216
2217 for my $source ( $op->{SOURCE} ) {
2218 if ( UNIVERSAL::isa( $source, 'SCALAR' ) ) {
2219 _debug(
2220 "kid ", $kid->{NUM}, " to read ", $op->{KFD},
2221 " from SCALAR via pty '", $op->{PTY_ID}, "'"
2222 ) if _debugging_details;
2223
2224 my $s = '';
2225 $op->{KIN_REF} = \$s;
2226 }
2227 elsif ( UNIVERSAL::isa( $source, 'CODE' ) ) {
2228 _debug(
2229 "kid ", $kid->{NUM}, " to read ", $op->{KFD},
2230 " from CODE via pty '", $op->{PTY_ID}, "'"
2231 ) if _debugging_details;
2232 my $s = '';
2233 $op->{KIN_REF} = \$s;
2234 }
2235 else {
2236 croak( "'" . ref($source) . "' not allowed as a source for '<pty<' redirection" );
2237 }
2238 }
2239 $op->{FD} = $self->{PTYS}->{ $op->{PTY_ID} }->fileno;
2240 $op->{TFD} = undef; # The fd isn't known until after fork().
2241 $op->_init_filters;
2242 }
2243 elsif ( $op->{TYPE} eq '>' ) {
2244 ## N> output redirection.
2245 my $dest = $op->{DEST};
2246 if ( !ref $dest ) {
2247 _debug(
2248 "kid ", $kid->{NUM}, " to write ", $op->{KFD},
2249 " to '", $dest, "' (write only, create, ",
2250 ( $op->{TRUNC} ? 'truncate' : 'append' ),
2251 ")"
2252 ) if _debugging_details;
2253 croak "simulated open failure"
2254 if $self->{_simulate_open_failure};
2255 $op->{TFD} = _sysopen(
2256 $dest,
2257 ( O_WRONLY | O_CREAT | ( $op->{TRUNC} ? O_TRUNC : O_APPEND ) )
2258 );
2259 if (Win32_MODE) {
2260 ## I have no idea why this is needed to make the current
2261 ## file position survive the gyrations TFD must go
2262 ## through...
2263 POSIX::lseek( $op->{TFD}, 0, POSIX::SEEK_END() );
2264 }
2265 push @close_on_fail, $op->{TFD};
2266 }
2267 elsif ( UNIVERSAL::isa( $dest, 'GLOB' ) ) {
2268 croak("Unopened filehandle in output redirect, command $kid->{NUM}") unless defined fileno $dest;
2269 ## Turn on autoflush, mostly just to flush out
2270 ## existing output.
2271 my $old_fh = select($dest);
2272 $| = 1;
2273 select($old_fh);
2274 $op->{TFD} = fileno $dest;
2275 _debug( 'kid to write ', $op->{KFD}, ' to handle ', $op->{TFD} ) if _debugging_details;
2276 }
2277 elsif ( UNIVERSAL::isa( $dest, 'SCALAR' ) ) {
2278 _debug( "kid ", $kid->{NUM}, " to write $op->{KFD} to SCALAR" ) if _debugging_details;
2279
2280 $op->open_pipe( $self->_debug_fd );
2281 push @close_on_fail, $op->{FD}, $op->{TFD};
2282 $$dest = '' if $op->{TRUNC};
2283 }
2284 elsif ( UNIVERSAL::isa( $dest, 'CODE' ) ) {
2285 _debug("kid $kid->{NUM} to write $op->{KFD} to CODE") if _debugging_details;
2286
2287 $op->open_pipe( $self->_debug_fd );
2288 push @close_on_fail, $op->{FD}, $op->{TFD};
2289 }
2290 else {
2291 croak( "'" . ref($dest) . "' not allowed as a sink for output redirection" );
2292 }
2293 $output_fds_accum[ $op->{KFD} ] = $op;
2294 $op->_init_filters;
2295 }
2296
2297 elsif ( $op->{TYPE} eq '>pipe' ) {
2298 ## N> output redirection to a pipe we open, but don't select()
2299 ## on.
2300 _debug(
2301 "kid ", $kid->{NUM}, " to write ", $op->{KFD},
2302 ' to a pipe IPC::Run opens and returns'
2303 ) if _debugging_details;
2304
2305 my ( $r, $w ) = $op->open_pipe( $self->_debug_fd, $op->{DEST} );
2306 _debug "caller will read from ", fileno $op->{DEST}
2307 if _debugging_details;
2308
2309 $op->{TFD} = $w;
2310 $op->{FD} = undef; # we don't manage this fd
2311 $op->_init_filters;
2312
2313 $output_fds_accum[ $op->{KFD} ] = $op;
2314 }
2315 elsif ( $op->{TYPE} eq '>pty>' ) {
2316 my $dest = $op->{DEST};
2317 if ( UNIVERSAL::isa( $dest, 'SCALAR' ) ) {
2318 _debug(
2319 "kid ", $kid->{NUM}, " to write ", $op->{KFD},
2320 " to SCALAR via pty '", $op->{PTY_ID}, "'"
2321 ) if _debugging_details;
2322
2323 $$dest = '' if $op->{TRUNC};
2324 }
2325 elsif ( UNIVERSAL::isa( $dest, 'CODE' ) ) {
2326 _debug(
2327 "kid ", $kid->{NUM}, " to write ", $op->{KFD},
2328 " to CODE via pty '", $op->{PTY_ID}, "'"
2329 ) if _debugging_details;
2330 }
2331 else {
2332 croak( "'" . ref($dest) . "' not allowed as a sink for output redirection" );
2333 }
2334
2335 $op->{FD} = $self->{PTYS}->{ $op->{PTY_ID} }->fileno;
2336 $op->{TFD} = undef; # The fd isn't known until after fork().
2337 $output_fds_accum[ $op->{KFD} ] = $op;
2338 $op->_init_filters;
2339 }
2340 elsif ( $op->{TYPE} eq '|' ) {
2341 _debug( "pipelining $kid->{NUM} and " . ( $kid->{NUM} + 1 ) ) if _debugging_details;
2342 ( $pipe_read_fd, $op->{TFD} ) = _pipe;
2343 if (Win32_MODE) {
2344 _dont_inherit($pipe_read_fd);
2345 _dont_inherit( $op->{TFD} );
2346 }
2347 @output_fds_accum = ();
2348 }
2349 elsif ( $op->{TYPE} eq '&' ) {
2350 @output_fds_accum = ();
2351 } # end if $op->{TYPE} tree
235213303655.0ms 1;
2353 }; # end eval
235413303665.1ms unless ($ok) {
2355 push @errs, $@;
2356 _debug 'caught ', $@ if _debugging;
2357 }
2358 } # end for ( OPS }
2359 }
2360
236113303633.7ms if (@errs) {
2362 for (@close_on_fail) {
2363 _close($_);
2364 $_ = undef;
2365 }
2366 for ( keys %{ $self->{PTYS} } ) {
2367 next unless $self->{PTYS}->{$_};
2368 close $self->{PTYS}->{$_};
2369 $self->{PTYS}->{$_} = undef;
2370 }
2371 die join( '', @errs );
2372 }
2373
2374 ## give all but the last child all of the output file descriptors
2375 ## These will be reopened (and thus rendered useless) if the child
2376 ## dup2s on to these descriptors, since we unshift these. This way
2377 ## each process emits output to the same file descriptors that the
2378 ## last child will write to. This is probably not quite correct,
2379 ## since each child should write to the file descriptors inherited
2380 ## from the parent.
2381 ## TODO: fix the inheritance of output file descriptors.
2382 ## NOTE: This sharing of OPS among kids means that we can't easily put
2383 ## a kid number in each OPS structure to ping the kid when all ops
2384 ## have closed (when $self->{PIPES} has emptied). This means that we
2385 ## need to scan the KIDS whenever @{$self->{PIPES}} is empty to see
2386 ## if there any of them are still alive.
2387133036352ms for ( my $num = 0; $num < $#{ $self->{KIDS} }; ++$num ) {
2388 for ( reverse @output_fds_accum ) {
2389 next unless defined $_;
2390 _debug(
2391 'kid ', $self->{KIDS}->[$num]->{NUM}, ' also to write ', $_->{KFD},
2392 ' to ', ref $_->{DEST}
2393 ) if _debugging_details;
2394 unshift @{ $self->{KIDS}->[$num]->{OPS} }, $_;
2395 }
2396 }
2397
2398 ## Open the debug pipe if we need it
2399 ## Create the list of PIPES we need to scan and the bit vectors needed by
2400 ## select(). Do this first so that _cleanup can _clobber() them if an
2401 ## exception occurs.
240213303670.6ms @{ $self->{PIPES} } = ();
2403133036104ms $self->{RIN} = '';
240413303664.1ms $self->{WIN} = '';
240513303650.4ms $self->{EIN} = '';
2406 ## PIN is a vec()tor that indicates who's paused.
2407133036153ms $self->{PIN} = '';
2408133036101ms for my $kid ( @{ $self->{KIDS} } ) {
240913303697.3ms for ( @{ $kid->{OPS} } ) {
241013303695.0ms if ( defined $_->{FD} ) {
2411 _debug(
2412 'kid ', $kid->{NUM}, '[', $kid->{PID}, "]'s ", $_->{KFD},
2413 ' is my ', $_->{FD}
241413303695.9ms1330361.09s ) if _debugging_details;
# spent 1.09s making 133036 calls to IPC::Run::Debug::_debugging_details, avg 8µs/call
2415133036974ms133036329ms vec( $self->{ $_->{TYPE} =~ /^</ ? 'WIN' : 'RIN' }, $_->{FD}, 1 ) = 1;
# spent 329ms making 133036 calls to IPC::Run::CORE:match, avg 2µs/call
2416
2417 # vec( $self->{EIN}, $_->{FD}, 1 ) = 1;
241813303668.4ms push @{ $self->{PIPES} }, $_;
2419 }
2420 }
2421 }
2422
2423133036274ms for my $io ( @{ $self->{IOS} } ) {
2424 my $fd = $io->fileno;
2425 vec( $self->{RIN}, $fd, 1 ) = 1 if $io->mode =~ /r/;
2426 vec( $self->{WIN}, $fd, 1 ) = 1 if $io->mode =~ /w/;
2427
2428 # vec( $self->{EIN}, $fd, 1 ) = 1;
2429 push @{ $self->{PIPES} }, $io;
2430 }
2431
2432 ## Put filters on the end of the filter chains to read & write the pipes.
2433 ## Clear pipe states
2434133036475ms for my $pipe ( @{ $self->{PIPES} } ) {
2435133036177ms $pipe->{SOURCE_EMPTY} = 0;
243613303641.8ms $pipe->{PAUSED} = 0;
2437133036429ms13303642.3ms if ( $pipe->{TYPE} =~ /^>/ ) {
# spent 42.3ms making 133036 calls to IPC::Run::CORE:match, avg 318ns/call
2438 my $pipe_reader = sub {
2439 my ( undef, $out_ref ) = @_;
2440
2441 return undef unless defined $pipe->{FD};
2442 return 0 unless vec( $self->{ROUT}, $pipe->{FD}, 1 );
2443
2444 vec( $self->{ROUT}, $pipe->{FD}, 1 ) = 0;
2445
2446 _debug_desc_fd( 'reading from', $pipe ) if _debugging_details;
2447 my $in = eval { _read( $pipe->{FD} ) };
2448 if ($@) {
2449 $in = '';
2450 ## IO::Pty throws the Input/output error if the kid dies.
2451 ## read() throws the bad file descriptor message if the
2452 ## kid dies on Win32.
2453 die $@
2454 unless $@ =~ $_EIO
2455 || ( $@ =~ /input or output/ && $^O =~ /aix/ )
2456 || ( Win32_MODE && $@ =~ /Bad file descriptor/ );
2457 }
2458
2459 unless ( length $in ) {
2460 $self->_clobber($pipe);
2461 return undef;
2462 }
2463
2464 ## Protect the position so /.../g matches may be used.
2465 my $pos = pos $$out_ref;
2466 $$out_ref .= $in;
2467 pos($$out_ref) = $pos;
2468 return 1;
2469 };
2470 ## Input filters are the last filters
2471 push @{ $pipe->{FILTERS} }, $pipe_reader;
2472 push @{ $self->{TEMP_FILTERS} }, $pipe_reader;
2473 }
2474 else {
2475
# spent 31.3s (5.69+25.6) within IPC::Run::__ANON__[/home/hejohns/perl5/lib/perl5/IPC/Run.pm:2514] which was called 266092 times, avg 118µs/call: # 266092 times (5.69s+25.6s) by IPC::Run::get_more_input at line 4162, avg 118µs/call
my $pipe_writer = sub {
2476266092336ms my ( $in_ref, $out_ref ) = @_;
247726609295.9ms return undef unless defined $pipe->{FD};
2478 return 0
2479 unless vec( $self->{WOUT}, $pipe->{FD}, 1 )
2480266092215ms || $pipe->{PAUSED};
2481
24822660921.04s vec( $self->{WOUT}, $pipe->{FD}, 1 ) = 0;
2483
2484266092123ms if ( !length $$in_ref ) {
2485266072700ms2660720s if ( !defined get_more_input ) {
# spent 6.56s making 266072 calls to IPC::Run::get_more_input, avg 25µs/call, recursion: max depth 1, sum of overlapping time 6.56s
2486133036390ms13303613.4s $self->_clobber($pipe);
# spent 13.4s making 133036 calls to IPC::Run::_clobber, avg 101µs/call
2487133036617ms return undef;
2488 }
2489 }
2490
249113305642.2ms unless ( length $$in_ref ) {
2492 unless ( $pipe->{PAUSED} ) {
2493 _debug_desc_fd( 'pausing', $pipe ) if _debugging_details;
2494 vec( $self->{WIN}, $pipe->{FD}, 1 ) = 0;
2495
2496 # vec( $self->{EIN}, $pipe->{FD}, 1 ) = 0;
2497 vec( $self->{PIN}, $pipe->{FD}, 1 ) = 1;
2498 $pipe->{PAUSED} = 1;
2499 }
2500 return 0;
2501 }
2502133056230ms1330561.61s _debug_desc_fd( 'writing to', $pipe ) if _debugging_details;
# spent 1.61s making 133056 calls to IPC::Run::Debug::_debugging_details, avg 12µs/call
2503
250413305679.4ms if ( length $$in_ref && $$in_ref ) {
2505133056433ms1330564.01s my $c = _write( $pipe->{FD}, $$in_ref );
# spent 4.01s making 133056 calls to IPC::Run::_write, avg 30µs/call
2506133056174ms substr( $$in_ref, 0, $c, '' );
2507 }
2508 else {
2509 $self->_clobber($pipe);
2510 return undef;
2511 }
2512
2513133056680ms return 1;
2514133036802ms };
2515 ## Output filters are the first filters
251613303687.7ms unshift @{ $pipe->{FILTERS} }, $pipe_writer;
2517133036101ms push @{ $self->{TEMP_FILTERS} }, $pipe_writer;
2518 }
2519 }
2520}
2521
2522sub _dup2_gently {
2523 ## A METHOD, NOT A FUNCTION, NEEDS $self!
2524 my IPC::Run $self = shift;
2525 my ( $files, $fd1, $fd2 ) = @_;
2526 ## Moves TFDs that are using the destination fd out of the
2527 ## way before calling _dup2
2528 for (@$files) {
2529 next unless defined $_->{TFD};
2530 $_->{TFD} = _dup( $_->{TFD} ) if $_->{TFD} == $fd2;
2531 }
2532 if ( defined $self->{DEBUG_FD} && $self->{DEBUG_FD} == $fd2 ) {
2533 $self->{DEBUG_FD} = _dup $self->{DEBUG_FD};
2534 $fds{$self->{DEBUG_FD}}{needed} = 1;
2535 }
2536 _dup2_rudely( $fd1, $fd2 );
2537}
2538
2539=pod
2540
2541=item close_terminal
2542
2543This is used as (or in) an init sub to cast off the bonds of a controlling
2544terminal. It must precede all other redirection ops that affect
2545STDIN, STDOUT, or STDERR to be guaranteed effective.
2546
2547=cut
2548
2549sub close_terminal {
2550 ## Cast of the bonds of a controlling terminal
2551
2552 # Just in case the parent (I'm talking to you FCGI) had these tied.
2553 untie *STDIN;
2554 untie *STDOUT;
2555 untie *STDERR;
2556
2557 POSIX::setsid() || croak "POSIX::setsid() failed";
2558 _debug "closing stdin, out, err"
2559 if _debugging_details;
2560 close STDIN;
2561 close STDERR;
2562 close STDOUT;
2563}
2564
2565sub _do_kid_and_exit {
2566 my IPC::Run $self = shift;
2567 my ($kid) = @_;
2568
2569 my ( $s1, $s2 );
2570 if ( $] < 5.008 ) {
2571 ## For unknown reasons, placing these two statements in the eval{}
2572 ## causes the eval {} to not catch errors after they are executed in
2573 ## perl 5.6.0, godforsaken version that it is...not sure about 5.6.1.
2574 ## Part of this could be that these symbols get destructed when
2575 ## exiting the eval, and that destruction might be what's (wrongly)
2576 ## confusing the eval{}, allowing the exception to propagate.
2577 $s1 = Symbol::gensym();
2578 $s2 = Symbol::gensym();
2579 }
2580
2581 eval {
2582 local $cur_self = $self;
2583
2584 if (_debugging) {
2585 _set_child_debug_name(
2586 ref $kid->{VAL} eq "CODE"
2587 ? "CODE"
2588 : basename( $kid->{VAL}->[0] )
2589 );
2590 }
2591
2592 ## close parent FD's first so they're out of the way.
2593 ## Don't close STDIN, STDOUT, STDERR: they should be inherited or
2594 ## overwritten below.
2595 do { $_->{needed} = 1 for @fds{0..2} }
2596 unless $self->{noinherit};
2597
2598 $fds{$self->{SYNC_WRITER_FD}}{needed} = 1;
2599 $fds{$self->{DEBUG_FD}}{needed} = 1 if defined $self->{DEBUG_FD};
2600
2601 $fds{$_->{TFD}}{needed} = 1
2602 foreach grep { defined $_->{TFD} } @{$kid->{OPS} };
2603
2604
2605 ## TODO: use the forthcoming IO::Pty to close the terminal and
2606 ## make the first pty for this child the controlling terminal.
2607 ## This will also make it so that pty-laden kids don't cause
2608 ## other kids to lose stdin/stdout/stderr.
2609
2610 if ( %{ $self->{PTYS} } ) {
2611 ## Clean up the parent's fds.
2612 for ( keys %{ $self->{PTYS} } ) {
2613 _debug "Cleaning up parent's ptty '$_'" if _debugging_details;
2614 $self->{PTYS}->{$_}->make_slave_controlling_terminal;
2615 my $slave = $self->{PTYS}->{$_}->slave;
2616 delete $fds{$self->{PTYS}->{$_}->fileno};
2617 close $self->{PTYS}->{$_};
2618 $self->{PTYS}->{$_} = $slave;
2619 }
2620
2621 close_terminal;
2622 delete @fds{0..2};
2623 }
2624
2625 for my $sibling ( @{ $self->{KIDS} } ) {
2626 for ( @{ $sibling->{OPS} } ) {
2627 if ( $_->{TYPE} =~ /^.pty.$/ ) {
2628 $_->{TFD} = $self->{PTYS}->{ $_->{PTY_ID} }->fileno;
2629 $fds{$_->{TFD}}{needed} = 1;
2630 }
2631
2632 # for ( $_->{FD}, ( $sibling != $kid ? $_->{TFD} : () ) ) {
2633 # if ( defined $_ && ! $closed[$_] && ! $needed[$_] ) {
2634 # _close( $_ );
2635 # $closed[$_] = 1;
2636 # $_ = undef;
2637 # }
2638 # }
2639 }
2640 }
2641
2642 ## This is crude: we have no way of keeping track of browsing all open
2643 ## fds, so we scan to a fairly high fd.
2644 _debug "open fds: ", join " ", keys %fds if _debugging_details;
2645
2646 _close( $_ ) foreach grep { ! $fds{$_}{needed} } keys %fds;
2647
2648 for ( @{ $kid->{OPS} } ) {
2649 if ( defined $_->{TFD} ) {
2650
2651 # we're always creating KFD
2652 $fds{$_->{KFD}}{needed} = 1;
2653
2654 unless ( $_->{TFD} == $_->{KFD} ) {
2655 $self->_dup2_gently( $kid->{OPS}, $_->{TFD}, $_->{KFD} );
2656 $fds{$_->{TFD}}{lazy_close} = 1;
2657 } else {
2658 my $fd = _dup($_->{TFD});
2659 $self->_dup2_gently( $kid->{OPS}, $fd, $_->{KFD} );
2660 _close($fd);
2661 }
2662 }
2663 elsif ( $_->{TYPE} eq 'dup' ) {
2664 $self->_dup2_gently( $kid->{OPS}, $_->{KFD1}, $_->{KFD2} )
2665 unless $_->{KFD1} == $_->{KFD2};
2666 $fds{$_->{KFD2}}{needed} = 1;
2667 }
2668 elsif ( $_->{TYPE} eq 'close' ) {
2669 for ( $_->{KFD} ) {
2670 if ( $fds{$_} ) {
2671 _close($_);
2672 $_ = undef;
2673 }
2674 }
2675 }
2676 elsif ( $_->{TYPE} eq 'init' ) {
2677 $_->{SUB}->();
2678 }
2679 }
2680
2681 _close( $_ ) foreach grep { $fds{$_}{lazy_close} } keys %fds;
2682
2683 if ( ref $kid->{VAL} ne 'CODE' ) {
2684 open $s1, ">&=$self->{SYNC_WRITER_FD}"
2685 or croak "$! setting filehandle to fd SYNC_WRITER_FD";
2686 fcntl $s1, F_SETFD, 1;
2687
2688 if ( defined $self->{DEBUG_FD} ) {
2689 open $s2, ">&=$self->{DEBUG_FD}"
2690 or croak "$! setting filehandle to fd DEBUG_FD";
2691 fcntl $s2, F_SETFD, 1;
2692 }
2693
2694 if (_debugging) {
2695 my @cmd = ( $kid->{PATH}, @{ $kid->{VAL} }[ 1 .. $#{ $kid->{VAL} } ] );
2696 _debug 'execing ', join " ", map { /[\s\"]/ ? "'$_'" : $_ } @cmd;
2697 }
2698
2699 die "exec failed: simulating exec() failure"
2700 if $self->{_simulate_exec_failure};
2701
2702 _exec $kid->{PATH}, @{ $kid->{VAL} }[ 1 .. $#{ $kid->{VAL} } ];
2703
2704 croak "exec failed: $!";
2705 }
2706 };
2707 if ($@) {
2708 _write $self->{SYNC_WRITER_FD}, $@;
2709 ## Avoid DESTROY.
2710 POSIX::_exit(1);
2711 }
2712
2713 ## We must be executing code in the child, otherwise exec() would have
2714 ## prevented us from being here.
2715 _close $self->{SYNC_WRITER_FD};
2716 _debug 'calling fork()ed CODE ref' if _debugging;
2717 POSIX::close $self->{DEBUG_FD} if defined $self->{DEBUG_FD};
2718 ## TODO: Overload CORE::GLOBAL::exit...
2719 $kid->{VAL}->();
2720
2721 ## There are bugs in perl closures up to and including 5.6.1
2722 ## that may keep this next line from having any effect, and it
2723 ## won't have any effect if our caller has kept a copy of it, but
2724 ## this may cause the closure to be cleaned up. Maybe.
2725 $kid->{VAL} = undef;
2726
2727 ## Use POSIX::_exit to avoid global destruction, since this might
2728 ## cause DESTROY() to be called on objects created in the parent
2729 ## and thus cause double cleanup. For instance, if DESTROY() unlinks
2730 ## a file in the child, we don't want the parent to suddenly miss
2731 ## it.
2732 POSIX::_exit(0);
2733}
2734
2735=pod
2736
2737=item start
2738
2739 $h = start(
2740 \@cmd, \$in, \$out, ...,
2741 timeout( 30, name => "process timeout" ),
2742 $stall_timeout = timeout( 10, name => "stall timeout" ),
2743 );
2744
2745 $h = start \@cmd, '<', \$in, '|', \@cmd2, ...;
2746
2747start() accepts a harness or harness specification and returns a harness
2748after building all of the pipes and launching (via fork()/exec(), or, maybe
2749someday, spawn()) all the child processes. It does not send or receive any
2750data on the pipes, see pump() and finish() for that.
2751
2752You may call harness() and then pass it's result to start() if you like,
2753but you only need to if it helps you structure or tune your application.
2754If you do call harness(), you may skip start() and proceed directly to
2755pump.
2756
2757start() also starts all timers in the harness. See L<IPC::Run::Timer>
2758for more information.
2759
2760start() flushes STDOUT and STDERR to help you avoid duplicate output.
2761It has no way of asking Perl to flush all your open filehandles, so
2762you are going to need to flush any others you have open. Sorry.
2763
2764Here's how if you don't want to alter the state of $| for your
2765filehandle:
2766
2767 $ofh = select HANDLE; $of = $|; $| = 1; $| = $of; select $ofh;
2768
2769If you don't mind leaving output unbuffered on HANDLE, you can do
2770the slightly shorter
2771
2772 $ofh = select HANDLE; $| = 1; select $ofh;
2773
2774Or, you can use IO::Handle's flush() method:
2775
2776 use IO::Handle;
2777 flush HANDLE;
2778
2779Perl needs the equivalent of C's fflush( (FILE *)NULL ).
2780
2781=cut
2782
2783
# spent 15460s (12.5+15448) within IPC::Run::start which was called 133036 times, avg 116ms/call: # 133036 times (12.5s+15448s) by IPC::Run::run at line 1519, avg 116ms/call
sub start {
2784
2785 # $SIG{__DIE__} = sub { my $s = shift; Carp::cluck $s; die $s };
278613303621.6ms my $options;
278713303691.4ms if ( @_ && ref $_[-1] eq 'HASH' ) {
2788 $options = pop;
2789 require Data::Dumper;
2790 carp "Passing in options as a hash is deprecated:\n", Data::Dumper::Dumper($options);
2791 }
2792
279313303617.9ms my IPC::Run $self;
279413303671.5ms if ( @_ == 1 && UNIVERSAL::isa( $_[0], __PACKAGE__ ) ) {
2795 $self = shift;
2796 $self->{$_} = $options->{$_} for keys %$options;
2797 }
2798 else {
2799133036411ms13303624.9s $self = harness( @_, $options ? $options : () );
# spent 24.9s making 133036 calls to IPC::Run::harness, avg 187µs/call
2800 }
2801
280213303636.6ms local $cur_self = $self;
2803
280413303671.9ms $self->kill_kill if $self->{STATE} == _started;
2805
280613303699.1ms1330361.02s _debug "** starting" if _debugging;
# spent 1.02s making 133036 calls to IPC::Run::Debug::_debugging, avg 8µs/call
2807
2808133036209ms $_->{RESULT} = undef for @{ $self->{KIDS} };
2809
2810 ## Assume we're not being called from &run. It will correct our
2811 ## assumption if need be. This affects whether &_select_loop clears
2812 ## input queues to '' when they're empty.
281313303664.0ms $self->{clear_ins} = 1;
2814
281513303698.5ms13303647.0ms IPC::Run::Win32Helper::optimize $self
# spent 47.0ms making 133036 calls to constant::__ANON__[constant.pm:192], avg 353ns/call
2816 if Win32_MODE && $in_run;
2817
281813303623.4ms my @errs;
2819
2820133036228ms for ( @{ $self->{TIMERS} } ) {
2821 eval { $_->start };
2822 if ($@) {
2823 push @errs, $@;
2824 _debug 'caught ', $@ if _debugging;
2825 }
2826 }
2827
2828266072285ms13303645.7s eval { $self->_open_pipes };
# spent 45.7s making 133036 calls to IPC::Run::_open_pipes, avg 343µs/call
282913303626.5ms if ($@) {
2830 push @errs, $@;
2831 _debug 'caught ', $@ if _debugging;
2832 }
2833
283413303656.3ms if ( !@errs ) {
2835 ## This is a bit of a hack, we should do it for all open filehandles.
2836 ## Since there's no way I know of to enumerate open filehandles, we
2837 ## autoflush STDOUT and STDERR. This is done so that the children don't
2838 ## inherit output buffers chock full o' redundant data. It's really
2839 ## confusing to track that down.
28406651801.56s266072153ms { my $ofh = select STDOUT; my $of = $|; $| = 1; $| = $of; select $ofh; }
# spent 153ms making 266072 calls to IPC::Run::CORE:select, avg 574ns/call
2841931252877ms26607252.1ms { my $ofh = select STDERR; my $of = $|; $| = 1; $| = $of; select $ofh; }
# spent 52.1ms making 266072 calls to IPC::Run::CORE:select, avg 196ns/call
2842133036111ms for my $kid ( @{ $self->{KIDS} } ) {
284313303659.2ms $kid->{RESULT} = undef;
2844 _debug "child: ", _debugstrings( $kid->{VAL} )
2845133036110ms1330361.01s if _debugging_details;
# spent 1.01s making 133036 calls to IPC::Run::Debug::_debugging_details, avg 8µs/call
284613303668.4ms eval {
2847 croak "simulated failure of fork"
284813303627.0ms if $self->{_simulate_fork_failure};
2849133036558ms26607215370s unless (Win32_MODE) {
# spent 15370s making 133036 calls to IPC::Run::_spawn, avg 116ms/call # spent 52.0ms making 133036 calls to constant::__ANON__[constant.pm:192], avg 391ns/call
2850 $self->_spawn($kid);
2851 }
2852 else {
2853## TODO: Test and debug spawning code. Someday.
2854 _debug(
2855 'spawning ',
2856 _debugstrings(
2857 [
2858 $kid->{PATH},
2859 @{ $kid->{VAL} }[ 1 .. $#{ $kid->{VAL} } ]
2860 ]
2861 )
2862 ) if $kid->{PATH} && _debugging;
2863 ## The external kid wouldn't know what to do with it anyway.
2864 ## This is only used by the "helper" pump processes on Win32.
2865 _dont_inherit( $self->{DEBUG_FD} );
2866 ( $kid->{PID}, $kid->{PROCESS} ) = IPC::Run::Win32Helper::win32_spawn(
2867 ref( $kid->{VAL} ) eq "ARRAY"
2868 ? [ $kid->{PATH}, @{ $kid->{VAL} }[ 1 .. $#{ $kid->{VAL} } ] ]
2869 : $kid->{VAL},
2870 $kid->{OPS},
2871 );
2872 _debug "spawn() = ", $kid->{PID} if _debugging;
2873 if ($self->{_sleep_after_win32_spawn}) {
2874 sleep $self->{_sleep_after_win32_spawn};
2875 _debug "after sleep $self->{_sleep_after_win32_spawn}"
2876 if _debugging;
2877 }
2878 }
2879 };
2880133036548ms if ($@) {
2881 push @errs, $@;
2882 _debug 'caught ', $@ if _debugging;
2883 }
2884 }
2885 }
2886
2887 ## Close all those temporary filehandles that the kids needed.
2888133036462ms for my $pty ( values %{ $self->{PTYS} } ) {
2889 close $pty->slave;
2890 }
2891
289213303637.5ms my @closed;
2893133036123ms for my $kid ( @{ $self->{KIDS} } ) {
2894133036490ms for ( @{ $kid->{OPS} } ) {
2895133036107ms my $close_it = eval {
2896 defined $_->{TFD}
2897 && !$_->{DONT_CLOSE}
2898 && !$closed[ $_->{TFD} ]
2899 && ( !Win32_MODE || !$_->{RECV_THROUGH_TEMP_FILE} ) ## Win32 hack
2900133036670ms133036100ms };
# spent 100ms making 133036 calls to constant::__ANON__[constant.pm:192], avg 753ns/call
290113303619.9ms if ($@) {
2902 push @errs, $@;
2903 _debug 'caught ', $@ if _debugging;
2904 }
2905133036131ms if ( $close_it || $@ ) {
290613303648.4ms eval {
2907133036256ms1330364.41s _close( $_->{TFD} );
# spent 4.41s making 133036 calls to IPC::Run::_close, avg 33µs/call
2908133036256ms $closed[ $_->{TFD} ] = 1;
290913303692.0ms $_->{TFD} = undef;
2910 };
291113303627.9ms if ($@) {
2912 push @errs, $@;
2913 _debug 'caught ', $@ if _debugging;
2914 }
2915 }
2916 }
2917 }
291813303660.1ms confess "gak!" unless defined $self->{PIPES};
2919
292013303640.6ms if (@errs) {
2921 eval { $self->_cleanup };
2922 warn $@ if $@;
2923 die join( '', @errs );
2924 }
2925
2926133036159ms $self->{STATE} = _started;
29271330361.24s return $self;
2928}
2929
2930=item adopt
2931
2932Experimental feature. NOT FUNCTIONAL YET, NEED TO CLOSE FDS BETTER IN CHILDREN. SEE t/adopt.t for a test suite.
2933
2934=cut
2935
2936sub adopt {
2937 my IPC::Run $self = shift;
2938
2939 for my $adoptee (@_) {
2940 push @{ $self->{IOS} }, @{ $adoptee->{IOS} };
2941 ## NEED TO RENUMBER THE KIDS!!
2942 push @{ $self->{KIDS} }, @{ $adoptee->{KIDS} };
2943 push @{ $self->{PIPES} }, @{ $adoptee->{PIPES} };
2944 $self->{PTYS}->{$_} = $adoptee->{PTYS}->{$_} for keys %{ $adoptee->{PYTS} };
2945 push @{ $self->{TIMERS} }, @{ $adoptee->{TIMERS} };
2946 $adoptee->{STATE} = _finished;
2947 }
2948}
2949
2950
# spent 13.4s (4.32+9.09) within IPC::Run::_clobber which was called 133036 times, avg 101µs/call: # 133036 times (4.32s+9.09s) by IPC::Run::__ANON__[/home/hejohns/perl5/lib/perl5/IPC/Run.pm:2514] at line 2486, avg 101µs/call
sub _clobber {
295113303635.0ms my IPC::Run $self = shift;
295213303638.2ms my ($file) = @_;
2953133036163ms1330361.47s _debug_desc_fd( "closing", $file ) if _debugging_details;
# spent 1.47s making 133036 calls to IPC::Run::Debug::_debugging_details, avg 11µs/call
295413303691.7ms my $doomed = $file->{FD};
29551330361.33s133036682ms my $dir = $file->{TYPE} =~ /^</ ? 'WIN' : 'RIN';
# spent 682ms making 133036 calls to IPC::Run::CORE:match, avg 5µs/call
2956133036334ms vec( $self->{$dir}, $doomed, 1 ) = 0;
2957
2958 # vec( $self->{EIN}, $doomed, 1 ) = 0;
2959133036269ms vec( $self->{PIN}, $doomed, 1 ) = 0;
29601330361.67s3991086.95s if ( $file->{TYPE} =~ /^(.)pty.$/ ) {
# spent 6.65s making 133036 calls to IPC::Run::IO::close, avg 50µs/call # spent 274ms making 133036 calls to UNIVERSAL::isa, avg 2µs/call # spent 17.6ms making 133036 calls to IPC::Run::CORE:match, avg 132ns/call
2961 if ( $1 eq '>' ) {
2962 ## Only close output ptys. This is so that ptys as inputs are
2963 ## never autoclosed, which would risk losing data that was
2964 ## in the slave->parent queue.
2965 _debug_desc_fd "closing pty", $file if _debugging_details;
2966 close $self->{PTYS}->{ $file->{PTY_ID} }
2967 if defined $self->{PTYS}->{ $file->{PTY_ID} };
2968 $self->{PTYS}->{ $file->{PTY_ID} } = undef;
2969 }
2970 }
2971 elsif ( UNIVERSAL::isa( $file, 'IPC::Run::IO' ) ) {
2972 $file->close unless $file->{DONT_CLOSE};
2973 }
2974 else {
2975 _close($doomed);
2976 }
2977
2978 @{ $self->{PIPES} } = grep
2979 defined $_->{FD} && ( $_->{TYPE} ne $file->{TYPE} || $_->{FD} ne $doomed ),
2980133036405ms @{ $self->{PIPES} };
2981
2982133036502ms $file->{FD} = undef;
2983}
2984
2985
# spent 38059s (31.1+38028) within IPC::Run::_select_loop which was called 133036 times, avg 286ms/call: # 133036 times (31.1s+38028s) by IPC::Run::finish at line 3538, avg 286ms/call
sub _select_loop {
298613303632.4ms my IPC::Run $self = shift;
2987
298813303622.7ms my $io_occurred;
2989
299013303643.0ms my $not_forever = 0.01;
2991
2992 SELECT:
2993133036140ms133036136ms while ( $self->pumpable ) {
# spent 136ms making 133036 calls to IPC::Run::pumpable, avg 1µs/call
2994666625308ms if ( $io_occurred && $self->{break_on_io} ) {
2995 _debug "exiting _select(): io occurred and break_on_io set"
2996 if _debugging_details;
2997 last;
2998 }
2999
3000666625402ms my $timeout = $self->{non_blocking} ? 0 : undef;
3001
3002666625321ms if ( @{ $self->{TIMERS} } ) {
3003 my $now = time;
3004 my $time_left;
3005 for ( @{ $self->{TIMERS} } ) {
3006 next unless $_->is_running;
3007 $time_left = $_->check($now);
3008 ## Return when a timer expires
3009 return if defined $time_left && !$time_left;
3010 $timeout = $time_left
3011 if !defined $timeout || $time_left < $timeout;
3012 }
3013 }
3014
3015 ##
3016 ## See if we can unpause any input channels
3017 ##
3018666625143ms my $paused = 0;
3019
3020666625657ms for my $file ( @{ $self->{PIPES} } ) {
302126609486.8ms next unless $file->{PAUSED} && $file->{TYPE} =~ /^</;
3022
3023 _debug_desc_fd( "checking for more input", $file ) if _debugging_details;
3024 my $did;
3025 1 while $did = $file->_do_filters($self);
3026 if ( defined $file->{FD} && !defined($did) || $did ) {
3027 _debug_desc_fd( "unpausing", $file ) if _debugging_details;
3028 $file->{PAUSED} = 0;
3029 vec( $self->{WIN}, $file->{FD}, 1 ) = 1;
3030
3031 # vec( $self->{EIN}, $file->{FD}, 1 ) = 1;
3032 vec( $self->{PIN}, $file->{FD}, 1 ) = 0;
3033 }
3034 else {
3035 ## This gets incremented occasionally when the IO channel
3036 ## was actually closed. That's a bug, but it seems mostly
3037 ## harmless: it causes us to exit if break_on_io, or to set
3038 ## the timeout to not be forever. I need to fix it, though.
3039 ++$paused;
3040 }
3041 }
3042
3043666625523ms6666255.75s if (_debugging_details) {
# spent 5.75s making 666625 calls to IPC::Run::Debug::_debugging_details, avg 9µs/call
3044 my $map = join(
3045 '',
3046 map {
3047 my $out;
3048 $out = 'r' if vec( $self->{RIN}, $_, 1 );
3049 $out = $out ? 'b' : 'w' if vec( $self->{WIN}, $_, 1 );
3050 $out = 'p' if !$out && vec( $self->{PIN}, $_, 1 );
3051 $out = $out ? uc($out) : 'x' if vec( $self->{EIN}, $_, 1 );
3052 $out = '-' unless $out;
3053 $out;
3054 } ( 0 .. 1024 )
3055 );
3056 $map =~ s/((?:[a-zA-Z-]|\([^\)]*\)){12,}?)-*$/$1/;
3057 _debug 'fds for select: ', $map if _debugging_details;
3058 }
3059
3060 ## _do_filters may have closed our last fd, and we need to see if
3061 ## we have I/O, or are just waiting for children to exit.
3062666625685ms66662590.1s my $p = $self->pumpable;
# spent 90.1s making 666625 calls to IPC::Run::pumpable, avg 135µs/call
3063666625116ms last unless $p;
3064666621382ms if ( $p != 0 && ( !defined $timeout || $timeout > 0.1 ) ) {
3065 ## No I/O will wake the select loop up, but we have children
3066 ## lingering, so we need to poll them with a short timeout.
3067 ## Otherwise, assume more input will be coming.
3068666621225ms $timeout = $not_forever;
3069666621258ms $not_forever *= 2;
3070666621189ms $not_forever = 0.5 if $not_forever >= 0.5;
3071 }
3072
3073 ## Make sure we don't block forever in select() because inputs are
3074 ## paused.
3075666621134ms if ( !defined $timeout && !( @{ $self->{PIPES} } - $paused ) ) {
3076 ## Need to return if we're in pump and all input is paused, or
3077 ## we'll loop until all inputs are unpaused, which is darn near
3078 ## forever. And a day.
3079 if ( $self->{break_on_io} ) {
3080 _debug "exiting _select(): no I/O to do and timeout=forever"
3081 if _debugging;
3082 last;
3083 }
3084
3085 ## Otherwise, assume more input will be coming.
3086 $timeout = $not_forever;
3087 $not_forever *= 2;
3088 $not_forever = 0.5 if $not_forever >= 0.5;
3089 }
3090
3091666621500ms6666215.60s _debug 'timeout=', defined $timeout ? $timeout : 'forever'
# spent 5.60s making 666621 calls to IPC::Run::Debug::_debugging_details, avg 8µs/call
3092 if _debugging_details;
3093
3094666621164ms my $nfound;
309566662137768s133324237761s unless (Win32_MODE) {
# spent 37761s making 666621 calls to IPC::Run::CORE:sselect, avg 56.6ms/call # spent 293ms making 666621 calls to constant::__ANON__[constant.pm:192], avg 440ns/call
3096 $nfound = select(
3097 $self->{ROUT} = $self->{RIN},
3098 $self->{WOUT} = $self->{WIN},
3099 $self->{EOUT} = $self->{EIN},
3100 $timeout
3101 );
3102 }
3103 else {
3104 my @in = map $self->{$_}, qw( RIN WIN EIN );
3105 ## Win32's select() on Win32 seems to die if passed vectors of
3106 ## all 0's. Need to report this when I get back online.
3107 for (@in) {
3108 $_ = undef unless index( ( unpack "b*", $_ ), 1 ) >= 0;
3109 }
3110
3111 $nfound = select(
3112 $self->{ROUT} = $in[0],
3113 $self->{WOUT} = $in[1],
3114 $self->{EOUT} = $in[2],
3115 $timeout
3116 );
3117
3118 for ( $self->{ROUT}, $self->{WOUT}, $self->{EOUT} ) {
3119 $_ = "" unless defined $_;
3120 }
3121 }
3122666621763ms last if !$nfound && $self->{non_blocking};
3123
3124666621217ms if ( $nfound < 0 ) {
3125 if ( $!{EINTR} ) {
3126
3127 # Caught a signal before any FD went ready. Ensure that
3128 # the bit fields reflect "no FDs ready".
3129 $self->{ROUT} = $self->{WOUT} = $self->{EOUT} = '';
3130 $nfound = 0;
3131 }
3132 else {
3133 croak "$! in select";
3134 }
3135 }
3136 ## TODO: Analyze the EINTR failure mode and see if this patch
3137 ## is adequate and optimal.
3138 ## TODO: Add an EINTR test to the test suite.
3139
31406666211.64s66662110.1s if (_debugging_details) {
# spent 10.1s making 666621 calls to IPC::Run::Debug::_debugging_details, avg 15µs/call
3141 my $map = join(
3142 '',
3143 map {
3144 my $out;
3145 $out = 'r' if vec( $self->{ROUT}, $_, 1 );
3146 $out = $out ? 'b' : 'w' if vec( $self->{WOUT}, $_, 1 );
3147 $out = $out ? uc($out) : 'x' if vec( $self->{EOUT}, $_, 1 );
3148 $out = '-' unless $out;
3149 $out;
3150 } ( 0 .. 128 )
3151 );
3152 $map =~ s/((?:[a-zA-Z-]|\([^\)]*\)){12,}?)-*$/$1/;
3153 _debug "selected ", $map;
3154 }
3155
3156 ## Need to copy since _clobber alters @{$self->{PIPES}}.
3157 ## TODO: Rethink _clobber(). Rethink $file->{PAUSED}, too.
3158666621963ms my @pipes = @{ $self->{PIPES} };
31596666212.93s932715155s $io_occurred = $_->poll($self) ? 1 : $io_occurred for @pipes;
# spent 107s making 666621 calls to IPC::Run::pumpable, avg 160µs/call # spent 48.4s making 266094 calls to IPC::Run::IO::poll, avg 182µs/call
3160
3161 # FILE:
3162 # for my $pipe ( @pipes ) {
3163 # ## Pipes can be shared among kids. If another kid closes the
3164 # ## pipe, then it's {FD} will be undef. Also, on Win32, pipes can
3165 # ## be optimized to be files, in which case the FD is left undef
3166 # ## so we don't try to select() on it.
3167 # if ( $pipe->{TYPE} =~ /^>/
3168 # && defined $pipe->{FD}
3169 # && vec( $self->{ROUT}, $pipe->{FD}, 1 )
3170 # ) {
3171 # _debug_desc_fd( "filtering data from", $pipe ) if _debugging_details;
3172 #confess "phooey" unless UNIVERSAL::isa( $pipe, "IPC::Run::IO" );
3173 # $io_occurred = 1 if $pipe->_do_filters( $self );
3174 #
3175 # next FILE unless defined $pipe->{FD};
3176 # }
3177 #
3178 # ## On Win32, pipes to the child can be optimized to be files
3179 # ## and FD left undefined so we won't select on it.
3180 # if ( $pipe->{TYPE} =~ /^</
3181 # && defined $pipe->{FD}
3182 # && vec( $self->{WOUT}, $pipe->{FD}, 1 )
3183 # ) {
3184 # _debug_desc_fd( "filtering data to", $pipe ) if _debugging_details;
3185 # $io_occurred = 1 if $pipe->_do_filters( $self );
3186 #
3187 # next FILE unless defined $pipe->{FD};
3188 # }
3189 #
3190 # if ( defined $pipe->{FD} && vec( $self->{EOUT}, $pipe->{FD}, 1 ) ) {
3191 # ## BSD seems to sometimes raise the exceptional condition flag
3192 # ## when a pipe is closed before we read it's last data. This
3193 # ## causes spurious warnings and generally renders the exception
3194 # ## mechanism useless for our purposes. The exception
3195 # ## flag semantics are too variable (they're device driver
3196 # ## specific) for me to easily map to any automatic action like
3197 # ## warning or croaking (try running v0.42 if you don't believe me
3198 # ## :-).
3199 # warn "Exception on descriptor $pipe->{FD}";
3200 # }
3201 # }
3202 }
3203
3204133036386ms return;
3205}
3206
3207
# spent 15.4s (9.92+5.45) within IPC::Run::_cleanup which was called 133036 times, avg 116µs/call: # 133036 times (9.92s+5.45s) by IPC::Run::finish at line 3540, avg 116µs/call
sub _cleanup {
320813303622.3ms my IPC::Run $self = shift;
320913303699.8ms1330361.05s _debug "cleaning up" if _debugging_details;
# spent 1.05s making 133036 calls to IPC::Run::Debug::_debugging_details, avg 8µs/call
3210
3211133036215ms for ( values %{ $self->{PTYS} } ) {
3212 next unless ref $_;
3213 eval {
3214 _debug "closing slave fd ", fileno $_->slave if _debugging_data;
3215 close $_->slave;
3216 };
3217 carp $@ . " while closing ptys" if $@;
3218 eval {
3219 _debug "closing master fd ", fileno $_ if _debugging_data;
3220 close $_;
3221 };
3222 carp $@ . " closing ptys" if $@;
3223 }
3224
322513303679.1ms133036940ms _debug "cleaning up pipes" if _debugging_details;
# spent 940ms making 133036 calls to IPC::Run::Debug::_debugging_details, avg 7µs/call
3226 ## _clobber modifies PIPES
322713303699.8ms $self->_clobber( $self->{PIPES}->[0] ) while @{ $self->{PIPES} };
3228
3229133036241ms for my $kid ( @{ $self->{KIDS} } ) {
323013303670.7ms133036923ms _debug "cleaning up kid ", $kid->{NUM} if _debugging_details;
# spent 923ms making 133036 calls to IPC::Run::Debug::_debugging_details, avg 7µs/call
3231133036158ms if ( !length $kid->{PID} ) {
3232 _debug 'never ran child ', $kid->{NUM}, ", can't reap"
3233 if _debugging;
3234 for my $op ( @{ $kid->{OPS} } ) {
3235 _close( $op->{TFD} )
3236 if defined $op->{TFD} && !defined $op->{TEMP_FILE_HANDLE};
3237 }
3238 }
3239 elsif ( !defined $kid->{RESULT} ) {
3240 _debug 'reaping child ', $kid->{NUM}, ' (pid ', $kid->{PID}, ')'
3241 if _debugging;
3242 my $pid = waitpid $kid->{PID}, 0;
3243 $kid->{RESULT} = $?;
3244 _debug 'reaped ', $pid, ', $?=', $kid->{RESULT}
3245 if _debugging;
3246 }
3247
3248 # if ( defined $kid->{DEBUG_FD} ) {
3249 # die;
3250 # @{$kid->{OPS}} = grep
3251 # ! defined $_->{KFD} || $_->{KFD} != $kid->{DEBUG_FD},
3252 # @{$kid->{OPS}};
3253 # $kid->{DEBUG_FD} = undef;
3254 # }
3255
325613303684.8ms133036947ms _debug "cleaning up filters" if _debugging_details;
# spent 947ms making 133036 calls to IPC::Run::Debug::_debugging_details, avg 7µs/call
3257133036115ms for my $op ( @{ $kid->{OPS} } ) {
3258 @{ $op->{FILTERS} } = grep {
325926607249.7ms my $filter = $_;
3260266072365ms !grep $filter == $_, @{ $self->{TEMP_FILTERS} };
3261133036631ms } @{ $op->{FILTERS} };
3262 }
3263
326413303697.5ms for my $op ( @{ $kid->{OPS} } ) {
3265133036925ms266072613ms $op->_cleanup($self) if UNIVERSAL::isa( $op, "IPC::Run::IO" );
# spent 339ms making 133036 calls to IPC::Run::IO::_cleanup, avg 3µs/call # spent 274ms making 133036 calls to UNIVERSAL::isa, avg 2µs/call
3266 }
3267 }
326813303676.2ms $self->{STATE} = _finished;
32691330363.96s @{ $self->{TEMP_FILTERS} } = ();
3270133036105ms133036982ms _debug "done cleaning up" if _debugging_details;
# spent 982ms making 133036 calls to IPC::Run::Debug::_debugging_details, avg 7µs/call
3271
327213303656.6ms POSIX::close $self->{DEBUG_FD} if defined $self->{DEBUG_FD};
3273133036723ms $self->{DEBUG_FD} = undef;
3274}
3275
3276=pod
3277
3278=item pump
3279
3280 pump $h;
3281 $h->pump;
3282
3283Pump accepts a single parameter harness. It blocks until it delivers some
3284input or receives some output. It returns TRUE if there is still input or
3285output to be done, FALSE otherwise.
3286
3287pump() will automatically call start() if need be, so you may call harness()
3288then proceed to pump() if that helps you structure your application.
3289
3290If pump() is called after all harnessed activities have completed, a "process
3291ended prematurely" exception to be thrown. This allows for simple scripting
3292of external applications without having to add lots of error handling code at
3293each step of the script:
3294
3295 $h = harness \@smbclient, \$in, \$out, $err;
3296
3297 $in = "cd /foo\n";
3298 $h->pump until $out =~ /^smb.*> \Z/m;
3299 die "error cding to /foo:\n$out" if $out =~ "ERR";
3300 $out = '';
3301
3302 $in = "mget *\n";
3303 $h->pump until $out =~ /^smb.*> \Z/m;
3304 die "error retrieving files:\n$out" if $out =~ "ERR";
3305
3306 $h->finish;
3307
3308 warn $err if $err;
3309
3310=cut
3311
3312sub pump {
3313 die "pump() takes only a single harness as a parameter"
3314 unless @_ == 1 && UNIVERSAL::isa( $_[0], __PACKAGE__ );
3315
3316 my IPC::Run $self = shift;
3317
3318 local $cur_self = $self;
3319
3320 _debug "** pumping"
3321 if _debugging;
3322
3323 # my $r = eval {
3324 $self->start if $self->{STATE} < _started;
3325 croak "process ended prematurely" unless $self->pumpable;
3326
3327 $self->{auto_close_ins} = 0;
3328 $self->{break_on_io} = 1;
3329 $self->_select_loop;
3330 return $self->pumpable;
3331
3332 # };
3333 # if ( $@ ) {
3334 # my $x = $@;
3335 # _debug $x if _debugging && $x;
3336 # eval { $self->_cleanup };
3337 # warn $@ if $@;
3338 # die $x;
3339 # }
3340 # return $r;
3341}
3342
3343=pod
3344
3345=item pump_nb
3346
3347 pump_nb $h;
3348 $h->pump_nb;
3349
3350"pump() non-blocking", pumps if anything's ready to be pumped, returns
3351immediately otherwise. This is useful if you're doing some long-running
3352task in the foreground, but don't want to starve any child processes.
3353
3354=cut
3355
3356sub pump_nb {
3357 my IPC::Run $self = shift;
3358
3359 $self->{non_blocking} = 1;
3360 my $r = eval { $self->pump };
3361 $self->{non_blocking} = 0;
3362 die $@ if $@;
3363 return $r;
3364}
3365
3366=pod
3367
3368=item pumpable
3369
3370Returns TRUE if calling pump() won't throw an immediate "process ended
3371prematurely" exception. This means that there are open I/O channels or
3372active processes. May yield the parent processes' time slice for 0.01
3373second if all pipes are to the child and all are paused. In this case
3374we can't tell if the child is dead, so we yield the processor and
3375then attempt to reap the child in a nonblocking way.
3376
3377=cut
3378
3379## Undocumented feature (don't depend on it outside this module):
3380## returns -1 if we have I/O channels open, or >0 if no I/O channels
3381## open, but we have kids running. This allows the select loop
3382## to poll for child exit.
3383
# spent 200s (18.4+181) within IPC::Run::pumpable which was called 1732354 times, avg 115µs/call: # 666625 times (6.95s+83.2s) by IPC::Run::_select_loop at line 3062, avg 135µs/call # 666621 times (9.81s+96.9s) by IPC::Run::_select_loop at line 3159, avg 160µs/call # 133036 times (644ms+1.05s) by IPC::Run::finish at line 3538, avg 13µs/call # 133036 times (829ms+0s) by IPC::Run::finish at line 3537, avg 6µs/call # 133036 times (136ms+0s) by IPC::Run::_select_loop at line 2993, avg 1µs/call
sub pumpable {
33841732354326ms my IPC::Run $self = shift;
3385
3386 ## There's a catch-22 we can get in to if there is only one pipe left
3387 ## open to the child and it's paused (ie the SCALAR it's tied to
3388 ## is ''). It's paused, so we're not select()ing on it, so we don't
3389 ## check it to see if the child attached to it is alive and it stays
3390 ## in @{$self->{PIPES}} forever. So, if all pipes are paused, see if
3391 ## we can reap the child.
339217323543.45s return -1 if grep !$_->{PAUSED}, @{ $self->{PIPES} };
3393
3394 ## See if the child is dead.
339510671301.23s106713031.1s $self->reap_nb;
# spent 31.1s making 1067130 calls to IPC::Run::reap_nb, avg 29µs/call
339610671301.71s10671301.73s return 0 unless $self->_running_kids;
# spent 1.73s making 1067130 calls to IPC::Run::_running_kids, avg 2µs/call
3397
3398 ## If we reap_nb and it's not dead yet, yield to it to see if it
3399 ## exits.
3400 ##
3401 ## A better solution would be to unpause all the pipes, but I tried that
3402 ## and it never errored on linux. Sigh.
3403801065131s801065127s select undef, undef, undef, 0.0001;
# spent 127s making 801065 calls to IPC::Run::CORE:sselect, avg 159µs/call
3404
3405 ## try again
34068010651.07s80106520.0s $self->reap_nb;
# spent 20.0s making 801065 calls to IPC::Run::reap_nb, avg 25µs/call
3407801065668ms8010651.05s return 0 unless $self->_running_kids;
# spent 1.05s making 801065 calls to IPC::Run::_running_kids, avg 1µs/call
3408
34098010582.24s return -1; ## There are pipes waiting
3410}
3411
3412
# spent 2.79s within IPC::Run::_running_kids which was called 1868195 times, avg 1µs/call: # 1067130 times (1.73s+0s) by IPC::Run::pumpable at line 3396, avg 2µs/call # 801065 times (1.05s+0s) by IPC::Run::pumpable at line 3407, avg 1µs/call
sub _running_kids {
34131868195295ms my IPC::Run $self = shift;
3414 return grep
3415 defined $_->{PID} && !defined $_->{RESULT},
341618681956.78s @{ $self->{KIDS} };
3417}
3418
3419=pod
3420
3421=item reap_nb
3422
3423Attempts to reap child processes, but does not block.
3424
3425Does not currently take any parameters, one day it will allow specific
3426children to be reaped.
3427
3428Only call this from a signal handler if your C<perl> is recent enough
3429to have safe signal handling (5.6.1 did not, IIRC, but it was being discussed
3430on perl5-porters). Calling this (or doing any significant work) in a signal
3431handler on older C<perl>s is asking for seg faults.
3432
3433=cut
3434
34351100nsmy $still_runnings;
3436
3437
# spent 51.1s (28.2+22.9) within IPC::Run::reap_nb which was called 1868195 times, avg 27µs/call: # 1067130 times (17.0s+14.1s) by IPC::Run::pumpable at line 3395, avg 29µs/call # 801065 times (11.2s+8.82s) by IPC::Run::pumpable at line 3406, avg 25µs/call
sub reap_nb {
34381868195323ms my IPC::Run $self = shift;
3439
34401868195424ms local $cur_self = $self;
3441
3442 ## No more pipes, look to see if all the kids yet live, reaping those
3443 ## that haven't. I'd use $SIG{CHLD}/$SIG{CLD}, but that's broken
3444 ## on older (SYSV) platforms and perhaps less portable than waitpid().
3445 ## This could be slow with a lot of kids, but that's rare and, well,
3446 ## a lot of kids is slow in the first place.
3447 ## Oh, and this keeps us from reaping other children the process
3448 ## may have spawned.
344918681956.53s for my $kid ( @{ $self->{KIDS} } ) {
345018681951.74s18681951.29s if (Win32_MODE) {
# spent 1.29s making 1868195 calls to constant::__ANON__[constant.pm:192], avg 692ns/call
3451 next if !defined $kid->{PROCESS} || defined $kid->{RESULT};
3452 unless ( $kid->{PROCESS}->Wait(0) ) {
3453 _debug "kid $kid->{NUM} ($kid->{PID}) still running"
3454 if _debugging_details;
3455 next;
3456 }
3457
3458 _debug "kid $kid->{NUM} ($kid->{PID}) exited"
3459 if _debugging;
3460
3461 $kid->{PROCESS}->GetExitCode( $kid->{RESULT} )
3462 or croak "$! while GetExitCode()ing for Win32 process";
3463
3464 unless ( defined $kid->{RESULT} ) {
3465 $kid->{RESULT} = "0 but true";
3466 $? = $kid->{RESULT} = 0x0F;
3467 }
3468 else {
3469 $? = $kid->{RESULT} << 8;
3470 }
3471 }
3472 else {
347318681951.36s next if !defined $kid->{PID} || defined $kid->{RESULT};
3474173515910.7s17351595.29s my $pid = waitpid $kid->{PID}, POSIX::WNOHANG();
# spent 5.29s making 1735159 calls to IPC::Run::CORE:waitpid, avg 3µs/call
34751735159256ms unless ($pid) {
347616021231.04s160212314.1s _debug "$kid->{NUM} ($kid->{PID}) still running"
# spent 14.1s making 1602123 calls to IPC::Run::Debug::_debugging_details, avg 9µs/call
3477 if _debugging_details;
34781602123738ms next;
3479 }
3480
348113303663.0ms if ( $pid < 0 ) {
3482 _debug "No such process: $kid->{PID}\n" if _debugging;
3483 $kid->{RESULT} = "unknown result, unknown PID";
3484 }
3485 else {
3486133036173ms1330361.28s _debug "kid $kid->{NUM} ($kid->{PID}) exited"
# spent 1.28s making 133036 calls to IPC::Run::Debug::_debugging, avg 10µs/call
3487 if _debugging;
3488
3489 confess "waitpid returned the wrong PID: $pid instead of $kid->{PID}"
349013303677.4ms unless $pid == $kid->{PID};
349113303672.9ms133036956ms _debug "$kid->{PID} returned $?\n" if _debugging;
# spent 956ms making 133036 calls to IPC::Run::Debug::_debugging, avg 7µs/call
3492133036742ms $kid->{RESULT} = $?;
3493 }
3494 }
3495 }
3496}
3497
3498=pod
3499
3500=item finish
3501
3502This must be called after the last start() or pump() call for a harness,
3503or your system will accumulate defunct processes and you may "leak"
3504file descriptors.
3505
3506finish() returns TRUE if all children returned 0 (and were not signaled and did
3507not coredump, ie ! $?), and FALSE otherwise (this is like run(), and the
3508opposite of system()).
3509
3510Once a harness has been finished, it may be run() or start()ed again,
3511including by pump()s auto-start.
3512
3513If this throws an exception rather than a normal exit, the harness may
3514be left in an unstable state, it's best to kill the harness to get rid
3515of all the child processes, etc.
3516
3517Specifically, if a timeout expires in finish(), finish() will not
3518kill all the children. Call C<<$h->kill_kill>> in this case if you care.
3519This differs from the behavior of L</run>.
3520
3521=cut
3522
3523
# spent 38084s (4.24+38080) within IPC::Run::finish which was called 133036 times, avg 286ms/call: # 133036 times (4.24s+38080s) by IPC::Run::run at line 1522, avg 286ms/call
sub finish {
352413303634.7ms my IPC::Run $self = shift;
3525133036135ms my $options = @_ && ref $_[-1] eq 'HASH' ? pop : {};
3526
352713303641.9ms local $cur_self = $self;
3528
3529133036169ms1330361.26s _debug "** finishing" if _debugging;
# spent 1.26s making 133036 calls to IPC::Run::Debug::_debugging, avg 9µs/call
3530
3531133036446ms $self->{non_blocking} = 0;
3532133036270ms $self->{auto_close_ins} = 1;
3533133036114ms $self->{break_on_io} = 0;
3534
3535 # We don't alter $self->{clear_ins}, start() and run() control it.
3536
3537133036355ms133036829ms while ( $self->pumpable ) {
# spent 829ms making 133036 calls to IPC::Run::pumpable, avg 6µs/call
3538133036594ms26607238061s $self->_select_loop($options);
# spent 38059s making 133036 calls to IPC::Run::_select_loop, avg 286ms/call # spent 1.69s making 133036 calls to IPC::Run::pumpable, avg 13µs/call
3539 }
3540133036255ms13303615.4s $self->_cleanup;
# spent 15.4s making 133036 calls to IPC::Run::_cleanup, avg 116µs/call
3541
3542133036974ms1330361.40s return !$self->full_result;
# spent 1.40s making 133036 calls to IPC::Run::full_result, avg 11µs/call
3543}
3544
3545=pod
3546
3547=item result
3548
3549 $h->result;
3550
3551Returns the first non-zero result code (ie $? >> 8). See L</full_result> to
3552get the $? value for a child process.
3553
3554To get the result of a particular child, do:
3555
3556 $h->result( 0 ); # first child's $? >> 8
3557 $h->result( 1 ); # second child
3558
3559or
3560
3561 ($h->results)[0]
3562 ($h->results)[1]
3563
3564Returns undef if no child processes were spawned and no child number was
3565specified. Throws an exception if an out-of-range child number is passed.
3566
3567=cut
3568
3569
# spent 291ms within IPC::Run::_assert_finished which was called 133036 times, avg 2µs/call: # 133036 times (291ms+0s) by IPC::Run::full_result at line 3648, avg 2µs/call
sub _assert_finished {
357013303638.8ms my IPC::Run $self = $_[0];
3571
357213303659.3ms croak "Harness not run" unless $self->{STATE} >= _finished;
3573133036424ms croak "Harness not finished running" unless $self->{STATE} == _finished;
3574}
3575
3576sub _child_result {
3577 my IPC::Run $self = shift;
3578
3579 my ($which) = @_;
3580 croak(
3581 "Only ",
3582 scalar( @{ $self->{KIDS} } ),
3583 " child processes, no process $which"
3584 ) unless $which >= 0 && $which <= $#{ $self->{KIDS} };
3585 return $self->{KIDS}->[$which]->{RESULT};
3586}
3587
3588sub result {
3589 &_assert_finished;
3590 my IPC::Run $self = shift;
3591
3592 if (@_) {
3593 my ($which) = @_;
3594 return $self->_child_result($which) >> 8;
3595 }
3596 else {
3597 return undef unless @{ $self->{KIDS} };
3598 for ( @{ $self->{KIDS} } ) {
3599 return $_->{RESULT} >> 8 if $_->{RESULT} >> 8;
3600 }
3601 }
3602}
3603
3604=pod
3605
3606=item results
3607
3608Returns a list of child exit values. See L</full_results> if you want to
3609know if a signal killed the child.
3610
3611Throws an exception if the harness is not in a finished state.
3612
3613=cut
3614
3615sub results {
3616 &_assert_finished;
3617 my IPC::Run $self = shift;
3618
3619 # we add 0 here to stop warnings associated with "unknown result, unknown PID"
3620 return map { ( 0 + $_->{RESULT} ) >> 8 } @{ $self->{KIDS} };
3621}
3622
3623=pod
3624
3625=item full_result
3626
3627 $h->full_result;
3628
3629Returns the first non-zero $?. See L</result> to get the first $? >> 8
3630value for a child process.
3631
3632To get the result of a particular child, do:
3633
3634 $h->full_result( 0 ); # first child's $?
3635 $h->full_result( 1 ); # second child
3636
3637or
3638
3639 ($h->full_results)[0]
3640 ($h->full_results)[1]
3641
3642Returns undef if no child processes were spawned and no child number was
3643specified. Throws an exception if an out-of-range child number is passed.
3644
3645=cut
3646
3647
# spent 1.40s (1.11+291ms) within IPC::Run::full_result which was called 133036 times, avg 11µs/call: # 133036 times (1.11s+291ms) by IPC::Run::finish at line 3542, avg 11µs/call
sub full_result {
3648133036196ms133036291ms &_assert_finished;
# spent 291ms making 133036 calls to IPC::Run::_assert_finished, avg 2µs/call
3649
365013303635.1ms my IPC::Run $self = shift;
3651
365213303660.2ms if (@_) {
3653 my ($which) = @_;
3654 return $self->_child_result($which);
3655 }
3656 else {
365713303637.7ms return undef unless @{ $self->{KIDS} };
365813303699.5ms for ( @{ $self->{KIDS} } ) {
3659133036412ms return $_->{RESULT} if $_->{RESULT};
3660 }
3661 }
3662}
3663
3664=pod
3665
3666=item full_results
3667
3668Returns a list of child exit values as returned by C<wait>. See L</results>
3669if you don't care about coredumps or signals.
3670
3671Throws an exception if the harness is not in a finished state.
3672
3673=cut
3674
3675sub full_results {
3676 &_assert_finished;
3677 my IPC::Run $self = shift;
3678
3679 croak "Harness not run" unless $self->{STATE} >= _finished;
3680 croak "Harness not finished running" unless $self->{STATE} == _finished;
3681
3682 return map $_->{RESULT}, @{ $self->{KIDS} };
3683}
3684
3685##
3686## Filter Scaffolding
3687##
3688
# spent 40µs (9+31) within IPC::Run::BEGIN@3688 which was called: # once (9µs+31µs) by main::BEGIN@29 at line 3691
use vars (
368919µs131µs '$filter_op', ## The op running a filter chain right now
# spent 31µs making 1 call to vars::import
3690 '$filter_num', ## Which filter is being run right now.
36911734µs140µs);
# spent 40µs making 1 call to IPC::Run::BEGIN@3688
3692
3693##
3694## A few filters and filter constructors
3695##
3696
3697=pod
3698
3699=back
3700
3701=back
3702
3703=head1 FILTERS
3704
3705These filters are used to modify input our output between a child
3706process and a scalar or subroutine endpoint.
3707
3708=over
3709
3710=item binary
3711
3712 run \@cmd, ">", binary, \$out;
3713 run \@cmd, ">", binary, \$out; ## Any TRUE value to enable
3714 run \@cmd, ">", binary 0, \$out; ## Any FALSE value to disable
3715
3716This is a constructor for a "binmode" "filter" that tells IPC::Run to keep
3717the carriage returns that would ordinarily be edited out for you (binmode
3718is usually off). This is not a real filter, but an option masquerading as
3719a filter.
3720
3721It's not named "binmode" because you're likely to want to call Perl's binmode
3722in programs that are piping binary data around.
3723
3724=cut
3725
3726sub binary(;$) {
3727 my $enable = @_ ? shift : 1;
3728 return bless sub { $enable }, "IPC::Run::binmode_pseudo_filter";
3729}
3730
3731=pod
3732
3733=item new_chunker
3734
3735This breaks a stream of data in to chunks, based on an optional
3736scalar or regular expression parameter. The default is the Perl
3737input record separator in $/, which is a newline be default.
3738
3739 run \@cmd, '>', new_chunker, \&lines_handler;
3740 run \@cmd, '>', new_chunker( "\r\n" ), \&lines_handler;
3741
3742Because this uses $/ by default, you should always pass in a parameter
3743if you are worried about other code (modules, etc) modifying $/.
3744
3745If this filter is last in a filter chain that dumps in to a scalar,
3746the scalar must be set to '' before a new chunk will be written to it.
3747
3748As an example of how a filter like this can be written, here's a
3749chunker that splits on newlines:
3750
3751 sub line_splitter {
3752 my ( $in_ref, $out_ref ) = @_;
3753
3754 return 0 if length $$out_ref;
3755
3756 return input_avail && do {
3757 while (1) {
3758 if ( $$in_ref =~ s/\A(.*?\n)// ) {
3759 $$out_ref .= $1;
3760 return 1;
3761 }
3762 my $hmm = get_more_input;
3763 unless ( defined $hmm ) {
3764 $$out_ref = $$in_ref;
3765 $$in_ref = '';
3766 return length $$out_ref ? 1 : 0;
3767 }
3768 return 0 if $hmm eq 0;
3769 }
3770 }
3771 };
3772
3773=cut
3774
3775sub new_chunker(;$) {
3776 my ($re) = @_;
3777 $re = $/ if _empty $re;
3778 $re = quotemeta($re) unless ref $re eq 'Regexp';
3779 $re = qr/\A(.*?$re)/s;
3780
3781 return sub {
3782 my ( $in_ref, $out_ref ) = @_;
3783
3784 return 0 if length $$out_ref;
3785
3786 return input_avail && do {
3787 while (1) {
3788 if ( $$in_ref =~ s/$re// ) {
3789 $$out_ref .= $1;
3790 return 1;
3791 }
3792 my $hmm = get_more_input;
3793 unless ( defined $hmm ) {
3794 $$out_ref = $$in_ref;
3795 $$in_ref = '';
3796 return length $$out_ref ? 1 : 0;
3797 }
3798 return 0 if $hmm eq 0;
3799 }
3800 }
3801 };
3802}
3803
3804=pod
3805
3806=item new_appender
3807
3808This appends a fixed string to each chunk of data read from the source
3809scalar or sub. This might be useful if you're writing commands to a
3810child process that always must end in a fixed string, like "\n":
3811
3812 run( \@cmd,
3813 '<', new_appender( "\n" ), \&commands,
3814 );
3815
3816Here's a typical filter sub that might be created by new_appender():
3817
3818 sub newline_appender {
3819 my ( $in_ref, $out_ref ) = @_;
3820
3821 return input_avail && do {
3822 $$out_ref = join( '', $$out_ref, $$in_ref, "\n" );
3823 $$in_ref = '';
3824 1;
3825 }
3826 };
3827
3828=cut
3829
3830sub new_appender($) {
3831 my ($suffix) = @_;
3832 croak "\$suffix undefined" unless defined $suffix;
3833
3834 return sub {
3835 my ( $in_ref, $out_ref ) = @_;
3836
3837 return input_avail && do {
3838 $$out_ref = join( '', $$out_ref, $$in_ref, $suffix );
3839 $$in_ref = '';
3840 1;
3841 }
3842 };
3843}
3844
3845=item new_string_source
3846
3847TODO: Needs confirmation. Was previously undocumented. in this module.
3848
3849This is a filter which is exportable. Returns a sub which appends the data passed in to the output buffer and returns 1 if data was appended. 0 if it was an empty string and undef if no data was passed.
3850
3851NOTE: Any additional variables passed to new_string_source will be passed to the sub every time it's called and appended to the output.
3852
3853=cut
3854
3855sub new_string_source {
3856 my $ref;
3857 if ( @_ > 1 ) {
3858 $ref = [@_],
3859 }
3860 else {
3861 $ref = shift;
3862 }
3863
3864 return ref $ref eq 'SCALAR'
3865 ? sub {
3866 my ( $in_ref, $out_ref ) = @_;
3867
3868 return defined $$ref
3869 ? do {
3870 $$out_ref .= $$ref;
3871 my $r = length $$ref ? 1 : 0;
3872 $$ref = undef;
3873 $r;
3874 }
3875 : undef;
3876 }
3877 : sub {
3878 my ( $in_ref, $out_ref ) = @_;
3879
3880 return @$ref
3881 ? do {
3882 my $s = shift @$ref;
3883 $$out_ref .= $s;
3884 length $s ? 1 : 0;
3885 }
3886 : undef;
3887 }
3888}
3889
3890=item new_string_sink
3891
3892TODO: Needs confirmation. Was previously undocumented.
3893
3894This is a filter which is exportable. Returns a sub which pops the data out of the input stream and pushes it onto the string.
3895
3896=cut
3897
3898sub new_string_sink {
3899 my ($string_ref) = @_;
3900
3901 return sub {
3902 my ( $in_ref, $out_ref ) = @_;
3903
3904 return input_avail && do {
3905 $$string_ref .= $$in_ref;
3906 $$in_ref = '';
3907 1;
3908 }
3909 };
3910}
3911
3912#=item timeout
3913#
3914#This function defines a time interval, starting from when start() is
3915#called, or when timeout() is called. If all processes have not finished
3916#by the end of the timeout period, then a "process timed out" exception
3917#is thrown.
3918#
3919#The time interval may be passed in seconds, or as an end time in
3920#"HH:MM:SS" format (any non-digit other than '.' may be used as
3921#spacing and punctuation). This is probably best shown by example:
3922#
3923# $h->timeout( $val );
3924#
3925# $val Effect
3926# ======================== =====================================
3927# undef Timeout timer disabled
3928# '' Almost immediate timeout
3929# 0 Almost immediate timeout
3930# 0.000001 timeout > 0.0000001 seconds
3931# 30 timeout > 30 seconds
3932# 30.0000001 timeout > 30 seconds
3933# 10:30 timeout > 10 minutes, 30 seconds
3934#
3935#Timeouts are currently evaluated with a 1 second resolution, though
3936#this may change in the future. This means that setting
3937#timeout($h,1) will cause a pokey child to be aborted sometime after
3938#one second has elapsed and typically before two seconds have elapsed.
3939#
3940#This sub does not check whether or not the timeout has expired already.
3941#
3942#Returns the number of seconds set as the timeout (this does not change
3943#as time passes, unless you call timeout( val ) again).
3944#
3945#The timeout does not include the time needed to fork() or spawn()
3946#the child processes, though some setup time for the child processes can
3947#included. It also does not include the length of time it takes for
3948#the children to exit after they've closed all their pipes to the
3949#parent process.
3950#
3951#=cut
3952#
3953#sub timeout {
3954# my IPC::Run $self = shift;
3955#
3956# if ( @_ ) {
3957# ( $self->{TIMEOUT} ) = @_;
3958# $self->{TIMEOUT_END} = undef;
3959# if ( defined $self->{TIMEOUT} ) {
3960# if ( $self->{TIMEOUT} =~ /[^\d.]/ ) {
3961# my @f = split( /[^\d\.]+/i, $self->{TIMEOUT} );
3962# unshift @f, 0 while @f < 3;
3963# $self->{TIMEOUT} = (($f[0]*60)+$f[1])*60+$f[2];
3964# }
3965# elsif ( $self->{TIMEOUT} =~ /^(\d*)(?:\.(\d*))/ ) {
3966# $self->{TIMEOUT} = $1 + 1;
3967# }
3968# $self->_calc_timeout_end if $self->{STATE} >= _started;
3969# }
3970# }
3971# return $self->{TIMEOUT};
3972#}
3973#
3974#
3975#sub _calc_timeout_end {
3976# my IPC::Run $self = shift;
3977#
3978# $self->{TIMEOUT_END} = defined $self->{TIMEOUT}
3979# ? time + $self->{TIMEOUT}
3980# : undef;
3981#
3982# ## We add a second because we might be at the very end of the current
3983# ## second, and we want to guarantee that we don't have a timeout even
3984# ## one second less then the timeout period.
3985# ++$self->{TIMEOUT_END} if $self->{TIMEOUT};
3986#}
3987
3988=pod
3989
3990=item io
3991
3992Takes a filename or filehandle, a redirection operator, optional filters,
3993and a source or destination (depends on the redirection operator). Returns
3994an IPC::Run::IO object suitable for harness()ing (including via start()
3995or run()).
3996
3997This is shorthand for
3998
3999
4000 require IPC::Run::IO;
4001
4002 ... IPC::Run::IO->new(...) ...
4003
4004=cut
4005
4006sub io {
4007 require IPC::Run::IO;
4008 IPC::Run::IO->new(@_);
4009}
4010
4011=pod
4012
4013=item timer
4014
4015 $h = start( \@cmd, \$in, \$out, $t = timer( 5 ) );
4016
4017 pump $h until $out =~ /expected stuff/ || $t->is_expired;
4018
4019Instantiates a non-fatal timer. pump() returns once each time a timer
4020expires. Has no direct effect on run(), but you can pass a subroutine
4021to fire when the timer expires.
4022
4023See L</timeout> for building timers that throw exceptions on
4024expiration.
4025
4026See L<IPC::Run::Timer/timer> for details.
4027
4028=cut
4029
4030# Doing the prototype suppresses 'only used once' on older perls.
4031sub timer;
403211µs*timer = \&IPC::Run::Timer::timer;
4033
4034=pod
4035
4036=item timeout
4037
4038 $h = start( \@cmd, \$in, \$out, $t = timeout( 5 ) );
4039
4040 pump $h until $out =~ /expected stuff/;
4041
4042Instantiates a timer that throws an exception when it expires.
4043If you don't provide an exception, a default exception that matches
4044/^IPC::Run: .*timed out/ is thrown by default. You can pass in your own
4045exception scalar or reference:
4046
4047 $h = start(
4048 \@cmd, \$in, \$out,
4049 $t = timeout( 5, exception => 'slowpoke' ),
4050 );
4051
4052or set the name used in debugging message and in the default exception
4053string:
4054
4055 $h = start(
4056 \@cmd, \$in, \$out,
4057 timeout( 50, name => 'process timer' ),
4058 $stall_timer = timeout( 5, name => 'stall timer' ),
4059 );
4060
4061 pump $h until $out =~ /started/;
4062
4063 $in = 'command 1';
4064 $stall_timer->start;
4065 pump $h until $out =~ /command 1 finished/;
4066
4067 $in = 'command 2';
4068 $stall_timer->start;
4069 pump $h until $out =~ /command 2 finished/;
4070
4071 $in = 'very slow command 3';
4072 $stall_timer->start( 10 );
4073 pump $h until $out =~ /command 3 finished/;
4074
4075 $stall_timer->start( 5 );
4076 $in = 'command 4';
4077 pump $h until $out =~ /command 4 finished/;
4078
4079 $stall_timer->reset; # Prevent restarting or expirng
4080 finish $h;
4081
4082See L</timer> for building non-fatal timers.
4083
4084See L<IPC::Run::Timer/timer> for details.
4085
4086=cut
4087
4088# Doing the prototype suppresses 'only used once' on older perls.
4089sub timeout;
40901400ns*timeout = \&IPC::Run::Timer::timeout;
4091
4092=pod
4093
4094=back
4095
4096=head1 FILTER IMPLEMENTATION FUNCTIONS
4097
4098These functions are for use from within filters.
4099
4100=over
4101
4102=item input_avail
4103
4104Returns TRUE if input is available. If none is available, then
4105&get_more_input is called and its result is returned.
4106
4107This is usually used in preference to &get_more_input so that the
4108calling filter removes all data from the $in_ref before more data
4109gets read in to $in_ref.
4110
4111C<input_avail> is usually used as part of a return expression:
4112
4113 return input_avail && do {
4114 ## process the input just gotten
4115 1;
4116 };
4117
4118This technique allows input_avail to return the undef or 0 that a
4119filter normally returns when there's no input to process. If a filter
4120stores intermediate values, however, it will need to react to an
4121undef:
4122
4123 my $got = input_avail;
4124 if ( ! defined $got ) {
4125 ## No more input ever, flush internal buffers to $out_ref
4126 }
4127 return $got unless $got;
4128 ## Got some input, move as much as need be
4129 return 1 if $added_to_out_ref;
4130
4131=cut
4132
4133sub input_avail() {
4134 confess "Undefined FBUF ref for $filter_num+1"
4135 unless defined $filter_op->{FBUFS}->[ $filter_num + 1 ];
4136 length ${ $filter_op->{FBUFS}->[ $filter_num + 1 ] } || get_more_input;
4137}
4138
4139=pod
4140
4141=item get_more_input
4142
4143This is used to fetch more input in to the input variable. It returns
4144undef if there will never be any more input, 0 if there is none now,
4145but there might be in the future, and TRUE if more input was gotten.
4146
4147C<get_more_input> is usually used as part of a return expression,
4148see L</input_avail> for more information.
4149
4150=cut
4151
4152##
4153## Filter implementation interface
4154##
4155
# spent 33.9s (5.11+28.8) within IPC::Run::get_more_input which was called 532164 times, avg 64µs/call: # 266092 times (2.61s+31.3s) by IPC::Run::IO::_do_filters at line 550 of IPC/Run/IO.pm, avg 127µs/call # 266072 times (2.50s+-2.50s) by IPC::Run::__ANON__[/home/hejohns/perl5/lib/perl5/IPC/Run.pm:2514] at line 2485, avg 0s/call
sub get_more_input() {
415653216470.6ms ++$filter_num;
4157532164212ms my $r = eval {
4158 confess "get_more_input() called and no more filters in chain"
4159532164243ms unless defined $filter_op->{FILTERS}->[$filter_num];
4160 $filter_op->{FILTERS}->[$filter_num]->(
4161 $filter_op->{FBUFS}->[ $filter_num + 1 ],
41625321642.29s53216435.3s $filter_op->{FBUFS}->[$filter_num],
# spent 31.3s making 266092 calls to IPC::Run::__ANON__[IPC/Run.pm:2514], avg 118µs/call # spent 4.06s making 266072 calls to IPC::Run::IO::__ANON__[IPC/Run/IO.pm:216], avg 15µs/call
4163 ); # if defined ${$filter_op->{FBUFS}->[$filter_num+1]};
4164 };
416553216477.0ms --$filter_num;
416653216482.8ms die $@ if $@;
41675321641.48s return $r;
4168}
4169
417014µs1;
4171
4172=pod
4173
4174=back
4175
4176=head1 TODO
4177
4178These will be addressed as needed and as time allows.
4179
4180Stall timeout.
4181
4182Expose a list of child process objects. When I do this,
4183each child process is likely to be blessed into IPC::Run::Proc.
4184
4185$kid->abort(), $kid->kill(), $kid->signal( $num_or_name ).
4186
4187Write tests for /(full_)?results?/ subs.
4188
4189Currently, pump() and run() only work on systems where select() works on the
4190filehandles returned by pipe(). This does *not* include ActiveState on Win32,
4191although it does work on cygwin under Win32 (thought the tests whine a bit).
4192I'd like to rectify that, suggestions and patches welcome.
4193
4194Likewise start() only fully works on fork()/exec() machines (well, just
4195fork() if you only ever pass perl subs as subprocesses). There's
4196some scaffolding for calling Open3::spawn_with_handles(), but that's
4197untested, and not that useful with limited select().
4198
4199Support for C<\@sub_cmd> as an argument to a command which
4200gets replaced with /dev/fd or the name of a temporary file containing foo's
4201output. This is like <(sub_cmd ...) found in bash and csh (IIRC).
4202
4203Allow multiple harnesses to be combined as independent sets of processes
4204in to one 'meta-harness'.
4205
4206Allow a harness to be passed in place of an \@cmd. This would allow
4207multiple harnesses to be aggregated.
4208
4209Ability to add external file descriptors w/ filter chains and endpoints.
4210
4211Ability to add timeouts and timing generators (i.e. repeating timeouts).
4212
4213High resolution timeouts.
4214
4215=head1 Win32 LIMITATIONS
4216
4217=over
4218
4219=item argument-passing rules are program-specific
4220
4221Win32 programs receive all arguments in a single "command line" string.
4222IPC::Run assembles this string so programs using L<standard command line parsing
4223rules|https://docs.microsoft.com/en-us/cpp/cpp/main-function-command-line-args#parsing-c-command-line-arguments>
4224will see an C<argv> that matches the array reference specifying the command.
4225Some programs use different rules to parse their command line. Notable examples
4226include F<cmd.exe>, F<cscript.exe>, and Cygwin programs called from non-Cygwin
4227programs. Use L<IPC::Run::Win32Process> to call these and other nonstandard
4228programs.
4229
4230=item batch files
4231
4232Properly escaping a batch file argument depends on how the script will use that
4233argument, because some uses experience multiple levels of caret (escape
4234character) removal. Avoid calling batch files with arguments, particularly when
4235the argument values originate outside your program or contain non-alphanumeric
4236characters. Perl scripts and PowerShell scripts are sound alternatives. If you
4237do use batch file arguments, IPC::Run escapes them so the batch file can pass
4238them, unquoted, to a program having standard command line parsing rules. If the
4239batch file enables delayed environment variable expansion, it must disable that
4240feature before expanding its arguments. For example, if F<foo.cmd> contains
4241C<perl %*>, C<run ['foo.cmd', @list]> will create a Perl process in which
4242C<@ARGV> matches C<@list>. Prepending a C<setlocal enabledelayedexpansion> line
4243would make the batch file malfunction, silently. Another silent-malfunction
4244example is C<run ['outer.bat', @list]> for F<outer.bat> containing C<foo.cmd
4245%*>.
4246
4247=item Fails on Win9X
4248
4249If you want Win9X support, you'll have to debug it or fund me because I
4250don't use that system any more. The Win32 subsysem has been extended to
4251use temporary files in simple run() invocations and these may actually
4252work on Win9X too, but I don't have time to work on it.
4253
4254=item May deadlock on Win2K (but not WinNT4 or WinXPPro)
4255
4256Spawning more than one subprocess on Win2K causes a deadlock I haven't
4257figured out yet, but simple uses of run() often work. Passes all tests
4258on WinXPPro and WinNT.
4259
4260=item no support yet for <pty< and >pty>
4261
4262These are likely to be implemented as "<" and ">" with binmode on, not
4263sure.
4264
4265=item no support for file descriptors higher than 2 (stderr)
4266
4267Win32 only allows passing explicit fds 0, 1, and 2. If you really, really need to pass file handles, us Win32API:: GetOsFHandle() or ::FdGetOsFHandle() to
4268get the integer handle and pass it to the child process using the command
4269line, environment, stdin, intermediary file, or other IPC mechanism. Then
4270use that handle in the child (Win32API.pm provides ways to reconstitute
4271Perl file handles from Win32 file handles).
4272
4273=item no support for subroutine subprocesses (CODE refs)
4274
4275Can't fork(), so the subroutines would have no context, and closures certainly
4276have no meaning
4277
4278Perhaps with Win32 fork() emulation, this can be supported in a limited
4279fashion, but there are other very serious problems with that: all parent
4280fds get dup()ed in to the thread emulating the forked process, and that
4281keeps the parent from being able to close all of the appropriate fds.
4282
4283=item no support for init => sub {} routines.
4284
4285Win32 processes are created from scratch, there is no way to do an init
4286routine that will affect the running child. Some limited support might
4287be implemented one day, do chdir() and %ENV changes can be made.
4288
4289=item signals
4290
4291Win32 does not fully support signals. signal() is likely to cause errors
4292unless sending a signal that Perl emulates, and C<kill_kill()> is immediately
4293fatal (there is no grace period).
4294
4295=item helper processes
4296
4297IPC::Run uses helper processes, one per redirected file, to adapt between the
4298anonymous pipe connected to the child and the TCP socket connected to the
4299parent. This is a waste of resources and will change in the future to either
4300use threads (instead of helper processes) or a WaitForMultipleObjects call
4301(instead of select). Please contact me if you can help with the
4302WaitForMultipleObjects() approach; I haven't figured out how to get at it
4303without C code.
4304
4305=item shutdown pause
4306
4307There seems to be a pause of up to 1 second between when a child program exits
4308and the corresponding sockets indicate that they are closed in the parent.
4309Not sure why.
4310
4311=item binmode
4312
4313binmode is not supported yet. The underpinnings are implemented, just ask
4314if you need it.
4315
4316=item IPC::Run::IO
4317
4318IPC::Run::IO objects can be used on Unix to read or write arbitrary files. On
4319Win32, they will need to use the same helper processes to adapt from
4320non-select()able filehandles to select()able ones (or perhaps
4321WaitForMultipleObjects() will work with them, not sure).
4322
4323=item startup race conditions
4324
4325There seems to be an occasional race condition between child process startup
4326and pipe closings. It seems like if the child is not fully created by the time
4327CreateProcess returns and we close the TCP socket being handed to it, the
4328parent socket can also get closed. This is seen with the Win32 pumper
4329applications, not the "real" child process being spawned.
4330
4331I assume this is because the kernel hasn't gotten around to incrementing the
4332reference count on the child's end (since the child was slow in starting), so
4333the parent's closing of the child end causes the socket to be closed, thus
4334closing the parent socket.
4335
4336Being a race condition, it's hard to reproduce, but I encountered it while
4337testing this code on a drive share to a samba box. In this case, it takes
4338t/run.t a long time to spawn it's child processes (the parent hangs in the
4339first select for several seconds until the child emits any debugging output).
4340
4341I have not seen it on local drives, and can't reproduce it at will,
4342unfortunately. The symptom is a "bad file descriptor in select()" error, and,
4343by turning on debugging, it's possible to see that select() is being called on
4344a no longer open file descriptor that was returned from the _socket() routine
4345in Win32Helper. There's a new confess() that checks for this ("PARENT_HANDLE
4346no longer open"), but I haven't been able to reproduce it (typically).
4347
4348=back
4349
4350=head1 LIMITATIONS
4351
4352On Unix, requires a system that supports C<waitpid( $pid, WNOHANG )> so
4353it can tell if a child process is still running.
4354
4355PTYs don't seem to be non-blocking on some versions of Solaris. Here's a
4356test script contributed by Borislav Deianov <borislav@ensim.com> to see
4357if you have the problem. If it dies, you have the problem.
4358
4359 #!/usr/bin/perl
4360
4361 use IPC::Run qw(run);
4362 use Fcntl;
4363 use IO::Pty;
4364
4365 sub makecmd {
4366 return ['perl', '-e',
4367 '<STDIN>, print "\n" x '.$_[0].'; while(<STDIN>){last if /end/}'];
4368 }
4369
4370 #pipe R, W;
4371 #fcntl(W, F_SETFL, O_NONBLOCK);
4372 #while (syswrite(W, "\n", 1)) { $pipebuf++ };
4373 #print "pipe buffer size is $pipebuf\n";
4374 my $pipebuf=4096;
4375 my $in = "\n" x ($pipebuf * 2) . "end\n";
4376 my $out;
4377
4378 $SIG{ALRM} = sub { die "Never completed!\n" };
4379
4380 print "reading from scalar via pipe...";
4381 alarm( 2 );
4382 run(makecmd($pipebuf * 2), '<', \$in, '>', \$out);
4383 alarm( 0 );
4384 print "done\n";
4385
4386 print "reading from code via pipe... ";
4387 alarm( 2 );
4388 run(makecmd($pipebuf * 3), '<', sub { $t = $in; undef $in; $t}, '>', \$out);
4389 alarm( 0 );
4390 print "done\n";
4391
4392 $pty = IO::Pty->new();
4393 $pty->blocking(0);
4394 $slave = $pty->slave();
4395 while ($pty->syswrite("\n", 1)) { $ptybuf++ };
4396 print "pty buffer size is $ptybuf\n";
4397 $in = "\n" x ($ptybuf * 3) . "end\n";
4398
4399 print "reading via pty... ";
4400 alarm( 2 );
4401 run(makecmd($ptybuf * 3), '<pty<', \$in, '>', \$out);
4402 alarm(0);
4403 print "done\n";
4404
4405No support for ';', '&&', '||', '{ ... }', etc: use perl's, since run()
4406returns TRUE when the command exits with a 0 result code.
4407
4408Does not provide shell-like string interpolation.
4409
4410No support for C<cd>, C<setenv>, or C<export>: do these in an init() sub
4411
4412 run(
4413 \cmd,
4414 ...
4415 init => sub {
4416 chdir $dir or die $!;
4417 $ENV{FOO}='BAR'
4418 }
4419 );
4420
4421Timeout calculation does not allow absolute times, or specification of
4422days, months, etc.
4423
4424B<WARNING:> Function coprocesses (C<run \&foo, ...>) suffer from two
4425limitations. The first is that it is difficult to close all filehandles the
4426child inherits from the parent, since there is no way to scan all open
4427FILEHANDLEs in Perl and it both painful and a bit dangerous to close all open
4428file descriptors with C<POSIX::close()>. Painful because we can't tell which
4429fds are open at the POSIX level, either, so we'd have to scan all possible fds
4430and close any that we don't want open (normally C<exec()> closes any
4431non-inheritable but we don't C<exec()> for &sub processes.
4432
4433The second problem is that Perl's DESTROY subs and other on-exit cleanup gets
4434run in the child process. If objects are instantiated in the parent before the
4435child is forked, the DESTROY will get run once in the parent and once in
4436the child. When coprocess subs exit, POSIX::_exit is called to work around this,
4437but it means that objects that are still referred to at that time are not
4438cleaned up. So setting package vars or closure vars to point to objects that
4439rely on DESTROY to affect things outside the process (files, etc), will
4440lead to bugs.
4441
4442I goofed on the syntax: "<pipe" vs. "<pty<" and ">filename" are both
4443oddities.
4444
4445=head1 TODO
4446
4447=over
4448
4449=item Allow one harness to "adopt" another:
4450
4451 $new_h = harness \@cmd2;
4452 $h->adopt( $new_h );
4453
4454=item Close all filehandles not explicitly marked to stay open.
4455
4456The problem with this one is that there's no good way to scan all open
4457FILEHANDLEs in Perl, yet you don't want child processes inheriting handles
4458willy-nilly.
4459
4460=back
4461
4462=head1 INSPIRATION
4463
4464Well, select() and waitpid() badly needed wrapping, and open3() isn't
4465open-minded enough for me.
4466
4467The shell-like API inspired by a message Russ Allbery sent to perl5-porters,
4468which included:
4469
4470 I've thought for some time that it would be
4471 nice to have a module that could handle full Bourne shell pipe syntax
4472 internally, with fork and exec, without ever invoking a shell. Something
4473 that you could give things like:
4474
4475 pipeopen (PIPE, [ qw/cat file/ ], '|', [ 'analyze', @args ], '>&3');
4476
4477Message ylln51p2b6.fsf@windlord.stanford.edu, on 2000/02/04.
4478
4479=head1 SUPPORT
4480
4481Bugs should always be submitted via the GitHub bug tracker
4482
4483L<https://github.com/toddr/IPC-Run/issues>
4484
4485=head1 AUTHORS
4486
4487Adam Kennedy <adamk@cpan.org>
4488
4489Barrie Slaymaker <barries@slaysys.com>
4490
4491=head1 COPYRIGHT
4492
4493Some parts copyright 2008 - 2009 Adam Kennedy.
4494
4495Copyright 1999 Barrie Slaymaker.
4496
4497You may distribute under the terms of either the GNU General Public
4498License or the Artistic License, as specified in the README file.
4499
4500=cut
 
# spent 424ms within IPC::Run::CORE:fcntl which was called 133036 times, avg 3µs/call: # 133036 times (424ms+0s) by IPC::Run::_pipe_nb at line 1403, avg 3µs/call
sub IPC::Run::CORE:fcntl; # opcode
# spent 619ms within IPC::Run::CORE:fteexec which was called 133036 times, avg 5µs/call: # 133035 times (619ms+0s) by IPC::Run::_search_path at line 1193, avg 5µs/call # once (11µs+0s) by IPC::Run::_search_path at line 1227
sub IPC::Run::CORE:fteexec; # opcode
# spent 238ms within IPC::Run::CORE:ftfile which was called 133042 times, avg 2µs/call: # 133035 times (238ms+0s) by IPC::Run::_search_path at line 1192, avg 2µs/call # 7 times (52µs+0s) by IPC::Run::_search_path at line 1227, avg 7µs/call
sub IPC::Run::CORE:ftfile; # opcode
# spent 483ms within IPC::Run::CORE:ftis which was called 133035 times, avg 4µs/call: # 133035 times (483ms+0s) by IPC::Run::_search_path at line 1191, avg 4µs/call
sub IPC::Run::CORE:ftis; # opcode
# spent 5.50s within IPC::Run::CORE:match which was called 2261613 times, avg 2µs/call: # 798216 times (690ms+0s) by IPC::Run::harness at line 1800, avg 865ns/call # 532144 times (3.05s+0s) by IPC::Run::_close at line 1275, avg 6µs/call # 266072 times (555ms+0s) by IPC::Run::_search_path at line 1170, avg 2µs/call # 133036 times (682ms+0s) by IPC::Run::_clobber at line 2955, avg 5µs/call # 133036 times (329ms+0s) by IPC::Run::_open_pipes at line 2415, avg 2µs/call # 133036 times (133ms+0s) by IPC::Run::_search_path at line 1189, avg 1µs/call # 133036 times (42.3ms+0s) by IPC::Run::_open_pipes at line 2437, avg 318ns/call # 133036 times (17.6ms+0s) by IPC::Run::_clobber at line 2960, avg 132ns/call # once (2µs+0s) by IPC::Run::BEGIN@1066 at line 1066
sub IPC::Run::CORE:match; # opcode
# spent 9µs within IPC::Run::CORE:qr which was called 3 times, avg 3µs/call: # once (8µs+0s) by IPC::Run::_search_path at line 1211 # once (800ns+0s) by IPC::Run::BEGIN@1089 at line 1092 # once (200ns+0s) by IPC::Run::BEGIN@1089 at line 1094
sub IPC::Run::CORE:qr; # opcode
# spent 125ms within IPC::Run::CORE:regcomp which was called 133039 times, avg 942ns/call: # 133036 times (125ms+0s) by IPC::Run::_search_path at line 1189, avg 942ns/call # once (11µs+0s) by IPC::Run::BEGIN@1089 at line 1092 # once (4µs+0s) by IPC::Run::BEGIN@1089 at line 1094 # once (1µs+0s) by IPC::Run::_search_path at line 1214
sub IPC::Run::CORE:regcomp; # opcode
# spent 205ms within IPC::Run::CORE:select which was called 532144 times, avg 385ns/call: # 266072 times (153ms+0s) by IPC::Run::start at line 2840, avg 574ns/call # 266072 times (52.1ms+0s) by IPC::Run::start at line 2841, avg 196ns/call
sub IPC::Run::CORE:select; # opcode
# spent 43.7ms within IPC::Run::CORE:sort which was called 133036 times, avg 328ns/call: # 133036 times (43.7ms+0s) by IPC::Run::_open_pipes at line 2112, avg 328ns/call
sub IPC::Run::CORE:sort; # opcode
# spent 37888s within IPC::Run::CORE:sselect which was called 1467686 times, avg 25.8ms/call: # 801065 times (127s+0s) by IPC::Run::pumpable at line 3403, avg 159µs/call # 666621 times (37761s+0s) by IPC::Run::_select_loop at line 3095, avg 56.6ms/call
sub IPC::Run::CORE:sselect; # opcode
# spent 5.29s within IPC::Run::CORE:waitpid which was called 1735159 times, avg 3µs/call: # 1735159 times (5.29s+0s) by IPC::Run::reap_nb at line 3474, avg 3µs/call
sub IPC::Run::CORE:waitpid; # opcode
# spent 84.2ms within IPC::Run::F_SETFL which was called 133036 times, avg 633ns/call: # 133036 times (84.2ms+0s) by IPC::Run::_pipe_nb at line 1403, avg 633ns/call
sub IPC::Run::F_SETFL; # xsub
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.