Profile of IPC/Cmd.pm

Filename	/usr/share/perl/5.36/IPC/Cmd.pm
Statements	Executed 173 statements in 5.64ms

Subroutines
Calls	P	F	Exclusive Time	Inclusive Time	Subroutine
1	1	1	27.8ms	59.5ms	IPC::Cmd::::can_runIPC::Cmd::can_run
1	1	1	4.95ms	10.8ms	IPC::Cmd::::BEGIN@5IPC::Cmd::BEGIN@5
1	1	1	1.29ms	9.34ms	IPC::Cmd::::BEGIN@61IPC::Cmd::BEGIN@61
1	1	1	994µs	2.20ms	IPC::Cmd::::BEGIN@59IPC::Cmd::BEGIN@59
1	1	1	745µs	819µs	IPC::Cmd::::BEGIN@60IPC::Cmd::BEGIN@60
27	1	1	52µs	52µs	IPC::Cmd::::CORE:ftdirIPC::Cmd::CORE:ftdir (opcode)
1	1	1	8µs	8µs	IPC::Cmd::::BEGIN@1873IPC::Cmd::BEGIN@1873
1	1	1	7µs	31µs	IPC::Cmd::::BEGIN@1507IPC::Cmd::BEGIN@1507
1	1	1	7µs	9µs	IPC::Cmd::::BEGIN@3IPC::Cmd::BEGIN@3
1	1	1	7µs	8µs	IPC::Cmd::::BEGIN@58IPC::Cmd::BEGIN@58
1	1	1	7µs	28µs	IPC::Cmd::::BEGIN@12IPC::Cmd::BEGIN@12
1	1	1	6µs	9µs	IPC::Cmd::::BEGIN@357IPC::Cmd::BEGIN@357
1	1	1	5µs	35µs	IPC::Cmd::::BEGIN@7IPC::Cmd::BEGIN@7
1	1	1	5µs	110µs	IPC::Cmd::::BEGIN@62IPC::Cmd::BEGIN@62
1	1	1	5µs	20µs	IPC::Cmd::::BEGIN@1874IPC::Cmd::BEGIN@1874
1	1	1	3µs	16µs	IPC::Cmd::::BEGIN@9IPC::Cmd::BEGIN@9
1	1	1	3µs	16µs	IPC::Cmd::::BEGIN@10IPC::Cmd::BEGIN@10
1	1	1	3µs	53µs	IPC::Cmd::::BEGIN@16IPC::Cmd::BEGIN@16
1	1	1	3µs	18µs	IPC::Cmd::::BEGIN@8IPC::Cmd::BEGIN@8
1	1	1	3µs	16µs	IPC::Cmd::::BEGIN@13IPC::Cmd::BEGIN@13
1	1	1	2µs	15µs	IPC::Cmd::::BEGIN@11IPC::Cmd::BEGIN@11
1	1	1	1µs	1µs	IPC::Cmd::::BEGIN@15IPC::Cmd::BEGIN@15
2	2	1	700ns	700ns	IPC::Cmd::::__ANON__IPC::Cmd::__ANON__ (xsub)
0	0	0	0s	0s	IPC::Cmd::::__ANON__[:1276]IPC::Cmd::__ANON__[:1276]
0	0	0	0s	0s	IPC::Cmd::::__ANON__[:1317]IPC::Cmd::__ANON__[:1317]
0	0	0	0s	0s	IPC::Cmd::::__ANON__[:1327]IPC::Cmd::__ANON__[:1327]
0	0	0	0s	0s	IPC::Cmd::::__ANON__[:1346]IPC::Cmd::__ANON__[:1346]
0	0	0	0s	0s	IPC::Cmd::::__ANON__[:1428]IPC::Cmd::__ANON__[:1428]
0	0	0	0s	0s	IPC::Cmd::::__ANON__[:1442]IPC::Cmd::__ANON__[:1442]
0	0	0	0s	0s	IPC::Cmd::::__ANON__[:361]IPC::Cmd::__ANON__[:361]
0	0	0	0s	0s	IPC::Cmd::::__ANON__[:459]IPC::Cmd::__ANON__[:459]
0	0	0	0s	0s	IPC::Cmd::::__ANON__[:559]IPC::Cmd::__ANON__[:559]
0	0	0	0s	0s	IPC::Cmd::::__ANON__[:597]IPC::Cmd::__ANON__[:597]
0	0	0	0s	0s	IPC::Cmd::::__ANON__[:944]IPC::Cmd::__ANON__[:944]
0	0	0	0s	0s	IPC::Cmd::::__ANON__[:947]IPC::Cmd::__ANON__[:947]
0	0	0	0s	0s	IPC::Cmd::::__dup_fdsIPC::Cmd::__dup_fds
0	0	0	0s	0s	IPC::Cmd::__fix_cmd_whitespace_and_special_chars
0	0	0	0s	0s	IPC::Cmd::::__reopen_fdsIPC::Cmd::__reopen_fds
0	0	0	0s	0s	IPC::Cmd::::_debugIPC::Cmd::_debug
0	0	0	0s	0s	IPC::Cmd::::_ipc_runIPC::Cmd::_ipc_run
0	0	0	0s	0s	IPC::Cmd::::_open3_runIPC::Cmd::_open3_run
0	0	0	0s	0s	IPC::Cmd::::_open3_run_win32IPC::Cmd::_open3_run_win32
0	0	0	0s	0s	IPC::Cmd::::_pp_child_errorIPC::Cmd::_pp_child_error
0	0	0	0s	0s	IPC::Cmd::::_quote_args_vmsIPC::Cmd::_quote_args_vms
0	0	0	0s	0s	IPC::Cmd::::_split_like_shell_win32IPC::Cmd::_split_like_shell_win32
0	0	0	0s	0s	IPC::Cmd::::_system_runIPC::Cmd::_system_run
0	0	0	0s	0s	IPC::Cmd::::adjust_monotonic_start_timeIPC::Cmd::adjust_monotonic_start_time
0	0	0	0s	0s	IPC::Cmd::::can_capture_bufferIPC::Cmd::can_capture_buffer
0	0	0	0s	0s	IPC::Cmd::::can_use_ipc_open3IPC::Cmd::can_use_ipc_open3
0	0	0	0s	0s	IPC::Cmd::::can_use_ipc_runIPC::Cmd::can_use_ipc_run
0	0	0	0s	0s	IPC::Cmd::::can_use_run_forkedIPC::Cmd::can_use_run_forked
0	0	0	0s	0s	IPC::Cmd::::get_monotonic_timeIPC::Cmd::get_monotonic_time
0	0	0	0s	0s	IPC::Cmd::::install_layered_signalIPC::Cmd::install_layered_signal
0	0	0	0s	0s	IPC::Cmd::::kill_gentlyIPC::Cmd::kill_gently
0	0	0	0s	0s	IPC::Cmd::::open3_runIPC::Cmd::open3_run
0	0	0	0s	0s	IPC::Cmd::::runIPC::Cmd::run
0	0	0	0s	0s	IPC::Cmd::::run_forkedIPC::Cmd::run_forked
0	0	0	0s	0s	IPC::Cmd::::uninstall_signalsIPC::Cmd::uninstall_signals

Call graph for these subroutines as a Graphviz dot language file.

Line	State ments	Time on line	Calls	Time in subs	Code
1					package IPC::Cmd;
2
3	2	27µs	2	10µs	# spent 9µs (7+1) within IPC::Cmd::BEGIN@3 which was called: # once (7µs+1µs) by main::BEGIN@30 at line 3 use strict; # spent 9µs making 1 call to IPC::Cmd::BEGIN@3 # spent 1µs making 1 call to strict::import
4
5					# spent 10.8ms (4.95+5.82) within IPC::Cmd::BEGIN@5 which was called: # once (4.95ms+5.82ms) by main::BEGIN@30 at line 55 BEGIN {
6
7	2	23µs	2	64µs	# spent 35µs (5+29) within IPC::Cmd::BEGIN@7 which was called: # once (5µs+29µs) by main::BEGIN@30 at line 7 use constant IS_VMS => $^O eq 'VMS' ? 1 : 0; # spent 35µs making 1 call to IPC::Cmd::BEGIN@7 # spent 29µs making 1 call to constant::import
8	2	18µs	2	33µs	# spent 18µs (3+15) within IPC::Cmd::BEGIN@8 which was called: # once (3µs+15µs) by main::BEGIN@30 at line 8 use constant IS_WIN32 => $^O eq 'MSWin32' ? 1 : 0; # spent 18µs making 1 call to IPC::Cmd::BEGIN@8 # spent 15µs making 1 call to constant::import
9	2	23µs	2	28µs	# spent 16µs (3+13) within IPC::Cmd::BEGIN@9 which was called: # once (3µs+13µs) by main::BEGIN@30 at line 9 use constant IS_HPUX => $^O eq 'hpux' ? 1 : 0; # spent 16µs making 1 call to IPC::Cmd::BEGIN@9 # spent 13µs making 1 call to constant::import
10	2	16µs	2	30µs	# spent 16µs (3+13) within IPC::Cmd::BEGIN@10 which was called: # once (3µs+13µs) by main::BEGIN@30 at line 10 use constant IS_WIN98 => (IS_WIN32 and !Win32::IsWinNT()) ? 1 : 0; # spent 16µs making 1 call to IPC::Cmd::BEGIN@10 # spent 13µs making 1 call to constant::import
11	2	16µs	2	28µs	# spent 15µs (2+13) within IPC::Cmd::BEGIN@11 which was called: # once (2µs+13µs) by main::BEGIN@30 at line 11 use constant ALARM_CLASS => __PACKAGE__ . '::TimeOut'; # spent 15µs making 1 call to IPC::Cmd::BEGIN@11 # spent 13µs making 1 call to constant::import
12	2	20µs	2	48µs	# spent 28µs (7+21) within IPC::Cmd::BEGIN@12 which was called: # once (7µs+21µs) by main::BEGIN@30 at line 12 use constant SPECIAL_CHARS => qw[< > \| &]; # spent 28µs making 1 call to IPC::Cmd::BEGIN@12 # spent 21µs making 1 call to constant::import
13	2	12µs	2	30µs	# spent 16µs (3+14) within IPC::Cmd::BEGIN@13 which was called: # once (3µs+14µs) by main::BEGIN@30 at line 13 use constant QUOTE => do { IS_WIN32 ? q["] : q['] }; # spent 16µs making 1 call to IPC::Cmd::BEGIN@13 # spent 14µs making 1 call to constant::import
14
15	2	24µs	1	1µs	# spent 1µs within IPC::Cmd::BEGIN@15 which was called: # once (1µs+0s) by main::BEGIN@30 at line 15 use Exporter (); # spent 1µs making 1 call to IPC::Cmd::BEGIN@15
16	1	2µs	1	50µs	# spent 53µs (3+50) within IPC::Cmd::BEGIN@16 which was called: # once (3µs+50µs) by main::BEGIN@30 at line 20 use vars qw[ @ISA $VERSION @EXPORT_OK $VERBOSE $DEBUG # spent 50µs making 1 call to vars::import
17					$USE_IPC_RUN $USE_IPC_OPEN3 $CAN_USE_RUN_FORKED $WARN
18					$INSTANCES $ALLOW_NULL_ARGS
19					$HAVE_MONOTONIC
20	1	123µs	1	53µs	]; # spent 53µs making 1 call to IPC::Cmd::BEGIN@16
21
22	1	200ns			$VERSION = '1.04';
23	1	200ns			$VERBOSE = 0;
24	1	0s			$DEBUG = 0;
25	1	100ns			$WARN = 1;
26	1	0s			$USE_IPC_RUN = IS_WIN32 && !IS_WIN98;
27	1	200ns			$USE_IPC_OPEN3 = not IS_VMS;
28	1	0s			$ALLOW_NULL_ARGS = 0;
29
30	1	100ns			$CAN_USE_RUN_FORKED = 0;
31	1	200ns			eval {
32	2	2µs	1	4.66ms	require POSIX; POSIX->import(); # spent 4.66ms making 1 call to POSIX::import
33	2	92µs	1	13µs	require IPC::Open3; IPC::Open3->import(); # spent 13µs making 1 call to Exporter::import
34	2	50µs	1	7µs	require IO::Select; IO::Select->import(); # spent 7µs making 1 call to Exporter::import
35	2	1µs	1	4µs	require IO::Handle; IO::Handle->import(); # spent 4µs making 1 call to Exporter::import
36	2	73µs	1	198µs	require FileHandle; FileHandle->import(); # spent 198µs making 1 call to FileHandle::import
37	1	96µs			require Socket;
38	2	3µs	1	44µs	require Time::HiRes; Time::HiRes->import(); # spent 44µs making 1 call to Time::HiRes::import
39	1	500ns			require Win32 if IS_WIN32;
40					};
41	1	700ns			$CAN_USE_RUN_FORKED = $@ \|\| !IS_VMS && !IS_WIN32;
42
43	1	300ns			eval {
44	1	7µs	2	13µs	my $wait_start_time = Time::HiRes::clock_gettime(&Time::HiRes::CLOCK_MONOTONIC); # spent 10µs making 1 call to Time::HiRes::AUTOLOAD # spent 2µs making 1 call to Time::HiRes::clock_gettime
45					};
46	1	300ns			if ($@) {
47					$HAVE_MONOTONIC = 0;
48					}
49					else {
50	1	200ns			$HAVE_MONOTONIC = 1;
51					}
52
53	1	5µs			@ISA = qw[Exporter];
54	1	3µs			@EXPORT_OK = qw[can_run run run_forked QUOTE];
55	1	39µs	1	10.8ms	} # spent 10.8ms making 1 call to IPC::Cmd::BEGIN@5
56
57	1	600ns			require Carp;
58	2	21µs	2	8µs	# spent 8µs (7+300ns) within IPC::Cmd::BEGIN@58 which was called: # once (7µs+300ns) by main::BEGIN@30 at line 58 use File::Spec; # spent 8µs making 1 call to IPC::Cmd::BEGIN@58 # spent 300ns making 1 call to IPC::Cmd::__ANON__
59	2	99µs	2	2.22ms	# spent 2.20ms (994µs+1.20) within IPC::Cmd::BEGIN@59 which was called: # once (994µs+1.20ms) by main::BEGIN@30 at line 59 use Params::Check qw[check]; # spent 2.20ms making 1 call to IPC::Cmd::BEGIN@59 # spent 20µs making 1 call to Exporter::import
60	2	91µs	1	819µs	# spent 819µs (745+74) within IPC::Cmd::BEGIN@60 which was called: # once (745µs+74µs) by main::BEGIN@30 at line 60 use Text::ParseWords (); # import ONLY if needed! # spent 819µs making 1 call to IPC::Cmd::BEGIN@60
61	2	107µs	2	9.36ms	# spent 9.34ms (1.29+8.05) within IPC::Cmd::BEGIN@61 which was called: # once (1.29ms+8.05ms) by main::BEGIN@30 at line 61 use Module::Load::Conditional qw[can_load]; # spent 9.34ms making 1 call to IPC::Cmd::BEGIN@61 # spent 21µs making 1 call to Exporter::import
62	2	306µs	2	214µs	# spent 110µs (5+105) within IPC::Cmd::BEGIN@62 which was called: # once (5µs+105µs) by main::BEGIN@30 at line 62 use Locale::Maketext::Simple Style => 'gettext'; # spent 110µs making 1 call to IPC::Cmd::BEGIN@62 # spent 105µs making 1 call to Locale::Maketext::Simple::import
63
64	1	300ns			local $Module::Load::Conditional::FORCE_SAFE_INC = 1;
65
66					=pod
67
68					=head1 NAME
69
70					IPC::Cmd - finding and running system commands made easy
71
72					=head1 SYNOPSIS
73
74					use IPC::Cmd qw[can_run run run_forked];
75
76					my $full_path = can_run('wget') or warn 'wget is not installed!';
77
78					### commands can be arrayrefs or strings ###
79					my $cmd = "$full_path -b theregister.co.uk";
80					my $cmd = [$full_path, '-b', 'theregister.co.uk'];
81
82					### in scalar context ###
83					my $buffer;
84					if( scalar run( command => $cmd,
85					verbose => 0,
86					buffer => \$buffer,
87					timeout => 20 )
88					) {
89					print "fetched webpage successfully: $buffer\n";
90					}
91
92
93					### in list context ###
94					my( $success, $error_message, $full_buf, $stdout_buf, $stderr_buf ) =
95					run( command => $cmd, verbose => 0 );
96
97					if( $success ) {
98					print "this is what the command printed:\n";
99					print join "", @$full_buf;
100					}
101
102					### run_forked example ###
103					my $result = run_forked("$full_path -q -O - theregister.co.uk", {'timeout' => 20});
104					if ($result->{'exit_code'} eq 0 && !$result->{'timeout'}) {
105					print "this is what wget returned:\n";
106					print $result->{'stdout'};
107					}
108
109					### check for features
110					print "IPC::Open3 available: " . IPC::Cmd->can_use_ipc_open3;
111					print "IPC::Run available: " . IPC::Cmd->can_use_ipc_run;
112					print "Can capture buffer: " . IPC::Cmd->can_capture_buffer;
113
114					### don't have IPC::Cmd be verbose, ie don't print to stdout or
115					### stderr when running commands -- default is '0'
116					$IPC::Cmd::VERBOSE = 0;
117
118
119					=head1 DESCRIPTION
120
121					IPC::Cmd allows you to run commands platform independently,
122					interactively if desired, but have them still work.
123
124					The C<can_run> function can tell you if a certain binary is installed
125					and if so where, whereas the C<run> function can actually execute any
126					of the commands you give it and give you a clear return value, as well
127					as adhere to your verbosity settings.
128
129					=head1 CLASS METHODS
130
131					=head2 $ipc_run_version = IPC::Cmd->can_use_ipc_run( [VERBOSE] )
132
133					Utility function that tells you if C<IPC::Run> is available.
134					If the C<verbose> flag is passed, it will print diagnostic messages
135					if L<IPC::Run> can not be found or loaded.
136
137					=cut
138
139
140					sub can_use_ipc_run {
141					my $self = shift;
142					my $verbose = shift \|\| 0;
143
144					### IPC::Run doesn't run on win98
145					return if IS_WIN98;
146
147					### if we don't have ipc::run, we obviously can't use it.
148					return unless can_load(
149					modules => { 'IPC::Run' => '0.55' },
150					verbose => ($WARN && $verbose),
151					);
152
153					### otherwise, we're good to go
154					return $IPC::Run::VERSION;
155					}
156
157					=head2 $ipc_open3_version = IPC::Cmd->can_use_ipc_open3( [VERBOSE] )
158
159					Utility function that tells you if C<IPC::Open3> is available.
160					If the verbose flag is passed, it will print diagnostic messages
161					if C<IPC::Open3> can not be found or loaded.
162
163					=cut
164
165
166					sub can_use_ipc_open3 {
167					my $self = shift;
168					my $verbose = shift \|\| 0;
169
170					### IPC::Open3 is not working on VMS because of a lack of fork.
171					return if IS_VMS;
172
173					### IPC::Open3 works on every non-VMS platform, but it can't
174					### capture buffers on win32 :(
175					return unless can_load(
176					modules => { map {$_ => '0.0'} qw\|IPC::Open3 IO::Select Symbol\| },
177					verbose => ($WARN && $verbose),
178					);
179
180					return $IPC::Open3::VERSION;
181					}
182
183					=head2 $bool = IPC::Cmd->can_capture_buffer
184
185					Utility function that tells you if C<IPC::Cmd> is capable of
186					capturing buffers in it's current configuration.
187
188					=cut
189
190					sub can_capture_buffer {
191					my $self = shift;
192
193					return 1 if $USE_IPC_RUN && $self->can_use_ipc_run;
194					return 1 if $USE_IPC_OPEN3 && $self->can_use_ipc_open3;
195					return;
196					}
197
198					=head2 $bool = IPC::Cmd->can_use_run_forked
199
200					Utility function that tells you if C<IPC::Cmd> is capable of
201					providing C<run_forked> on the current platform.
202
203					=head1 FUNCTIONS
204
205					=head2 $path = can_run( PROGRAM );
206
207					C<can_run> takes only one argument: the name of a binary you wish
208					to locate. C<can_run> works much like the unix binary C<which> or the bash
209					command C<type>, which scans through your path, looking for the requested
210					binary.
211
212					Unlike C<which> and C<type>, this function is platform independent and
213					will also work on, for example, Win32.
214
215					If called in a scalar context it will return the full path to the binary
216					you asked for if it was found, or C<undef> if it was not.
217
218					If called in a list context and the global variable C<$INSTANCES> is a true
219					value, it will return a list of the full paths to instances
220					of the binary where found in C<PATH>, or an empty list if it was not found.
221
222					=cut
223
224					# spent 59.5ms (27.8+31.7) within IPC::Cmd::can_run which was called: # once (27.8ms+31.7ms) by main::BEGIN@51 at line 29 of /home/hejohns/documentsNoSync/22f/490/gradescope-utils/lib/Gradescope/Color.pm sub can_run {
225	1	300ns			my $command = shift;
226
227					# a lot of VMS executables have a symbol defined
228					# check those first
229	1	900ns			if ( $^O eq 'VMS' ) {
230					require VMS::DCLsym;
231					my $syms = VMS::DCLsym->new;
232					return $command if scalar $syms->getsym( uc $command );
233					}
234
235	1	400ns			require File::Spec;
236	1	98µs			require ExtUtils::MakeMaker;
237
238	1	300ns			my @possibles;
239
240	1	3µs	1	6µs	if( File::Spec->file_name_is_absolute($command) ) { # spent 6µs making 1 call to File::Spec::Unix::file_name_is_absolute
241					return MM->maybe_command($command);
242
243					} else {
244	1	4µs	1	12µs	for my $dir ( # spent 12µs making 1 call to File::Spec::Unix::path
245					File::Spec->path,
246					( IS_WIN32 ? File::Spec->curdir : () )
247					) {
248	27	70µs	27	52µs	next if ! $dir \|\| ! -d $dir; # spent 52µs making 27 calls to IPC::Cmd::CORE:ftdir, avg 2µs/call
249	27	105µs	108	121µs	my $abs = File::Spec->catfile( IS_WIN32 ? Win32::GetShortPathName( $dir ) : $dir, $command); # spent 82µs making 27 calls to File::Spec::Unix::catfile, avg 3µs/call # spent 30µs making 27 calls to File::Spec::Unix::catdir, avg 1µs/call # spent 9µs making 54 calls to File::Spec::Unix::canonpath, avg 169ns/call
250	27	19µs	27	94µs	push @possibles, $abs if $abs = MM->maybe_command($abs); # spent 94µs making 27 calls to ExtUtils::MM_Unix::maybe_command, avg 3µs/call
251					}
252					}
253	1	400ns			return @possibles if wantarray and $INSTANCES;
254	1	3µs			return shift @possibles;
255					}
256
257					=head2 $ok \| ($ok, $err, $full_buf, $stdout_buff, $stderr_buff) = run( command => COMMAND, [verbose => BOOL, buffer => \$SCALAR, timeout => DIGIT] );
258
259					C<run> takes 4 arguments:
260
261					=over 4
262
263					=item command
264
265					This is the command to execute. It may be either a string or an array
266					reference.
267					This is a required argument.
268
269					See L<"Caveats"> for remarks on how commands are parsed and their
270					limitations.
271
272					=item verbose
273
274					This controls whether all output of a command should also be printed
275					to STDOUT/STDERR or should only be trapped in buffers (NOTE: buffers
276					require L<IPC::Run> to be installed, or your system able to work with
277					L<IPC::Open3>).
278
279					It will default to the global setting of C<$IPC::Cmd::VERBOSE>,
280					which by default is 0.
281
282					=item buffer
283
284					This will hold all the output of a command. It needs to be a reference
285					to a scalar.
286					Note that this will hold both the STDOUT and STDERR messages, and you
287					have no way of telling which is which.
288					If you require this distinction, run the C<run> command in list context
289					and inspect the individual buffers.
290
291					Of course, this requires that the underlying call supports buffers. See
292					the note on buffers above.
293
294					=item timeout
295
296					Sets the maximum time the command is allowed to run before aborting,
297					using the built-in C<alarm()> call. If the timeout is triggered, the
298					C<errorcode> in the return value will be set to an object of the
299					C<IPC::Cmd::TimeOut> class. See the L<"error message"> section below for
300					details.
301
302					Defaults to C<0>, meaning no timeout is set.
303
304					=back
305
306					C<run> will return a simple C<true> or C<false> when called in scalar
307					context.
308					In list context, you will be returned a list of the following items:
309
310					=over 4
311
312					=item success
313
314					A simple boolean indicating if the command executed without errors or
315					not.
316
317					=item error message
318
319					If the first element of the return value (C<success>) was 0, then some
320					error occurred. This second element is the error message the command
321					you requested exited with, if available. This is generally a pretty
322					printed value of C<$?> or C<$@>. See C<perldoc perlvar> for details on
323					what they can contain.
324					If the error was a timeout, the C<error message> will be prefixed with
325					the string C<IPC::Cmd::TimeOut>, the timeout class.
326
327					=item full_buffer
328
329					This is an array reference containing all the output the command
330					generated.
331					Note that buffers are only available if you have L<IPC::Run> installed,
332					or if your system is able to work with L<IPC::Open3> -- see below).
333					Otherwise, this element will be C<undef>.
334
335					=item out_buffer
336
337					This is an array reference containing all the output sent to STDOUT the
338					command generated. The notes from L<"full_buffer"> apply.
339
340					=item error_buffer
341
342					This is an arrayreference containing all the output sent to STDERR the
343					command generated. The notes from L<"full_buffer"> apply.
344
345
346					=back
347
348					See the L<"HOW IT WORKS"> section below to see how C<IPC::Cmd> decides
349					what modules or function calls to use when issuing a command.
350
351					=cut
352
353	2	900ns			{ my @acc = qw[ok error _fds];
354
355					### autogenerate accessors ###
356	1	500ns			for my $key ( @acc ) {
357	2	2.71ms	2	13µs	# spent 9µs (6+4) within IPC::Cmd::BEGIN@357 which was called: # once (6µs+4µs) by main::BEGIN@30 at line 357 no strict 'refs'; # spent 9µs making 1 call to IPC::Cmd::BEGIN@357 # spent 4µs making 1 call to strict::unimport
358					*{__PACKAGE__."::$key"} = sub {
359					$_[0]->{$key} = $_[1] if @_ > 1;
360					return $_[0]->{$key};
361					}
362	3	6µs			}
363					}
364
365					sub can_use_run_forked {
366					return $CAN_USE_RUN_FORKED eq "1";
367					}
368
369					sub get_monotonic_time {
370					if ($HAVE_MONOTONIC) {
371					return Time::HiRes::clock_gettime(&Time::HiRes::CLOCK_MONOTONIC);
372					}
373					else {
374					return time();
375					}
376					}
377
378					sub adjust_monotonic_start_time {
379					my ($ref_vars, $now, $previous) = @_;
380
381					# workaround only for those systems which don't have
382					# Time::HiRes::CLOCK_MONOTONIC (Mac OSX in particular)
383					return if $HAVE_MONOTONIC;
384
385					# don't have previous monotonic value (only happens once
386					# in the beginning of the program execution)
387					return unless $previous;
388
389					my $time_diff = $now - $previous;
390
391					# adjust previously saved time with the skew value which is
392					# either negative when clock moved back or more than 5 seconds --
393					# assuming that event loop does happen more often than once
394					# per five seconds, which might not be always true (!) but
395					# hopefully that's ok, because it's just a workaround
396					if ($time_diff > 5 \|\| $time_diff < 0) {
397					foreach my $ref_var (@{$ref_vars}) {
398					if (defined($$ref_var)) {
399					$$ref_var = $$ref_var + $time_diff;
400					}
401					}
402					}
403					}
404
405					sub uninstall_signals {
406					return unless defined($IPC::Cmd::{'__old_signals'});
407
408					foreach my $sig_name (keys %{$IPC::Cmd::{'__old_signals'}}) {
409					$SIG{$sig_name} = $IPC::Cmd::{'__old_signals'}->{$sig_name};
410					}
411					}
412
413					# incompatible with POSIX::SigAction
414					#
415					sub install_layered_signal {
416					my ($s, $handler_code) = @_;
417
418					my %available_signals = map {$_ => 1} keys %SIG;
419
420					Carp::confess("install_layered_signal got nonexistent signal name [$s]")
421					unless defined($available_signals{$s});
422					Carp::confess("install_layered_signal expects coderef")
423					if !ref($handler_code) \|\| ref($handler_code) ne 'CODE';
424
425					$IPC::Cmd::{'__old_signals'} = {}
426					unless defined($IPC::Cmd::{'__old_signals'});
427					$IPC::Cmd::{'__old_signals'}->{$s} = $SIG{$s};
428
429					my $previous_handler = $SIG{$s};
430
431					my $sig_handler = sub {
432					my ($called_sig_name, @sig_param) = @_;
433
434					# $s is a closure referring to real signal name
435					# for which this handler is being installed.
436					# it is used to distinguish between
437					# real signal handlers and aliased signal handlers
438					my $signal_name = $s;
439
440					# $called_sig_name is a signal name which
441					# was passed to this signal handler;
442					# it doesn't equal $signal_name in case
443					# some signal handlers in %SIG point
444					# to other signal handler (CHLD and CLD,
445					# ABRT and IOT)
446					#
447					# initial signal handler for aliased signal
448					# calls some other signal handler which
449					# should not execute the same handler_code again
450					if ($called_sig_name eq $signal_name) {
451					$handler_code->($signal_name);
452					}
453
454					# run original signal handler if any (including aliased)
455					#
456					if (ref($previous_handler)) {
457					$previous_handler->($called_sig_name, @sig_param);
458					}
459					};
460
461					$SIG{$s} = $sig_handler;
462					}
463
464					# give process a chance sending TERM,
465					# waiting for a while (2 seconds)
466					# and killing it with KILL
467					sub kill_gently {
468					my ($pid, $opts) = @_;
469
470					require POSIX;
471
472					$opts = {} unless $opts;
473					$opts->{'wait_time'} = 2 unless defined($opts->{'wait_time'});
474					$opts->{'first_kill_type'} = 'just_process' unless $opts->{'first_kill_type'};
475					$opts->{'final_kill_type'} = 'just_process' unless $opts->{'final_kill_type'};
476
477					if ($opts->{'first_kill_type'} eq 'just_process') {
478					kill(15, $pid);
479					}
480					elsif ($opts->{'first_kill_type'} eq 'process_group') {
481					kill(-15, $pid);
482					}
483
484					my $do_wait = 1;
485					my $child_finished = 0;
486
487					my $wait_start_time = get_monotonic_time();
488					my $now;
489					my $previous_monotonic_value;
490
491					while ($do_wait) {
492					$previous_monotonic_value = $now;
493					$now = get_monotonic_time();
494
495					adjust_monotonic_start_time([\$wait_start_time], $now, $previous_monotonic_value);
496
497					if ($now > $wait_start_time + $opts->{'wait_time'}) {
498					$do_wait = 0;
499					next;
500					}
501
502					my $waitpid = waitpid($pid, POSIX::WNOHANG);
503
504					if ($waitpid eq -1) {
505					$child_finished = 1;
506					$do_wait = 0;
507					next;
508					}
509
510					Time::HiRes::usleep(250000); # quarter of a second
511					}
512
513					if (!$child_finished) {
514					if ($opts->{'final_kill_type'} eq 'just_process') {
515					kill(9, $pid);
516					}
517					elsif ($opts->{'final_kill_type'} eq 'process_group') {
518					kill(-9, $pid);
519					}
520					}
521					}
522
523					sub open3_run {
524					my ($cmd, $opts) = @_;
525
526					$opts = {} unless $opts;
527
528					my $child_in = FileHandle->new;
529					my $child_out = FileHandle->new;
530					my $child_err = FileHandle->new;
531					$child_out->autoflush(1);
532					$child_err->autoflush(1);
533
534					my $pid = open3($child_in, $child_out, $child_err, $cmd);
535					Time::HiRes::usleep(1) if IS_HPUX;
536
537					# will consider myself orphan if my ppid changes
538					# from this one:
539					my $original_ppid = $opts->{'original_ppid'};
540
541					# push my child's pid to our parent
542					# so in case i am killed parent
543					# could stop my child (search for
544					# child_child_pid in parent code)
545					if ($opts->{'parent_info'}) {
546					my $ps = $opts->{'parent_info'};
547					print $ps "spawned $pid\n";
548					}
549
550					if ($child_in && $child_out->opened && $opts->{'child_stdin'}) {
551					# If the child process dies for any reason,
552					# the next write to CHLD_IN is likely to generate
553					# a SIGPIPE in the parent, which is fatal by default.
554					# So you may wish to handle this signal.
555					#
556					# from http://perldoc.perl.org/IPC/Open3.html,
557					# absolutely needed to catch piped commands errors.
558					#
559					local $SIG{'PIPE'} = sub { 1; };
560
561					print $child_in $opts->{'child_stdin'};
562					}
563					close($child_in);
564
565					my $child_output = {
566					'out' => $child_out->fileno,
567					'err' => $child_err->fileno,
568					$child_out->fileno => {
569					'parent_socket' => $opts->{'parent_stdout'},
570					'scalar_buffer' => "",
571					'child_handle' => $child_out,
572					'block_size' => ($child_out->stat)[11] \|\| 1024,
573					},
574					$child_err->fileno => {
575					'parent_socket' => $opts->{'parent_stderr'},
576					'scalar_buffer' => "",
577					'child_handle' => $child_err,
578					'block_size' => ($child_err->stat)[11] \|\| 1024,
579					},
580					};
581
582					my $select = IO::Select->new();
583					$select->add($child_out, $child_err);
584
585					# pass any signal to the child
586					# effectively creating process
587					# strongly attached to the child:
588					# it will terminate only after child
589					# has terminated (except for SIGKILL,
590					# which is specially handled)
591					SIGNAL: foreach my $s (keys %SIG) {
592					next SIGNAL if $s eq '__WARN__' or $s eq '__DIE__'; # Skip and don't clobber __DIE__ & __WARN__
593					my $sig_handler;
594					$sig_handler = sub {
595					kill("$s", $pid);
596					$SIG{$s} = $sig_handler;
597					};
598					$SIG{$s} = $sig_handler;
599					}
600
601					my $child_finished = 0;
602
603					my $real_exit;
604					my $exit_value;
605
606					while(!$child_finished) {
607
608					# parent was killed otherwise we would have got
609					# the same signal as parent and process it same way
610					if (getppid() != $original_ppid) {
611
612					# end my process group with all the children
613					# (i am the process group leader, so my pid
614					# equals to the process group id)
615					#
616					# same thing which is done
617					# with $opts->{'clean_up_children'}
618					# in run_forked
619					#
620					kill(-9, $$);
621
622					POSIX::_exit 1;
623					}
624
625					my $waitpid = waitpid($pid, POSIX::WNOHANG);
626
627					# child finished, catch it's exit status
628					if ($waitpid ne 0 && $waitpid ne -1) {
629					$real_exit = $?;
630					$exit_value = $? >> 8;
631					}
632
633					if ($waitpid eq -1) {
634					$child_finished = 1;
635					}
636
637
638					my $ready_fds = [];
639					push @{$ready_fds}, $select->can_read(1/100);
640
641					READY_FDS: while (scalar(@{$ready_fds})) {
642					my $fd = shift @{$ready_fds};
643					$ready_fds = [grep {$_ ne $fd} @{$ready_fds}];
644
645					my $str = $child_output->{$fd->fileno};
646					Carp::confess("child stream not found: $fd") unless $str;
647
648					my $data;
649					my $count = $fd->sysread($data, $str->{'block_size'});
650
651					if ($count) {
652					if ($str->{'parent_socket'}) {
653					my $ph = $str->{'parent_socket'};
654					print $ph $data;
655					}
656					else {
657					$str->{'scalar_buffer'} .= $data;
658					}
659					}
660					elsif ($count eq 0) {
661					$select->remove($fd);
662					$fd->close();
663					}
664					else {
665					Carp::confess("error during sysread: " . $!);
666					}
667
668					push @{$ready_fds}, $select->can_read(1/100) if $child_finished;
669					}
670
671					Time::HiRes::usleep(1);
672					}
673
674					# since we've successfully reaped the child,
675					# let our parent know about this.
676					#
677					if ($opts->{'parent_info'}) {
678					my $ps = $opts->{'parent_info'};
679
680					# child was killed, inform parent
681					if ($real_exit & 127) {
682					print $ps "$pid killed with " . ($real_exit & 127) . "\n";
683					}
684
685					print $ps "reaped $pid\n";
686					}
687
688					if ($opts->{'parent_stdout'} \|\| $opts->{'parent_stderr'}) {
689					return $exit_value;
690					}
691					else {
692					return {
693					'stdout' => $child_output->{$child_output->{'out'}}->{'scalar_buffer'},
694					'stderr' => $child_output->{$child_output->{'err'}}->{'scalar_buffer'},
695					'exit_code' => $exit_value,
696					};
697					}
698					}
699
700					=head2 $hashref = run_forked( COMMAND, { child_stdin => SCALAR, timeout => DIGIT, stdout_handler => CODEREF, stderr_handler => CODEREF} );
701
702					C<run_forked> is used to execute some program or a coderef,
703					optionally feed it with some input, get its return code
704					and output (both stdout and stderr into separate buffers).
705					In addition, it allows to terminate the program
706					if it takes too long to finish.
707
708					The important and distinguishing feature of run_forked
709					is execution timeout which at first seems to be
710					quite a simple task but if you think
711					that the program which you're spawning
712					might spawn some children itself (which
713					in their turn could do the same and so on)
714					it turns out to be not a simple issue.
715
716					C<run_forked> is designed to survive and
717					successfully terminate almost any long running task,
718					even a fork bomb in case your system has the resources
719					to survive during given timeout.
720
721					This is achieved by creating separate watchdog process
722					which spawns the specified program in a separate
723					process session and supervises it: optionally
724					feeds it with input, stores its exit code,
725					stdout and stderr, terminates it in case
726					it runs longer than specified.
727
728					Invocation requires the command to be executed or a coderef and optionally a hashref of options:
729
730					=over
731
732					=item C<timeout>
733
734					Specify in seconds how long to run the command before it is killed with SIG_KILL (9),
735					which effectively terminates it and all of its children (direct or indirect).
736
737					=item C<child_stdin>
738
739					Specify some text that will be passed into the C<STDIN> of the executed program.
740
741					=item C<stdout_handler>
742
743					Coderef of a subroutine to call when a portion of data is received on
744					STDOUT from the executing program.
745
746					=item C<stderr_handler>
747
748					Coderef of a subroutine to call when a portion of data is received on
749					STDERR from the executing program.
750
751					=item C<wait_loop_callback>
752
753					Coderef of a subroutine to call inside of the main waiting loop
754					(while C<run_forked> waits for the external to finish or fail).
755					It is useful to stop running external process before it ends
756					by itself, e.g.
757
758					my $r = run_forked("some external command", {
759					'wait_loop_callback' => sub {
760					if (condition) {
761					kill(1, $$);
762					}
763					},
764					'terminate_on_signal' => 'HUP',
765					});
766
767					Combined with C<stdout_handler> and C<stderr_handler> allows terminating
768					external command based on its output. Could also be used as a timer
769					without engaging with L<alarm> (signals).
770
771					Remember that this code could be called every millisecond (depending
772					on the output which external command generates), so try to make it
773					as lightweight as possible.
774
775					=item C<discard_output>
776
777					Discards the buffering of the standard output and standard errors for return by run_forked().
778					With this option you have to use the std*_handlers to read what the command outputs.
779					Useful for commands that send a lot of output.
780
781					=item C<terminate_on_parent_sudden_death>
782
783					Enable this option if you wish all spawned processes to be killed if the initially spawned
784					process (the parent) is killed or dies without waiting for child processes.
785
786					=back
787
788					C<run_forked> will return a HASHREF with the following keys:
789
790					=over
791
792					=item C<exit_code>
793
794					The exit code of the executed program.
795
796					=item C<timeout>
797
798					The number of seconds the program ran for before being terminated, or 0 if no timeout occurred.
799
800					=item C<stdout>
801
802					Holds the standard output of the executed command (or empty string if
803					there was no STDOUT output or if C<discard_output> was used; it's always defined!)
804
805					=item C<stderr>
806
807					Holds the standard error of the executed command (or empty string if
808					there was no STDERR output or if C<discard_output> was used; it's always defined!)
809
810					=item C<merged>
811
812					Holds the standard output and error of the executed command merged into one stream
813					(or empty string if there was no output at all or if C<discard_output> was used; it's always defined!)
814
815					=item C<err_msg>
816
817					Holds some explanation in the case of an error.
818
819					=back
820
821					=cut
822
823					sub run_forked {
824					### container to store things in
825					my $self = bless {}, __PACKAGE__;
826
827					if (!can_use_run_forked()) {
828					Carp::carp("run_forked is not available: $CAN_USE_RUN_FORKED");
829					return;
830					}
831
832					require POSIX;
833
834					my ($cmd, $opts) = @_;
835					if (ref($cmd) eq 'ARRAY') {
836					$cmd = join(" ", @{$cmd});
837					}
838
839					if (!$cmd) {
840					Carp::carp("run_forked expects command to run");
841					return;
842					}
843
844					$opts = {} unless $opts;
845					$opts->{'timeout'} = 0 unless $opts->{'timeout'};
846					$opts->{'terminate_wait_time'} = 2 unless defined($opts->{'terminate_wait_time'});
847
848					# turned on by default
849					$opts->{'clean_up_children'} = 1 unless defined($opts->{'clean_up_children'});
850
851					# sockets to pass child stdout to parent
852					my $child_stdout_socket;
853					my $parent_stdout_socket;
854
855					# sockets to pass child stderr to parent
856					my $child_stderr_socket;
857					my $parent_stderr_socket;
858
859					# sockets for child -> parent internal communication
860					my $child_info_socket;
861					my $parent_info_socket;
862
863					socketpair($child_stdout_socket, $parent_stdout_socket, &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC) \|\|
864					Carp::confess ("socketpair: $!");
865					socketpair($child_stderr_socket, $parent_stderr_socket, &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC) \|\|
866					Carp::confess ("socketpair: $!");
867					socketpair($child_info_socket, $parent_info_socket, &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC) \|\|
868					Carp::confess ("socketpair: $!");
869
870					$child_stdout_socket->autoflush(1);
871					$parent_stdout_socket->autoflush(1);
872					$child_stderr_socket->autoflush(1);
873					$parent_stderr_socket->autoflush(1);
874					$child_info_socket->autoflush(1);
875					$parent_info_socket->autoflush(1);
876
877					my $start_time = get_monotonic_time();
878
879					my $pid;
880					my $ppid = $$;
881					if ($pid = fork) {
882
883					# we are a parent
884					close($parent_stdout_socket);
885					close($parent_stderr_socket);
886					close($parent_info_socket);
887
888					my $flags;
889
890					# prepare sockets to read from child
891
892					$flags = fcntl($child_stdout_socket, POSIX::F_GETFL, 0) \|\| Carp::confess "can't fnctl F_GETFL: $!";
893					$flags \|= POSIX::O_NONBLOCK;
894					fcntl($child_stdout_socket, POSIX::F_SETFL, $flags) \|\| Carp::confess "can't fnctl F_SETFL: $!";
895
896					$flags = fcntl($child_stderr_socket, POSIX::F_GETFL, 0) \|\| Carp::confess "can't fnctl F_GETFL: $!";
897					$flags \|= POSIX::O_NONBLOCK;
898					fcntl($child_stderr_socket, POSIX::F_SETFL, $flags) \|\| Carp::confess "can't fnctl F_SETFL: $!";
899
900					$flags = fcntl($child_info_socket, POSIX::F_GETFL, 0) \|\| Carp::confess "can't fnctl F_GETFL: $!";
901					$flags \|= POSIX::O_NONBLOCK;
902					fcntl($child_info_socket, POSIX::F_SETFL, $flags) \|\| Carp::confess "can't fnctl F_SETFL: $!";
903
904					# print "child $pid started\n";
905
906					my $child_output = {
907					$child_stdout_socket->fileno => {
908					'scalar_buffer' => "",
909					'child_handle' => $child_stdout_socket,
910					'block_size' => ($child_stdout_socket->stat)[11] \|\| 1024,
911					'protocol' => 'stdout',
912					},
913					$child_stderr_socket->fileno => {
914					'scalar_buffer' => "",
915					'child_handle' => $child_stderr_socket,
916					'block_size' => ($child_stderr_socket->stat)[11] \|\| 1024,
917					'protocol' => 'stderr',
918					},
919					$child_info_socket->fileno => {
920					'scalar_buffer' => "",
921					'child_handle' => $child_info_socket,
922					'block_size' => ($child_info_socket->stat)[11] \|\| 1024,
923					'protocol' => 'info',
924					},
925					};
926
927					my $select = IO::Select->new();
928					$select->add($child_stdout_socket, $child_stderr_socket, $child_info_socket);
929
930					my $child_timedout = 0;
931					my $child_finished = 0;
932					my $child_stdout = '';
933					my $child_stderr = '';
934					my $child_merged = '';
935					my $child_exit_code = 0;
936					my $child_killed_by_signal = 0;
937					my $parent_died = 0;
938
939					my $last_parent_check = 0;
940					my $got_sig_child = 0;
941					my $got_sig_quit = 0;
942					my $orig_sig_child = $SIG{'CHLD'};
943
944					$SIG{'CHLD'} = sub { $got_sig_child = get_monotonic_time(); };
945
946					if ($opts->{'terminate_on_signal'}) {
947					install_layered_signal($opts->{'terminate_on_signal'}, sub { $got_sig_quit = time(); });
948					}
949
950					my $child_child_pid;
951					my $now;
952					my $previous_monotonic_value;
953
954					while (!$child_finished) {
955					$previous_monotonic_value = $now;
956					$now = get_monotonic_time();
957
958					adjust_monotonic_start_time([\$start_time, \$last_parent_check, \$got_sig_child], $now, $previous_monotonic_value);
959
960					if ($opts->{'terminate_on_parent_sudden_death'}) {
961					# check for parent once each five seconds
962					if ($now > $last_parent_check + 5) {
963					if (getppid() eq "1") {
964					kill_gently ($pid, {
965					'first_kill_type' => 'process_group',
966					'final_kill_type' => 'process_group',
967					'wait_time' => $opts->{'terminate_wait_time'}
968					});
969					$parent_died = 1;
970					}
971
972					$last_parent_check = $now;
973					}
974					}
975
976					# user specified timeout
977					if ($opts->{'timeout'}) {
978					if ($now > $start_time + $opts->{'timeout'}) {
979					kill_gently ($pid, {
980					'first_kill_type' => 'process_group',
981					'final_kill_type' => 'process_group',
982					'wait_time' => $opts->{'terminate_wait_time'}
983					});
984					$child_timedout = 1;
985					}
986					}
987
988					# give OS 10 seconds for correct return of waitpid,
989					# kill process after that and finish wait loop;
990					# shouldn't ever happen -- remove this code?
991					if ($got_sig_child) {
992					if ($now > $got_sig_child + 10) {
993					print STDERR "waitpid did not return -1 for 10 seconds after SIG_CHLD, killing [$pid]\n";
994					kill (-9, $pid);
995					$child_finished = 1;
996					}
997					}
998
999					if ($got_sig_quit) {
1000					kill_gently ($pid, {
1001					'first_kill_type' => 'process_group',
1002					'final_kill_type' => 'process_group',
1003					'wait_time' => $opts->{'terminate_wait_time'}
1004					});
1005					$child_finished = 1;
1006					}
1007
1008					my $waitpid = waitpid($pid, POSIX::WNOHANG);
1009
1010					# child finished, catch it's exit status
1011					if ($waitpid ne 0 && $waitpid ne -1) {
1012					$child_exit_code = $? >> 8;
1013					}
1014
1015					if ($waitpid eq -1) {
1016					$child_finished = 1;
1017					}
1018
1019					my $ready_fds = [];
1020					push @{$ready_fds}, $select->can_read(1/100);
1021
1022					READY_FDS: while (scalar(@{$ready_fds})) {
1023					my $fd = shift @{$ready_fds};
1024					$ready_fds = [grep {$_ ne $fd} @{$ready_fds}];
1025
1026					my $str = $child_output->{$fd->fileno};
1027					Carp::confess("child stream not found: $fd") unless $str;
1028
1029					my $data = "";
1030					my $count = $fd->sysread($data, $str->{'block_size'});
1031
1032					if ($count) {
1033					# extract all the available lines and store the rest in temporary buffer
1034					if ($data =~ /(.+\n)([^\n]*)/so) {
1035					$data = $str->{'scalar_buffer'} . $1;
1036					$str->{'scalar_buffer'} = $2 \|\| "";
1037					}
1038					else {
1039					$str->{'scalar_buffer'} .= $data;
1040					$data = "";
1041					}
1042					}
1043					elsif ($count eq 0) {
1044					$select->remove($fd);
1045					$fd->close();
1046					if ($str->{'scalar_buffer'}) {
1047					$data = $str->{'scalar_buffer'} . "\n";
1048					}
1049					}
1050					else {
1051					Carp::confess("error during sysread on [$fd]: " . $!);
1052					}
1053
1054					# $data contains only full lines (or last line if it was unfinished read
1055					# or now new-line in the output of the child); dat is processed
1056					# according to the "protocol" of socket
1057					if ($str->{'protocol'} eq 'info') {
1058					if ($data =~ /^spawned ([0-9]+?)\n(.*?)/so) {
1059					$child_child_pid = $1;
1060					$data = $2;
1061					}
1062					if ($data =~ /^reaped ([0-9]+?)\n(.*?)/so) {
1063					$child_child_pid = undef;
1064					$data = $2;
1065					}
1066					if ($data =~ /^[\d]+ killed with ([0-9]+?)\n(.*?)/so) {
1067					$child_killed_by_signal = $1;
1068					$data = $2;
1069					}
1070
1071					# we don't expect any other data in info socket, so it's
1072					# some strange violation of protocol, better know about this
1073					if ($data) {
1074					Carp::confess("info protocol violation: [$data]");
1075					}
1076					}
1077					if ($str->{'protocol'} eq 'stdout') {
1078					if (!$opts->{'discard_output'}) {
1079					$child_stdout .= $data;
1080					$child_merged .= $data;
1081					}
1082
1083					if ($opts->{'stdout_handler'} && ref($opts->{'stdout_handler'}) eq 'CODE') {
1084					$opts->{'stdout_handler'}->($data);
1085					}
1086					}
1087					if ($str->{'protocol'} eq 'stderr') {
1088					if (!$opts->{'discard_output'}) {
1089					$child_stderr .= $data;
1090					$child_merged .= $data;
1091					}
1092
1093					if ($opts->{'stderr_handler'} && ref($opts->{'stderr_handler'}) eq 'CODE') {
1094					$opts->{'stderr_handler'}->($data);
1095					}
1096					}
1097
1098					# process may finish (waitpid returns -1) before
1099					# we've read all of its output because of buffering;
1100					# so try to read all the way it is possible to read
1101					# in such case - this shouldn't be too much (unless
1102					# the buffer size is HUGE -- should introduce
1103					# another counter in such case, maybe later)
1104					#
1105					push @{$ready_fds}, $select->can_read(1/100) if $child_finished;
1106					}
1107
1108					if ($opts->{'wait_loop_callback'} && ref($opts->{'wait_loop_callback'}) eq 'CODE') {
1109					$opts->{'wait_loop_callback'}->();
1110					}
1111
1112					Time::HiRes::usleep(1);
1113					}
1114
1115					# $child_pid_pid is not defined in two cases:
1116					# * when our child was killed before
1117					# it had chance to tell us the pid
1118					# of the child it spawned. we can do
1119					# nothing in this case :(
1120					# * our child successfully reaped its child,
1121					# we have nothing left to do in this case
1122					#
1123					# defined $child_pid_pid means child's child
1124					# has not died but nobody is waiting for it,
1125					# killing it brutally.
1126					#
1127					if ($child_child_pid) {
1128					kill_gently($child_child_pid);
1129					}
1130
1131					# in case there are forks in child which
1132					# do not forward or process signals (TERM) correctly
1133					# kill whole child process group, effectively trying
1134					# not to return with some children or their parts still running
1135					#
1136					# to be more accurate -- we need to be sure
1137					# that this is process group created by our child
1138					# (and not some other process group with the same pgid,
1139					# created just after death of our child) -- fortunately
1140					# this might happen only when process group ids
1141					# are reused quickly (there are lots of processes
1142					# spawning new process groups for example)
1143					#
1144					if ($opts->{'clean_up_children'}) {
1145					kill(-9, $pid);
1146					}
1147
1148					# print "child $pid finished\n";
1149
1150					close($child_stdout_socket);
1151					close($child_stderr_socket);
1152					close($child_info_socket);
1153
1154					my $o = {
1155					'stdout' => $child_stdout,
1156					'stderr' => $child_stderr,
1157					'merged' => $child_merged,
1158					'timeout' => $child_timedout ? $opts->{'timeout'} : 0,
1159					'exit_code' => $child_exit_code,
1160					'parent_died' => $parent_died,
1161					'killed_by_signal' => $child_killed_by_signal,
1162					'child_pgid' => $pid,
1163					'cmd' => $cmd,
1164					};
1165
1166					my $err_msg = '';
1167					if ($o->{'exit_code'}) {
1168					$err_msg .= "exited with code [$o->{'exit_code'}]\n";
1169					}
1170					if ($o->{'timeout'}) {
1171					$err_msg .= "ran more than [$o->{'timeout'}] seconds\n";
1172					}
1173					if ($o->{'parent_died'}) {
1174					$err_msg .= "parent died\n";
1175					}
1176					if ($o->{'stdout'} && !$opts->{'non_empty_stdout_ok'}) {
1177					$err_msg .= "stdout:\n" . $o->{'stdout'} . "\n";
1178					}
1179					if ($o->{'stderr'}) {
1180					$err_msg .= "stderr:\n" . $o->{'stderr'} . "\n";
1181					}
1182					if ($o->{'killed_by_signal'}) {
1183					$err_msg .= "killed by signal [" . $o->{'killed_by_signal'} . "]\n";
1184					}
1185					$o->{'err_msg'} = $err_msg;
1186
1187					if ($orig_sig_child) {
1188					$SIG{'CHLD'} = $orig_sig_child;
1189					}
1190					else {
1191					delete($SIG{'CHLD'});
1192					}
1193
1194					uninstall_signals();
1195
1196					return $o;
1197					}
1198					else {
1199					Carp::confess("cannot fork: $!") unless defined($pid);
1200
1201					# create new process session for open3 call,
1202					# so we hopefully can kill all the subprocesses
1203					# which might be spawned in it (except for those
1204					# which do setsid theirselves -- can't do anything
1205					# with those)
1206
1207					POSIX::setsid() == -1 and Carp::confess("Error running setsid: " . $!);
1208
1209					if ($opts->{'child_BEGIN'} && ref($opts->{'child_BEGIN'}) eq 'CODE') {
1210					$opts->{'child_BEGIN'}->();
1211					}
1212
1213					close($child_stdout_socket);
1214					close($child_stderr_socket);
1215					close($child_info_socket);
1216
1217					my $child_exit_code;
1218
1219					# allow both external programs
1220					# and internal perl calls
1221					if (!ref($cmd)) {
1222					$child_exit_code = open3_run($cmd, {
1223					'parent_info' => $parent_info_socket,
1224					'parent_stdout' => $parent_stdout_socket,
1225					'parent_stderr' => $parent_stderr_socket,
1226					'child_stdin' => $opts->{'child_stdin'},
1227					'original_ppid' => $ppid,
1228					});
1229					}
1230					elsif (ref($cmd) eq 'CODE') {
1231					# reopen STDOUT and STDERR for child code:
1232					# https://rt.cpan.org/Ticket/Display.html?id=85912
1233					open STDOUT, '>&', $parent_stdout_socket \|\| Carp::confess("Unable to reopen STDOUT: $!\n");
1234					open STDERR, '>&', $parent_stderr_socket \|\| Carp::confess("Unable to reopen STDERR: $!\n");
1235
1236					$child_exit_code = $cmd->({
1237					'opts' => $opts,
1238					'parent_info' => $parent_info_socket,
1239					'parent_stdout' => $parent_stdout_socket,
1240					'parent_stderr' => $parent_stderr_socket,
1241					'child_stdin' => $opts->{'child_stdin'},
1242					});
1243					}
1244					else {
1245					print $parent_stderr_socket "Invalid command reference: " . ref($cmd) . "\n";
1246					$child_exit_code = 1;
1247					}
1248
1249					close($parent_stdout_socket);
1250					close($parent_stderr_socket);
1251					close($parent_info_socket);
1252
1253					if ($opts->{'child_END'} && ref($opts->{'child_END'}) eq 'CODE') {
1254					$opts->{'child_END'}->();
1255					}
1256
1257					$\| = 1;
1258					POSIX::_exit $child_exit_code;
1259					}
1260					}
1261
1262					sub run {
1263					### container to store things in
1264					my $self = bless {}, __PACKAGE__;
1265
1266					my %hash = @_;
1267
1268					### if the user didn't provide a buffer, we'll store it here.
1269					my $def_buf = '';
1270
1271					my($verbose,$cmd,$buffer,$timeout);
1272					my $tmpl = {
1273					verbose => { default => $VERBOSE, store => \$verbose },
1274					buffer => { default => \$def_buf, store => \$buffer },
1275					command => { required => 1, store => \$cmd,
1276					allow => sub { !ref($_[0]) or ref($_[0]) eq 'ARRAY' },
1277					},
1278					timeout => { default => 0, store => \$timeout },
1279					};
1280
1281					unless( check( $tmpl, \%hash, $VERBOSE ) ) {
1282					Carp::carp( loc( "Could not validate input: %1",
1283					Params::Check->last_error ) );
1284					return;
1285					};
1286
1287					$cmd = _quote_args_vms( $cmd ) if IS_VMS;
1288
1289					### strip any empty elements from $cmd if present
1290					if ( $ALLOW_NULL_ARGS ) {
1291					$cmd = [ grep { defined } @$cmd ] if ref $cmd;
1292					}
1293					else {
1294					$cmd = [ grep { defined && length } @$cmd ] if ref $cmd;
1295					}
1296
1297					my $pp_cmd = (ref $cmd ? "@$cmd" : $cmd);
1298					print loc("Running [%1]...\n", $pp_cmd ) if $verbose;
1299
1300					### did the user pass us a buffer to fill or not? if so, set this
1301					### flag so we know what is expected of us
1302					### XXX this is now being ignored. in the future, we could add diagnostic
1303					### messages based on this logic
1304					#my $user_provided_buffer = $buffer == \$def_buf ? 0 : 1;
1305
1306					### buffers that are to be captured
1307					my( @buffer, @buff_err, @buff_out );
1308
1309					### capture STDOUT
1310					my $_out_handler = sub {
1311					my $buf = shift;
1312					return unless defined $buf;
1313
1314					print STDOUT $buf if $verbose;
1315					push @buffer, $buf;
1316					push @buff_out, $buf;
1317					};
1318
1319					### capture STDERR
1320					my $_err_handler = sub {
1321					my $buf = shift;
1322					return unless defined $buf;
1323
1324					print STDERR $buf if $verbose;
1325					push @buffer, $buf;
1326					push @buff_err, $buf;
1327					};
1328
1329
1330					### flag to indicate we have a buffer captured
1331					my $have_buffer = $self->can_capture_buffer ? 1 : 0;
1332
1333					### flag indicating if the subcall went ok
1334					my $ok;
1335
1336					### don't look at previous errors:
1337					local $?;
1338					local $@;
1339					local $!;
1340
1341					### we might be having a timeout set
1342					eval {
1343					local $SIG{ALRM} = sub { die bless sub {
1344					ALARM_CLASS .
1345					qq[: Command '$pp_cmd' aborted by alarm after $timeout seconds]
1346					}, ALARM_CLASS } if $timeout;
1347					alarm $timeout \|\| 0;
1348
1349					### IPC::Run is first choice if $USE_IPC_RUN is set.
1350					if( !IS_WIN32 and $USE_IPC_RUN and $self->can_use_ipc_run( 1 ) ) {
1351					### ipc::run handlers needs the command as a string or an array ref
1352
1353					$self->_debug( "# Using IPC::Run. Have buffer: $have_buffer" )
1354					if $DEBUG;
1355
1356					$ok = $self->_ipc_run( $cmd, $_out_handler, $_err_handler );
1357
1358					### since IPC::Open3 works on all platforms, and just fails on
1359					### win32 for capturing buffers, do that ideally
1360					} elsif ( $USE_IPC_OPEN3 and $self->can_use_ipc_open3( 1 ) ) {
1361
1362					$self->_debug("# Using IPC::Open3. Have buffer: $have_buffer")
1363					if $DEBUG;
1364
1365					### in case there are pipes in there;
1366					### IPC::Open3 will call exec and exec will do the right thing
1367
1368					my $method = IS_WIN32 ? '_open3_run_win32' : '_open3_run';
1369
1370					$ok = $self->$method(
1371					$cmd, $_out_handler, $_err_handler, $verbose
1372					);
1373
1374					### if we are allowed to run verbose, just dispatch the system command
1375					} else {
1376					$self->_debug( "# Using system(). Have buffer: $have_buffer" )
1377					if $DEBUG;
1378					$ok = $self->_system_run( $cmd, $verbose );
1379					}
1380
1381					alarm 0;
1382					};
1383
1384					### restore STDIN after duping, or STDIN will be closed for
1385					### this current perl process!
1386					$self->__reopen_fds( @{ $self->_fds} ) if $self->_fds;
1387
1388					my $err;
1389					unless( $ok ) {
1390					### alarm happened
1391					if ( $@ and ref $@ and $@->isa( ALARM_CLASS ) ) {
1392					$err = $@->(); # the error code is an expired alarm
1393
1394					### another error happened, set by the dispatchub
1395					} else {
1396					$err = $self->error;
1397					}
1398					}
1399
1400					### fill the buffer;
1401					$$buffer = join '', @buffer if @buffer;
1402
1403					### return a list of flags and buffers (if available) in list
1404					### context, or just a simple 'ok' in scalar
1405					return wantarray
1406					? $have_buffer
1407					? ($ok, $err, \@buffer, \@buff_out, \@buff_err)
1408					: ($ok, $err )
1409					: $ok
1410
1411
1412					}
1413
1414					sub _open3_run_win32 {
1415					my $self = shift;
1416					my $cmd = shift;
1417					my $outhand = shift;
1418					my $errhand = shift;
1419
1420					require Socket;
1421
1422					my $pipe = sub {
1423					socketpair($_[0], $_[1], &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC)
1424					or return undef;
1425					shutdown($_[0], 1); # No more writing for reader
1426					shutdown($_[1], 0); # No more reading for writer
1427					return 1;
1428					};
1429
1430					my $open3 = sub {
1431					local (TO_CHLD_R, TO_CHLD_W);
1432					local (FR_CHLD_R, FR_CHLD_W);
1433					local (FR_CHLD_ERR_R, FR_CHLD_ERR_W);
1434
1435					$pipe->(TO_CHLD_R, TO_CHLD_W ) or die $^E;
1436					$pipe->(FR_CHLD_R, FR_CHLD_W ) or die $^E;
1437					$pipe->(FR_CHLD_ERR_R, FR_CHLD_ERR_W) or die $^E;
1438
1439					my $pid = IPC::Open3::open3('>&TO_CHLD_R', '<&FR_CHLD_W', '<&FR_CHLD_ERR_W', @_);
1440
1441					return ( $pid, TO_CHLD_W, FR_CHLD_R, *FR_CHLD_ERR_R );
1442					};
1443
1444					$cmd = [ grep { defined && length } @$cmd ] if ref $cmd;
1445					$cmd = $self->__fix_cmd_whitespace_and_special_chars( $cmd );
1446
1447					my ($pid, $to_chld, $fr_chld, $fr_chld_err) =
1448					$open3->( ( ref $cmd ? @$cmd : $cmd ) );
1449
1450					my $in_sel = IO::Select->new();
1451					my $out_sel = IO::Select->new();
1452
1453					my %objs;
1454
1455					$objs{ fileno( $fr_chld ) } = $outhand;
1456					$objs{ fileno( $fr_chld_err ) } = $errhand;
1457					$in_sel->add( $fr_chld );
1458					$in_sel->add( $fr_chld_err );
1459
1460					close($to_chld);
1461
1462					while ($in_sel->count() + $out_sel->count()) {
1463					my ($ins, $outs) = IO::Select::select($in_sel, $out_sel, undef);
1464
1465					for my $fh (@$ins) {
1466					my $obj = $objs{ fileno($fh) };
1467					my $buf;
1468					my $bytes_read = sysread($fh, $buf, 64*1024 ); #, length($buf));
1469					if (!$bytes_read) {
1470					$in_sel->remove($fh);
1471					}
1472					else {
1473					$obj->( "$buf" );
1474					}
1475					}
1476
1477					for my $fh (@$outs) {
1478					}
1479					}
1480
1481					waitpid($pid, 0);
1482
1483					### some error occurred
1484					if( $? ) {
1485					$self->error( $self->_pp_child_error( $cmd, $? ) );
1486					$self->ok( 0 );
1487					return;
1488					} else {
1489					return $self->ok( 1 );
1490					}
1491					}
1492
1493					sub _open3_run {
1494					my $self = shift;
1495					my $cmd = shift;
1496					my $_out_handler = shift;
1497					my $_err_handler = shift;
1498					my $verbose = shift \|\| 0;
1499
1500					### Following code are adapted from Friar 'abstracts' in the
1501					### Perl Monastery (http://www.perlmonks.org/index.pl?node_id=151886).
1502					### XXX that code didn't work.
1503					### we now use the following code, thanks to theorbtwo
1504
1505					### define them beforehand, so we always have defined FH's
1506					### to read from.
1507	2	897µs	2	55µs	# spent 31µs (7+24) within IPC::Cmd::BEGIN@1507 which was called: # once (7µs+24µs) by main::BEGIN@30 at line 1507 use Symbol; # spent 31µs making 1 call to IPC::Cmd::BEGIN@1507 # spent 24µs making 1 call to Exporter::import
1508					my $kidout = Symbol::gensym();
1509					my $kiderror = Symbol::gensym();
1510
1511					### Dup the filehandle so we can pass 'our' STDIN to the
1512					### child process. This stops us from having to pump input
1513					### from ourselves to the childprocess. However, we will need
1514					### to revive the FH afterwards, as IPC::Open3 closes it.
1515					### We'll do the same for STDOUT and STDERR. It works without
1516					### duping them on non-unix derivatives, but not on win32.
1517					my @fds_to_dup = ( IS_WIN32 && !$verbose
1518					? qw[STDIN STDOUT STDERR]
1519					: qw[STDIN]
1520					);
1521					$self->_fds( \@fds_to_dup );
1522					$self->__dup_fds( @fds_to_dup );
1523
1524					### pipes have to come in a quoted string, and that clashes with
1525					### whitespace. This sub fixes up such commands so they run properly
1526					$cmd = $self->__fix_cmd_whitespace_and_special_chars( $cmd );
1527
1528					### don't stringify @$cmd, so spaces in filenames/paths are
1529					### treated properly
1530					my $pid = eval {
1531					IPC::Open3::open3(
1532					'<&STDIN',
1533					(IS_WIN32 ? '>&STDOUT' : $kidout),
1534					(IS_WIN32 ? '>&STDERR' : $kiderror),
1535					( ref $cmd ? @$cmd : $cmd ),
1536					);
1537					};
1538
1539					### open3 error occurred
1540					if( $@ and $@ =~ /^open3:/ ) {
1541					$self->ok( 0 );
1542					$self->error( $@ );
1543					return;
1544					};
1545
1546					### use OUR stdin, not $kidin. Somehow,
1547					### we never get the input.. so jump through
1548					### some hoops to do it :(
1549					my $selector = IO::Select->new(
1550					(IS_WIN32 ? \*STDERR : $kiderror),
1551					\*STDIN,
1552					(IS_WIN32 ? \*STDOUT : $kidout)
1553					);
1554
1555					STDOUT->autoflush(1); STDERR->autoflush(1); STDIN->autoflush(1);
1556					$kidout->autoflush(1) if UNIVERSAL::can($kidout, 'autoflush');
1557					$kiderror->autoflush(1) if UNIVERSAL::can($kiderror, 'autoflush');
1558
1559					### add an explicit break statement
1560					### code courtesy of theorbtwo from #london.pm
1561					my $stdout_done = 0;
1562					my $stderr_done = 0;
1563					OUTER: while ( my @ready = $selector->can_read ) {
1564
1565					for my $h ( @ready ) {
1566					my $buf;
1567
1568					### $len is the amount of bytes read
1569					my $len = sysread( $h, $buf, 4096 ); # try to read 4096 bytes
1570
1571					### see perldoc -f sysread: it returns undef on error,
1572					### so bail out.
1573					if( not defined $len ) {
1574					warn(loc("Error reading from process: %1", $!));
1575					last OUTER;
1576					}
1577
1578					### check for $len. it may be 0, at which point we're
1579					### done reading, so don't try to process it.
1580					### if we would print anyway, we'd provide bogus information
1581					$_out_handler->( "$buf" ) if $len && $h == $kidout;
1582					$_err_handler->( "$buf" ) if $len && $h == $kiderror;
1583
1584					### Wait till child process is done printing to both
1585					### stdout and stderr.
1586					$stdout_done = 1 if $h == $kidout and $len == 0;
1587					$stderr_done = 1 if $h == $kiderror and $len == 0;
1588					last OUTER if ($stdout_done && $stderr_done);
1589					}
1590					}
1591
1592					waitpid $pid, 0; # wait for it to die
1593
1594					### restore STDIN after duping, or STDIN will be closed for
1595					### this current perl process!
1596					### done in the parent call now
1597					# $self->__reopen_fds( @fds_to_dup );
1598
1599					### some error occurred
1600					if( $? ) {
1601					$self->error( $self->_pp_child_error( $cmd, $? ) );
1602					$self->ok( 0 );
1603					return;
1604					} else {
1605					return $self->ok( 1 );
1606					}
1607					}
1608
1609					### Text::ParseWords::shellwords() uses unix semantics. that will break
1610					### on win32
1611	1	8µs	1	2µs	{ my $parse_sub = IS_WIN32 # spent 2µs making 1 call to UNIVERSAL::can
1612					? __PACKAGE__->can('_split_like_shell_win32')
1613					: Text::ParseWords->can('shellwords');
1614
1615					sub _ipc_run {
1616					my $self = shift;
1617					my $cmd = shift;
1618					my $_out_handler = shift;
1619					my $_err_handler = shift;
1620
1621					STDOUT->autoflush(1); STDERR->autoflush(1);
1622
1623					### a command like:
1624					# [
1625					# '/usr/bin/gzip',
1626					# '-cdf',
1627					# '/Users/kane/sources/p4/other/archive-extract/t/src/x.tgz',
1628					# '\|',
1629					# '/usr/bin/tar',
1630					# '-tf -'
1631					# ]
1632					### needs to become:
1633					# [
1634					# ['/usr/bin/gzip', '-cdf',
1635					# '/Users/kane/sources/p4/other/archive-extract/t/src/x.tgz']
1636					# '\|',
1637					# ['/usr/bin/tar', '-tf -']
1638					# ]
1639
1640
1641					my @command;
1642					my $special_chars;
1643
1644					my $re = do { my $x = join '', SPECIAL_CHARS; qr/([$x])/ };
1645					if( ref $cmd ) {
1646					my $aref = [];
1647					for my $item (@$cmd) {
1648					if( $item =~ $re ) {
1649					push @command, $aref, $item;
1650					$aref = [];
1651					$special_chars .= $1;
1652					} else {
1653					push @$aref, $item;
1654					}
1655					}
1656					push @command, $aref;
1657					} else {
1658					@command = map { if( $_ =~ $re ) {
1659					$special_chars .= $1; $_;
1660					} else {
1661					# [ split /\s+/ ]
1662					[ map { m/[ ]/ ? qq{'$_'} : $_ } $parse_sub->($_) ]
1663					}
1664					} split( /\s$re\s/, $cmd );
1665					}
1666
1667					### if there's a pipe in the command, *STDIN needs to
1668					### be inserted BEFORE the pipe, to work on win32
1669					### this also works on *nix, so we should do it when possible
1670					### this should also work on multiple pipes in the command
1671					### if there's no pipe in the command, append STDIN to the back
1672					### of the command instead.
1673					### XXX seems IPC::Run works it out for itself if you just
1674					### don't pass STDIN at all.
1675					# if( $special_chars and $special_chars =~ /\\|/ ) {
1676					# ### only add STDIN the first time..
1677					# my $i;
1678					# @command = map { ($_ eq '\|' && not $i++)
1679					# ? ( \*STDIN, $_ )
1680					# : $_
1681					# } @command;
1682					# } else {
1683					# push @command, \*STDIN;
1684					# }
1685
1686					# \*STDIN is already included in the @command, see a few lines up
1687					my $ok = eval { IPC::Run::run( @command,
1688					fileno(STDOUT).'>',
1689					$_out_handler,
1690					fileno(STDERR).'>',
1691					$_err_handler
1692					)
1693					};
1694
1695					### all is well
1696					if( $ok ) {
1697					return $self->ok( $ok );
1698
1699					### some error occurred
1700					} else {
1701					$self->ok( 0 );
1702
1703					### if the eval fails due to an exception, deal with it
1704					### unless it's an alarm
1705					if( $@ and not UNIVERSAL::isa( $@, ALARM_CLASS ) ) {
1706					$self->error( $@ );
1707
1708					### if it is an alarm, propagate
1709					} elsif( $@ ) {
1710					die $@;
1711
1712					### some error in the sub command
1713					} else {
1714					$self->error( $self->_pp_child_error( $cmd, $? ) );
1715					}
1716
1717					return;
1718					}
1719					}
1720					}
1721
1722	1	100ns			sub _system_run {
1723					my $self = shift;
1724					my $cmd = shift;
1725					my $verbose = shift \|\| 0;
1726
1727					### pipes have to come in a quoted string, and that clashes with
1728					### whitespace. This sub fixes up such commands so they run properly
1729					$cmd = $self->__fix_cmd_whitespace_and_special_chars( $cmd );
1730
1731					my @fds_to_dup = $verbose ? () : qw[STDOUT STDERR];
1732					$self->_fds( \@fds_to_dup );
1733					$self->__dup_fds( @fds_to_dup );
1734
1735					### system returns 'true' on failure -- the exit code of the cmd
1736					$self->ok( 1 );
1737					system( ref $cmd ? @$cmd : $cmd ) == 0 or do {
1738					$self->error( $self->_pp_child_error( $cmd, $? ) );
1739					$self->ok( 0 );
1740					};
1741
1742					### done in the parent call now
1743					#$self->__reopen_fds( @fds_to_dup );
1744
1745					return unless $self->ok;
1746					return $self->ok;
1747					}
1748
1749	1	13µs			{ my %sc_lookup = map { $_ => $_ } SPECIAL_CHARS;
1750
1751
1752					sub __fix_cmd_whitespace_and_special_chars {
1753					my $self = shift;
1754					my $cmd = shift;
1755
1756					### command has a special char in it
1757					if( ref $cmd and grep { $sc_lookup{$_} } @$cmd ) {
1758
1759					### since we have special chars, we have to quote white space
1760					### this may conflict with the parsing :(
1761					my $fixed;
1762					my @cmd = map { / / ? do { $fixed++; QUOTE.$_.QUOTE } : $_ } @$cmd;
1763
1764					$self->_debug( "# Quoted $fixed arguments containing whitespace" )
1765					if $DEBUG && $fixed;
1766
1767					### stringify it, so the special char isn't escaped as argument
1768					### to the program
1769					$cmd = join ' ', @cmd;
1770					}
1771
1772					return $cmd;
1773					}
1774					}
1775
1776					### Command-line arguments (but not the command itself) must be quoted
1777					### to ensure case preservation. Borrowed from Module::Build with adaptations.
1778					### Patch for this supplied by Craig Berry, see RT #46288: [PATCH] Add argument
1779					### quoting for run() on VMS
1780	1	600ns			sub _quote_args_vms {
1781					### Returns a command string with proper quoting so that the subprocess
1782					### sees this same list of args, or if we get a single arg that is an
1783					### array reference, quote the elements of it (except for the first)
1784					### and return the reference.
1785					my @args = @_;
1786					my $got_arrayref = (scalar(@args) == 1
1787					&& UNIVERSAL::isa($args[0], 'ARRAY'))
1788					? 1
1789					: 0;
1790
1791					@args = split(/\s+/, $args[0]) unless $got_arrayref \|\| scalar(@args) > 1;
1792
1793					my $cmd = $got_arrayref ? shift @{$args[0]} : shift @args;
1794
1795					### Do not quote qualifiers that begin with '/' or previously quoted args.
1796					map { if (/^[^\/\"]/) {
1797					$_ =~ s/\"/""/g; # escape C<"> by doubling
1798					$_ = q(").$_.q(");
1799					}
1800					}
1801					($got_arrayref ? @{$args[0]}
1802					: @args
1803					);
1804
1805					$got_arrayref ? unshift(@{$args[0]}, $cmd) : unshift(@args, $cmd);
1806
1807					return $got_arrayref ? $args[0]
1808					: join(' ', @args);
1809					}
1810
1811
1812					### XXX this is cribbed STRAIGHT from M::B 0.30 here:
1813					### http://search.cpan.org/src/KWILLIAMS/Module-Build-0.30/lib/Module/Build/Platform/Windows.pm:split_like_shell
1814					### XXX this should be integrated into text::parsewords
1815					sub _split_like_shell_win32 {
1816					# As it turns out, Windows command-parsing is very different from
1817					# Unix command-parsing. Double-quotes mean different things,
1818					# backslashes don't necessarily mean escapes, and so on. So we
1819					# can't use Text::ParseWords::shellwords() to break a command string
1820					# into words. The algorithm below was bashed out by Randy and Ken
1821					# (mostly Randy), and there are a lot of regression tests, so we
1822					# should feel free to adjust if desired.
1823
1824					local $_ = shift;
1825
1826					my @argv;
1827					return @argv unless defined() && length();
1828
1829					my $arg = '';
1830					my( $i, $quote_mode ) = ( 0, 0 );
1831
1832					while ( $i < length() ) {
1833
1834					my $ch = substr( $_, $i , 1 );
1835					my $next_ch = substr( $_, $i+1, 1 );
1836
1837					if ( $ch eq '\\' && $next_ch eq '"' ) {
1838					$arg .= '"';
1839					$i++;
1840					} elsif ( $ch eq '\\' && $next_ch eq '\\' ) {
1841					$arg .= '\\';
1842					$i++;
1843					} elsif ( $ch eq '"' && $next_ch eq '"' && $quote_mode ) {
1844					$quote_mode = !$quote_mode;
1845					$arg .= '"';
1846					$i++;
1847					} elsif ( $ch eq '"' && $next_ch eq '"' && !$quote_mode &&
1848					( $i + 2 == length() \|\|
1849					substr( $_, $i + 2, 1 ) eq ' ' )
1850					) { # for cases like: a"" => [ 'a' ]
1851					push( @argv, $arg );
1852					$arg = '';
1853					$i += 2;
1854					} elsif ( $ch eq '"' ) {
1855					$quote_mode = !$quote_mode;
1856					} elsif ( $ch eq ' ' && !$quote_mode ) {
1857					push( @argv, $arg ) if defined( $arg ) && length( $arg );
1858					$arg = '';
1859					++$i while substr( $_, $i + 1, 1 ) eq ' ';
1860					} else {
1861					$arg .= $ch;
1862					}
1863
1864					$i++;
1865					}
1866
1867					push( @argv, $arg ) if defined( $arg ) && length( $arg );
1868					return @argv;
1869					}
1870
- -
1873	2	19µs	2	8µs	# spent 8µs (8+400ns) within IPC::Cmd::BEGIN@1873 which was called: # once (8µs+400ns) by main::BEGIN@30 at line 1873 { use File::Spec; # spent 8µs making 1 call to IPC::Cmd::BEGIN@1873 # spent 400ns making 1 call to IPC::Cmd::__ANON__
1874	2	358µs	2	35µs	# spent 20µs (5+15) within IPC::Cmd::BEGIN@1874 which was called: # once (5µs+15µs) by main::BEGIN@30 at line 1874 use Symbol; # spent 20µs making 1 call to IPC::Cmd::BEGIN@1874 # spent 15µs making 1 call to Exporter::import
1875
1876	1	4µs	3	8µs	my %Map = ( # spent 8µs making 3 calls to Symbol::gensym, avg 3µs/call
1877					STDOUT => [qw\|>&\|, \*STDOUT, Symbol::gensym() ],
1878					STDERR => [qw\|>&\|, \*STDERR, Symbol::gensym() ],
1879					STDIN => [qw\|<&\|, \*STDIN, Symbol::gensym() ],
1880					);
1881
1882					### dups FDs and stores them in a cache
1883					sub __dup_fds {
1884					my $self = shift;
1885					my @fds = @_;
1886
1887					__PACKAGE__->_debug( "# Closing the following fds: @fds" ) if $DEBUG;
1888
1889					for my $name ( @fds ) {
1890					my($redir, $fh, $glob) = @{$Map{$name}} or (
1891					Carp::carp(loc("No such FD: '%1'", $name)), next );
1892
1893					### MUST use the 2-arg version of open for dup'ing for
1894					### 5.6.x compatibility. 5.8.x can use 3-arg open
1895					### see perldoc5.6.2 -f open for details
1896					open $glob, $redir . fileno($fh) or (
1897					Carp::carp(loc("Could not dup '$name': %1", $!)),
1898					return
1899					);
1900
1901					### we should re-open this filehandle right now, not
1902					### just dup it
1903					### Use 2-arg version of open, as 5.5.x doesn't support
1904					### 3-arg version =/
1905					if( $redir eq '>&' ) {
1906					open( $fh, '>' . File::Spec->devnull ) or (
1907					Carp::carp(loc("Could not reopen '$name': %1", $!)),
1908					return
1909					);
1910					}
1911					}
1912
1913					return 1;
1914					}
1915
1916					### reopens FDs from the cache
1917					sub __reopen_fds {
1918					my $self = shift;
1919					my @fds = @_;
1920
1921					__PACKAGE__->_debug( "# Reopening the following fds: @fds" ) if $DEBUG;
1922
1923					for my $name ( @fds ) {
1924					my($redir, $fh, $glob) = @{$Map{$name}} or (
1925					Carp::carp(loc("No such FD: '%1'", $name)), next );
1926
1927					### MUST use the 2-arg version of open for dup'ing for
1928					### 5.6.x compatibility. 5.8.x can use 3-arg open
1929					### see perldoc5.6.2 -f open for details
1930					open( $fh, $redir . fileno($glob) ) or (
1931					Carp::carp(loc("Could not restore '$name': %1", $!)),
1932					return
1933					);
1934
1935					### close this FD, we're not using it anymore
1936					close $glob;
1937					}
1938					return 1;
1939
1940					}
1941					}
1942
1943	1	300ns			sub _debug {
1944					my $self = shift;
1945					my $msg = shift or return;
1946					my $level = shift \|\| 0;
1947
1948					local $Carp::CarpLevel += $level;
1949					Carp::carp($msg);
1950
1951					return 1;
1952					}
1953
1954					sub _pp_child_error {
1955					my $self = shift;
1956					my $cmd = shift or return;
1957					my $ce = shift or return;
1958					my $pp_cmd = ref $cmd ? "@$cmd" : $cmd;
1959
1960
1961					my $str;
1962					if( $ce == -1 ) {
1963					### Include $! in the error message, so that the user can
1964					### see 'No such file or directory' versus 'Permission denied'
1965					### versus 'Cannot fork' or whatever the cause was.
1966					$str = "Failed to execute '$pp_cmd': $!";
1967
1968					} elsif ( $ce & 127 ) {
1969					### some signal
1970					$str = loc( "'%1' died with signal %2, %3 coredump",
1971					$pp_cmd, ($ce & 127), ($ce & 128) ? 'with' : 'without');
1972
1973					} else {
1974					### Otherwise, the command run but gave error status.
1975					$str = "'$pp_cmd' exited with value " . ($ce >> 8);
1976					}
1977
1978					$self->_debug( "# Child error '$ce' translated to: $str" ) if $DEBUG;
1979
1980					return $str;
1981					}
1982
1983	1	8µs			1;
1984
1985					__END__

					# spent 52µs within IPC::Cmd::CORE:ftdir which was called 27 times, avg 2µs/call: # 27 times (52µs+0s) by IPC::Cmd::can_run at line 248, avg 2µs/call sub IPC::Cmd::CORE:ftdir; # opcode
					# spent 700ns within IPC::Cmd::__ANON__ which was called 2 times, avg 350ns/call: # once (400ns+0s) by IPC::Cmd::BEGIN@1873 at line 1873 # once (300ns+0s) by IPC::Cmd::BEGIN@58 at line 58 sub IPC::Cmd::__ANON__; # xsub