Codebase list libipc-run-perl / 962a4b7
[svn-inject] Installing original source of libipc-run-perl Vincent Danjean 16 years ago
40 changed file(s) with 10884 addition(s) and 0 deletion(s). Raw diff Collapse all Expand all
+323
-0
Changes less more
0 Revision history for Perl extension IPC::Run
1
2
3 0.80
4 - IPC::Run::IO now retries on certain "temporarily unavailable" errors.
5 This should fix several reported issues with t/run.t, test 69.
6
7 Many thanks to < Eric (at) Scratch Computing (.com) > for the patch!
8
9 - Applied documentation patch from RT.
10 - Fixed documentation to work with '<' redirect
11
12 0.79 Wed Jan 19 15:39:00 PST 2005
13 - New maintainer: Richard Soderberg <rsod@cpan.org>
14 - Resolved several RT tickets
15 - 4934, 8263, 8060, 8400, 8624, 5870, 4658, 8940, 1474, 4311
16 - Skip certain tests on AIX and OpenBSD as they deadlock otherwise
17 - Applied AIX patch from ActiveState (#8263)
18 - Fixed t/run.t on OS X (#8940)
19 - Add check for EINTR to _read (#5870)
20 - FreeBSD uses fds up to 4 by default, fixed tests to start at 5 (#8060)
21
22 0.78 Tue Mar 9 01:49:25 EST 2004
23 - Removed all psuedohashes
24 - Require Win32::Process when on Win32 (<CORION a t cpan . org>)
25 - Retry the select() instead of croaking when EINTR occurs
26 (Ilya Martynov, ilya a t iponweb.net)
27 - This needs further testing and analysis, but works for
28 the submitter.
29
30 0.77 Fri Sep 26 15:36:56 EDT 2003
31 - Non-binmoded pipes are now s/\r//g on Win32
32 - Passes all tests on WinXPPro and WinNT
33 - Deadlocks somewhere shortly after process creation on Win2K
34 in some cases
35
36 0.76
37 - Does not use pseudohashes for perls >= 5.9.0 (reported by several
38 users, patch by Nicholas Clark <nick@unfortu.net>)
39 - pumpable() is now exported (reported by fetko@slaysys.com)
40 - pumpable() now more thorough in checking for a dead child (reported
41 by fetko@slaysys.com)
42 - it checks for reapable processes when all pipes to the process
43 are paused
44 - pumpable() now yields the processor when all pipes to
45 - Distro layout improved: Run.pm and Run/... are now under
46 lib/IPC/...
47
48 0.75 Tue Jan 28 11:33:40 EST 2003
49 - Fix a bug that was causing _pipe() to seem to fail when feeding
50
51 0.74 Thu May 23 09:24:57 EDT 2002
52 - Skip a set of pty tests that deadlock on freebsd. Reported and
53 investigated by Rocco Caputo <troc@pobox.com>. perldoc t/pty.t
54 for details.
55
56 0.73 Wed May 22 09:03:26 EDT 2002
57 - Improved Win32 PATH and PATHEXT search; original patch by Ron Savage
58 <ron@savage.net.au>
59
60 0.72 Thu May 9 10:25:55 EDT 2002
61 - Doc patch from daniel@danielgardner.org
62 - Backport Win32Helper to 5.00503 (compilation of this is
63 tested on Unix or it would not have been spotted,
64 not even by Matt Sergeant matts@sergeant.org).
65
66 0.71 Mon May 6 09:04:18 EDT 2002
67 - Fix the pesky run/t check for specific error string (test 134 at
68 the moment, bad file descriptor test) that keeps tripping up
69 cpantesters
70
71 0.70 Fri Apr 26 10:15:13 EDT 2002
72 - Massive performance improvements on Win32 See IPC::Run::Win32Helper's
73 optimize() documentation.
74 - moved data pump routine to IPC::Run::Win32Pump, now it loads much
75 faster.
76 - Where reasonably safe to do so, temporary files are used instead of
77 pipes+pumps.
78 - Setting $ENV{IPCRUNDEBUG}="notopt" can help find opportunities for
79 optimizing. See IPC::Run::Debug for details.
80 - Added 'noinherit => 1' option (parsed like 'debug => "basic") to
81 allow stdin, stdout, and stderr to not be inherited by the child.
82 - Factored debugging out in to IPC::Run::Debug so Win32Pump.pm need not load
83 IPC::Run to get it.
84 - Debugging code can be compile-time optimized away by setting
85 $ENV{IPCRUNDEBUG} = "none" (or 0) before IPC::Run::Debug is first loaded
86 causes all _debug... code to be optimized away before runtime.
87 - Moved some functionality from IPC::Run in to IPC::Run::IO to allow
88 IPC::Run::Win32IO to alter IPC::Run's behavior. More of this should
89 happen; IPC::Run has grown too bloaty.
90 - All the hokey hacky "manual imports" of IPC::Run's old _debug...()
91 functions has been replaced by "use IPC::Run::Debug".
92 - All the hokey hacky "manual imports" of IPC::Run's Win32_MODE()
93 constant has been replaced by importing it from IPC::Run.
94 - Cleaned up IPC::Run::Win32*'s debugging levels a bit to unclutter
95 "basic" and "data" debugging level output.
96 - exception handling in _open_pipes no longer silently eats exceptions.
97
98 0.67 Fri Apr 19 12:14:02 EDT 2002
99 - remove _q from the examples in the POD - it was inconsistent (the
100 examples had bugs) and didn't help readability. Spotted by
101 B.Rowlingson@lancaster.ac.uk.
102
103 0.66 Wed Mar 27 07:42:27 EST 2002
104 - Really dumb down that bad file descriptor test last tweaked in 0.64;
105 the CLI does not script well under internationalization.
106
107 0.65 (unreleased)
108 - Win32
109 - pass filehandles to pumpers by number on the command line to avoid
110 - use 2 arg binmode to force socket handles into/out of binmode
111 - improve t/binmode.t
112 - TODO: test ^Z and \000 pass-through.
113
114 0.64 Wed Mar 13 11:04:23 EST 2002
115 - Fix a test that fails on AIX because it uses a different message for
116 "Bad file descriptor". Reported by "Dave Gomboc" <dave@cs.ualberta.ca>
117 - If IO::Pty is loadable, require IO::Pty 1.00 or later.
118
119 0.63 Wed Feb 27 12:25:22 EST 2002
120 - the select loop will now poll (with logarithmic fallback) when all
121 I/O is closed but we have children running. Problem report by
122 "William R. Pearson" <wrp@alpha0.bioch.virginia.edu>.
123
124 0.62 Tue Jan 1 16:40:54 EST 2002
125 - Have all children close all file descriptors opened by the parent
126 harness, otherwise children of different harnesses can unwittingly
127 keep open fds the parent closes, thus preventing other children
128 from seeing them close. Reported by Blair Zajac <blair@orcaware.com>.
129
130 0.61 Fri Dec 7 05:21:28 EST 2001
131 - Fix up signal.t to not fail due to printing not working quite right in
132 signal handlers. Spotted in the wild by Blair Zajac <blair@orcaware.com>.
133
134 0.6 Thu Dec 6 04:36:57 EST 2001
135 - Get binmode--(">", binary) and ("<", binary)--working on Win32.
136
137 0.56 Sun Dec 2 09:18:19 EST 2001
138 - IPC::Run now throws exceptions from the post-fork, pre-exec child process
139 back to the parent process using an additional pipe. This pipe also
140 is used to pause the parent until the child performs the exec(), so
141 that (when a new version of IO::Pty implements it) pty creation can
142 be completed before the parent tries to write to it.
143
144 0.55 Sat Dec 1 17:15:02 EST 2001
145 - Fixups to Win32 code to get it compiling ok (added t/win32_compile.t
146 to ensure that Win32Helper.pm at least compiles Ok).
147 - Minor tweak to deal with "_" in $IO::Pty::VERSION, which is "0.92_04",
148 including quotes, in the current version.
149
150 0.54 Fri Nov 30 11:46:05 EST 2001
151 - Win32 SUPPORT!!!!!
152 - Added support for env. var. IPCRUNDEBUG=1 (or 2, 3, 4) to make it
153 easier for users to debug the test suite.
154 - Adapt to IO::Pty 0.91, which creates slave fds in new(), forcing us to
155 close them in the parent after the fork(). We don't check for IO::Pty's
156 version number, perhaps we should (waiting for a response from Roland
157 Giersig <RGiersig@cpan.org> about what he intends, since this could affect
158 all users of older IO::Ptys that upgrade).
159 - Add a sleep(1) to allow the slave pty to be initted, otherwise a premature
160 write() to the slave's input can be lost. This is a bogus hack, but
161 IO::Pty 0.9x should fix it when it's released.
162 - removed spurious use Errno qw( EAGAIN ), since this causes warnings with
163 perl5.00505. Reported by Christian Jaeger <christian.jaeger@sl.ethz.ch>
164 (pflanze).
165 - IPC::Run::start() now does a kill_kill() if called on an already started
166 harness. This is needed on Win32 to pass the test suite, but it's also a
167 nice thing.
168 - The debug file descriptor is built by dup()ing STDERR in the parent and
169 passing it to the kids. This keeps us from needing to worry about
170 debugging info in the select() loop and removes unnecessary complications.
171 Still needs a bit of work: it should be dup()ed in _open_pipes and it's
172 value should be stored in the harness, not a global.
173 - child processes are now a little more clearly identified in debug output.
174 - Some debugging messages are now clearer.
175 - debugging is now almost ready to be compile-time optimized away.
176 - "time since script start" is now shown when debugging. We should check to
177 see if Time::HiRes is loaded and make this more accurate.
178 - pipe opens are now down in Run::IO::open_pipe().
179 - map_fds won't complain about no open fds unnecessarily (which was rare,
180 but still).
181 - the debug fd is now determined per-harness, not globally. This requires a
182 bit of a hack (since I don't want to require $harness->_debug everywhere
183 _debug might be called), but it seems worthwhile.
184
185 0.5 Sat Nov 10 21:32:58 EST 2001
186 - confess() when undef passed to _exec()
187 - Cleaned up some POD and code comments.
188 - Added patch to make the write side of pipes & ptys that IPC::Run must
189 write to be non-blocking. Added a test for pipes, but Boris reports that
190 Solaris 8 something seems to still block in the pty case, though Linux
191 does not, so I did not add a test for that case. Probably should add one
192 and complain bitterly if it fails (rather than actually failing the tests)
193 and ptys are used. Patch from Borislav Deianov
194 <borislav@users.sourceforge.net>.
195 - Added a patch to invalidate the search path cache if the file is no longer
196 executable, also from Borislav Deianov <borislav@users.sourceforge.net>
197 - Started implementation of an adopt() external call that would let you
198 aggregate harnesses, and a t/adopt.t, but different children need to
199 properly close all FDs: they're inheriting each other's FDs and not
200 properly closing them.
201 - Close $debug_fd in &sub coprocesses.
202 - Document the problems with &sub coprocesses.
203 - Fixed fork error return detection to actually work, spotted by Dave
204 Mitchell <davem@fdgroup.co.uk>.
205 - Give errors if a path with a directory separator is passed in if the
206 indicated filename does not exist, is not a file, or is not executable.
207 They're unixish errors, but hey...
208 - Allowed harness \@cmd, '>', $foo, timeout 10 ; to parse (it was mistakenly
209 thinking I wanted to send output to the IPC::Run::Timer created by
210 timeout().
211 - pumpable() now returns true if there are any kids left alive, so that
212 timers may continue to run.
213 - A timeout of 1 second is forced if there are no I/O pipes left open, so
214 that the select loop won't hang in select() if there is no I/O to do.
215 Perhaps should only do that if there are timers.
216 - Added a signal() to send specified signals to processes. Chose this over
217 the more traditional Unix kill() to avoid people thinking that kill()
218 should kill off processes.
219 - Added kill_kill() which does kill off processes and clean up the harness.
220 Sends TERM then (if need be) waits and sends KILL.
221 - timeouts now work.
222 - Removed eval{}s from a few subs, we were being over protective.
223 - Preserve pos() across updates to scalars we append to, so m//g
224 matches will work.
225 - Cleaned up the examples/
226 - Added abuse/ for (mostly user contributed) scripts that I can use as
227 a manual regression test. Most/all are reflected in t/*.t, but not
228 verbatim, so it's good to have to originals around in case they
229 happen to trigger something t/*.t miss.
230 - Cleaned up SYNOPSIS a bit: it was too scary. Still is, but less so.
231
232 0.44 Mon Oct 2 17:20:29 EDT 2000
233 - Commented out all code dealing with select()'s exception file descriptor
234 mask. Exceptions are vaguely defined and until somebody asks for them
235 I don't want to do anything automatic with them. Croaking on them
236 was certainly a bad idea: FreeBSD and some other platforms raise an
237 exception when a pipe is closed, even if there's data in the pipe.
238 IPC::Run closes a pipe filehandle if it sees sysread() return an
239 error or 0 bytes read.
240
241 0.43 Thu Aug 17 23:26:34 EDT 2000
242 - Added flushing of STDOUT and STDERR before fork()/spawn() so that the
243 children won't inherit bufferloads of unflushed output. This seems
244 to be automatic in 5.6.0, but can cause loads of grief in 5.00503.
245 I wish there were a way to flush all open filehandles, like stdio's
246 fflush( NULL ) ;
247
248 0.42 Thu Aug 17 23:26:34 EDT 2000
249 - Worked around psuedo-hash features not implemented in perl5.00503
250 - Deprecated passing hashes of options in favor of just passing
251 name-vlaue pairs.
252
253 0.41
254 - Added result, results, full_result, full_results. I added so many
255 variations because I expect that result and full_result are the most
256 likely to get a lot of use, but I wanted to be able to return a list
257 as well, without misusing wantarray.
258
259 0.4 Thu Jun 15 14:59:22 EDT 2000
260 - Added IPC::Run::IO and IPC::Run::Timer, bunches of tests. IPC::Run
261 can now do more than just run child processes.
262 - Scribbled more documentation. Needs a good edit.
263 - Fixed some minor bugs here and there.
264
265 0.34 Thu Jun 8 06:39:23 EDT 2000
266 - Fixed bug in t/pty.t that prevented it from noticing IO::Pty
267 - Converted IPC::Run to use fields.
268
269 0.32 Thu Jun 8 06:15:17 EDT 2000
270 - Added warning about missing IO::Pty in MakeMaker.PL. Thought about
271 making it a prerequisite, but it's not: IPC::Run can do pipes, etc,
272 if it's not found, and IO::Pty is more unix-specific than IPC::Run is.
273 What I'd really like is an 'ENABLERS' section to MakeMaker.PL that
274 tells CPAN.pm to try to install it but not to stress if it can't.
275 - t/pty.t skips all tests if require IO::Pty fails.
276
277 0.31 Tue Jun 6 01:54:59 EDT 2000
278 - t/pty.t should now report what was received when checking it against
279 a regex. This is because 0.3's failing a few tests on ppc-linux
280 and the ok( $out =~ /.../ ) ; wasn't giving me enough info. I chose
281 the 1 arg form due to older perl dists' Test.pm not grokking
282 ok( $out, qr// ) ;. I should really do this to t/*.t, but I'm tired.
283 - Removed the misfired Run/Pty.pm from the dist.
284
285 0.3 Sat Jun 3 08:33:17 EDT 2000
286 - Changed spelling of '<|<' and '>|>' to '<pipe' and '>pipe'. This
287 is to make it less confusing (I hope), since '>|' is a valid construct
288 in some shells with totally unrelated semantics, and I plan on adding
289 it to IPC::Run if a noclobber option ever makes it in.
290 - Added '<pty<' and '>pty>' operators.
291
292 0.21 Fri Jun 2 12:49:08 EDT 2000
293 - Added some advice for dealing with obstinate children
294 - Converted many methods to plain subs for simplicity & performance
295 - Converted to using local $debug to control debugging status for
296 simplicity's sake. Don't know about performance effects, since
297 dynamic scope lookups can be slow.
298
299 0.2 Thu Jun 1 01:48:29 EDT 2000
300 - Undid the creation of a pipe when passing a \*FOO or an IO::Handle
301 ref and added '<|<', \*IN and '>|>', \*OUT syntax instead. This was
302 because some very subtle bugs might have occured if \*FOO was left
303 in the wrong opened/closed state before calling run(), start() or
304 harness(). Now, \*FOO must be open before the start() call, and
305 '<|<' and '>|>' will close \*IN or \*OUT (or whatever) and open
306 a pipe on it. This is analagous to IPC/Open{2,3}.pm behaviors.
307 - Added eg/factorial_scalar and eg/runsh. Rewrote eg/factorial_pipe.
308 - Fixed bug that was preventing input scalar refs (ie input for the
309 child process) from ever being read from a second time. This
310 caused pump() to hang.
311 - Cleaned up calculation and use of timeout values so that when
312 select() times out, it isn't called again. It's now adding one
313 second to the timeout value because time() resolution is 1 second
314 and we want to guarantee a minimum timeout even when we sample the
315 start time at the end of a second
316 - minor name changes to some field names to make the code marginally
317 less obscure.
318 - Fixed the MakeMaker settings and the directory layout so "make install"
319 actually works.
320
321 0.1 Tue Apr 25 22:10:07 2000
322
+40
-0
MANIFEST less more
0 Changes
1 MANIFEST
2 MANIFEST.SKIP
3 Makefile.PL
4 lib/IPC/Run.pm
5 lib/IPC/Run/Debug.pm
6 lib/IPC/Run/IO.pm
7 lib/IPC/Run/Timer.pm
8 lib/IPC/Run/Win32Helper.pm
9 lib/IPC/Run/Win32IO.pm
10 lib/IPC/Run/Win32Pump.pm
11 abuse/blocking_debug_with_sub_coprocess
12 abuse/blocking_writes
13 abuse/broken_pipe_on_bad_executable_name
14 abuse/timers
15 eg/factorial
16 eg/factorial_pipe
17 eg/factorial_scalar
18 eg/run_daemon
19 eg/runsh
20 eg/runsu
21 eg/synopsis_scripting
22 t/adopt.t
23 t/binmode.t
24 t/bogus.t
25 t/filter.t
26 t/harness.t
27 t/io.t
28 t/kill_kill.t
29 t/parallel.t
30 t/pty.t
31 t/pump.t
32 t/run.t
33 t/signal.t
34 t/timeout.t
35 t/timer.t
36 t/win32_compile.t
37 TODO
38 SIGNATURE
39 META.yml
+13
-0
MANIFEST.SKIP less more
0 CVS/.*
1 \.bak$
2 \.sw[a-z]$
3 \.tar$
4 \.tgz$
5 \.tar\.gz$
6 ^mess/
7 ^tmp/
8 ^blib/
9 ^Makefile$
10 ^Makefile\.[a-z]+$
11 ^pm_to_blib$
12 ~$
+10
-0
META.yml less more
0 # http://module-build.sourceforge.net/META-spec.html
1 #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
2 name: IPC-Run
3 version: 0.80
4 version_from: lib/IPC/Run.pm
5 installdirs: site
6 requires:
7
8 distribution_type: module
9 generated_by: ExtUtils::MakeMaker version 6.17
+79
-0
Makefile.PL less more
0 use ExtUtils::MakeMaker;
1
2 sub pty_warn {
3 warn "WARNING: $_[0].\nWARNING: '<pty<', '>pty>' $_[1] not work.\n\n";
4 last ;
5 }
6
7 my @conditional_prereqs;
8
9 if ( $^O !~ /Win32/ ) {
10 for ( eval { require IO::Pty ; IO::Pty->VERSION } ) {
11 s/_//g if defined ;
12 pty_warn "IO::Pty not found", "will" unless defined ;
13 push @conditional_prereqs, "IO::Pty" => 1.00;
14 }
15 }
16 else {
17 push @conditional_prereqs, "Win32::Process" => 0.0;
18 if ( ! eval "use Socket qw( IPPROTO_TCP TCP_NODELAY ); 1" ) {
19 warn <<TOHERE;
20 $@
21 IPC::Run on Win32 requires a recent Sockets.pm in order to handle more
22 complex interactions with subprocesses. They are not needed for most
23 casual uses of run(), but it's impossible to tell whether all uses of
24 IPC::Run in your installed modules meet the requirements, so IPC::Run
25 should not be installed on Win32 machines with older perls.
26
27 TOHERE
28
29 ## Die nicely in case some install manager cares about the canonical
30 ## error message for this. Not that I've ever seen one, but those
31 ## wacky CPANPLUSers might just do something cool in this case.
32
33 require 5.006; ## Older perls' Socket.pm don't export IPPROTO_TCP
34 ## Most of the time it's not needed (since IPC::Run tries not to
35 ## use sockets), but the user is not likely to know what the hell
36 ## went wrong running sb. else's program.
37
38 exit 1; ## If something really odd is happening...
39 }
40 }
41
42 print <<'TOHERE' ;
43
44 If you experience problems while running make test, please run
45 the failing scripts using a command like:
46
47 make test TEST_FILES=t/foo.t TEST_VERBOSE=1 IPCRUNDEBUG=4 > foo.out 2>&1
48
49 (use nmake on Windows) and sending foo.out with your problem report.
50 Bonus air miles awarded for writing a small, simple exploit script :).
51
52 You may also use the IPCRUNDEBUG=1 (or 2, 3, or 4) trick with your own
53 programs, see perldoc IPC::Run for details.
54
55 See perldoc IPC::Run for details on the experimental nature of
56 pty and Win32 support.
57
58 <barbie tm="Mattel">Subprocesses are *HARD*.</barbie>
59
60 TOHERE
61
62 WriteMakefile(
63 NAME => 'IPC::Run',
64 VERSION_FROM => 'lib/IPC/Run.pm',
65 PREREQ_PM => {
66 @conditional_prereqs,
67 }
68 );
69
70
71 sub MY::libscan {
72 package MY ;
73 my $self = shift ;
74 my ( $path ) = @_ ;
75 return '' if /\.sw[a-z]$/ ;
76 return '' unless length $self->SUPER::libscan( $path ) ;
77 return $path ;
78 }
+62
-0
SIGNATURE less more
0 This file contains message digests of all files listed in MANIFEST,
1 signed via the Module::Signature module, version 0.50.
2
3 To verify the content in this distribution, first make sure you have
4 Module::Signature installed, then type:
5
6 % cpansign -v
7
8 It will check each file's integrity, as well as the signature's
9 validity. If "==> Signature verified OK! <==" is not displayed,
10 the distribution may already have been compromised, and you should
11 not run its Makefile.PL or Build.PL.
12
13 -----BEGIN PGP SIGNED MESSAGE-----
14 Hash: SHA1
15
16 SHA1 ddda40abf46f1e89c4b8ec2a98c9576af9a10571 Changes
17 SHA1 07e39c16ee58858c09d83849b286ea66d725ae1d MANIFEST
18 SHA1 dcd5a2e5e83f02e172b5bcee8407354097eff390 MANIFEST.SKIP
19 SHA1 78c9597325741774df7c75d41eeaa13a07457738 META.yml
20 SHA1 a14ca773e75d19d2dd63efc526fcba8e51b84ff6 Makefile.PL
21 SHA1 a02248670bc20319379ec21acafa5ed6f630f3a4 TODO
22 SHA1 3f5928d86e3e9ced4e3829048ff7bc88db3af4a1 abuse/blocking_debug_with_sub_coprocess
23 SHA1 ae81796545dfdada8c08f54b29b6029b3696a484 abuse/blocking_writes
24 SHA1 32a5e706d5896d9550c9f9697f4b7166483a22c9 abuse/broken_pipe_on_bad_executable_name
25 SHA1 4f65bb492723443dc7a591d44287f98bf055e2ed abuse/timers
26 SHA1 185e5f15278360ccce479f09324070cb9da6ec4d eg/factorial
27 SHA1 3b5fcda75e38cc479ea9a2f67b792ad94b2e6e43 eg/factorial_pipe
28 SHA1 293d679cf505b74ea3cdea5a0bc7e9e813fa99f4 eg/factorial_scalar
29 SHA1 c4ac5a17ab932365de1f2f575f51537e52394424 eg/run_daemon
30 SHA1 d3d71aa1f3a2963d1e73226a65b5e944a9c7848b eg/runsh
31 SHA1 4271e0cd68f05e236c476feaf4bff2b2bd384fe0 eg/runsu
32 SHA1 67b31305d3a66c130ae9ae9df76653756446c734 eg/synopsis_scripting
33 SHA1 a81152412125dfcd98346e3f9b32070cb0e49871 lib/IPC/Run.pm
34 SHA1 9d007f1da1079b2c1dfab02ef4f755f5c273c8cf lib/IPC/Run/Debug.pm
35 SHA1 5ae3ec22051fcb9b23e41f6ba1069e1743f2f4b2 lib/IPC/Run/IO.pm
36 SHA1 baa6f4418727870f8f3943f4d8d0cc30170f2753 lib/IPC/Run/Timer.pm
37 SHA1 c504f4172c5d4de46bfc9c5db5fb09f7dffa2f48 lib/IPC/Run/Win32Helper.pm
38 SHA1 8993424899d06664614c5b29a04609da9679fefb lib/IPC/Run/Win32IO.pm
39 SHA1 6464ec5ac46463a5ac9ad58d507531c6c896f48e lib/IPC/Run/Win32Pump.pm
40 SHA1 67a7fdfd0129504ae0ec78f9993313e21e685c09 t/adopt.t
41 SHA1 2c0f00d2759cf936d25270bf7f1da7b512d28aba t/binmode.t
42 SHA1 90d75fdda1f32f346a2a98d95a7cf8c63caa7456 t/bogus.t
43 SHA1 032582f5529ed37f5096848a533211275a2069fb t/filter.t
44 SHA1 8a3b7028dbb4f8ba797e6ba16a9949ad89217bfb t/harness.t
45 SHA1 2f772b6a97c58ef0daac795bae868e7919b05265 t/io.t
46 SHA1 239b78ac73dfd05c0a4d3e342a55f18827b62f59 t/kill_kill.t
47 SHA1 4a5592b7a867193acba7ec66aa76ae9304657264 t/parallel.t
48 SHA1 fa6a734db486e7abc88181240d95c8cd20bccfe0 t/pty.t
49 SHA1 3acb9967c0c68c19a8c889ba91c89fb1db8feaf4 t/pump.t
50 SHA1 1724c3a2835b06ff321544309e6e3e8bad865a30 t/run.t
51 SHA1 3bab4c603d4dd5bd388c4e3c089c73960319e05f t/signal.t
52 SHA1 56632e52a0ecb57b9bb21821dc758f6c9a0e30a8 t/timeout.t
53 SHA1 31dfbc5a2c2af66697f6af5eeee4b224e1981163 t/timer.t
54 SHA1 10644bbe21c0306df73b4a4da6b3cd9ee4cb3a06 t/win32_compile.t
55 -----BEGIN PGP SIGNATURE-----
56 Version: GnuPG v1.4.1 (Darwin)
57
58 iD8DBQFEYkWuCV/r5CcpuVoRAsKXAJwL5B62exN5neNRq1keXe/RvR03owCeMRDj
59 okWVPtytzdMVBDFQotk5bBQ=
60 =Uz5U
61 -----END PGP SIGNATURE-----
+4
-0
TODO less more
0 TODO for IPC::Run
1
2 - Debug Win2K deadlock
3 - Debug t\run.t's resource problem on rh8
+48
-0
abuse/blocking_debug_with_sub_coprocess less more
0 #!/opt/i386-linux/perl/bin/perl -w
1
2 ## Submitted by Blair Zajac <blair@orcaware.com>
3
4 ## Tests blocking when piping though a &sub coprocess.
5 ## Fixed, now in test suite.
6
7 $| = 1;
8
9 use strict;
10 use Carp;
11 use Symbol;
12 use IPC::Run 0.44 qw(start);
13
14 print "My pid is $$\n";
15
16 my $out_fd = gensym;
17 open($out_fd, ">ZZZ.test") or
18 die "$0: open: $!\n";
19
20 my $queue = '';
21
22 my @commands = ([['cat', '-'], \$queue, '|'],
23 [['cat'], '|'],
24 [\&double, '>', $out_fd]);
25
26 my $harness = start 'debug' => 10, map { @$_ } @commands;
27 $harness or
28 die "$0: harness\n";
29
30 close($out_fd) or
31 die "$0: cannot close: $!\n";
32
33 for (1..100) {
34 $queue .= rand(100) . "\n";
35 $harness->pump;
36 }
37 $harness->finish or
38 die "$0: finish\n";
39
40 exit 0;
41
42 sub double {
43 while (<STDIN>) {
44 s/\s+$//;
45 print "$_ $_\n";
46 }
47 }
+39
-0
abuse/blocking_writes less more
0 #!/usr/bin/perl
1
2 ## Submitted by Borislav Deianov <borislav@users.sourceforge.net>
3 ## This stresses the blocking write to see if it blocks.
4
5
6 use Fcntl;
7 use IO::Pty;
8 use IPC::Run qw(run);
9
10 sub makecmd {
11 return ['perl', '-e',
12 '<STDIN>, print "\n" x '.$_[0].'; while(<STDIN>){last if /end/}'];
13 }
14
15 pipe R, W;
16 fcntl(W, F_SETFL, O_NONBLOCK);
17 while (syswrite(W, "\n", 1)) { $pipebuf++ };
18 print "pipe buffer size is $pipebuf\n";
19 $in = "\n" x ($pipebuf * 3) . "end\n";
20
21 print "reading from scalar via pipe... ";
22 run(makecmd($pipebuf * 3), '<', \$in, '>', \$out);
23 print "done\n";
24
25 print "reading from code via pipe... ";
26 run(makecmd($pipebuf * 3), '<', sub { $t = $in; undef $in; $t}, '>', \$out);
27 print "done\n";
28
29 $pty = IO::Pty->new();
30 $pty->blocking(0);
31 $slave = $pty->slave();
32 while ($pty->syswrite("\n", 1)) { $ptybuf++ };
33 print "pty buffer size is $ptybuf\n";
34 $in = "\n" x ($ptybuf * 3) . "end\n";
35
36 print "reading via pty... ";
37 run(makecmd($ptybuf * 3), '<pty<', \$in, '>', \$out);
38 print "done\n";
+12
-0
abuse/broken_pipe_on_bad_executable_name less more
0 #!/usr/bin/perl -w
1
2 ## Submitted by Dave Mitchell <davem@fdgroup.co.uk>
3
4 use IPC::Run qw(run timeout);
5
6 $IPC::Run::debug = 10 ;
7
8 warn "parent id=$$\n";
9 $res = run [ './nosuchfile', 0 ], \"foo", \$out, \$err ;
10 warn "running after 'run',
11 pid=$$\n\$?=$?\nstderr=[[[[$err]]]]\nstdout=[[[[$out]]]]\n";
+12
-0
abuse/timers less more
0 #!/usr/local/lib/perl -w
1
2 use strict ;
3 use IPC::Run qw( :all ) ;
4
5 $IPC::Run::debug = 10 ;
6
7 alarm 5 ;
8 $SIG{ALRM} = sub { die "timeout never fired!" } ;
9
10 my $out ;
11 run [$^X, '-e', 'sleep 10'], ">", \$out, timeout 1 ;
+53
-0
eg/factorial less more
0 #!/usr/bin/perl -w
1
2 ## Demonstration of event-driven interaction with a subprocess
3
4 ## Event driven programming is a pain. This code is not that readable
5 ## and is not a good place to start, especially since few people (including
6 ## me) are familiar with bc's nuances.
7
8 use strict ;
9
10 use IPC::Run qw( run ) ;
11
12 die "usage: $0 <num>\n\nwhere <num> is a positive integer\n" unless @ARGV ;
13 my $i = shift ;
14 die "\$i must be > 0, not '$i'" unless $i =~ /^\d+$/ && $i > 0 ;
15
16 ## bc instructions to initialize two variables and print one out
17 my $stdin_queue = "a = i = $i ; i\n" ;
18
19 ## Note the FALSE on failure result (opposite of system()).
20 die $! unless run(
21 ['bc'],
22 sub {
23 ## Consume all input and return it. This is used instead of a plain
24 ## scalar because run() would close bc's stdin the first time the
25 ## scalar emptied.
26 my $r = $stdin_queue ;
27 $stdin_queue = '' ;
28 return $r ;
29 },
30 sub {
31 my $out = shift ;
32 print "bc said: ", $out ;
33
34 if ( $out =~ s/.*?(\d+)\n/$1/g ) {
35 ## Grab the number from bc. Assume all numbers are delivered in
36 ## single chunks and all numbers are significant.
37 if ( $out > $i ) {
38 ## i! is always >i for i > 0
39 print "result = ", $out, "\n" ;
40 $stdin_queue = undef ;
41 }
42 elsif ( $out == '1' ) {
43 ## End of calculation loop, get bc to output the result.
44 $stdin_queue = "a\n" ;
45 }
46 else {
47 ## get bc to calculate the next iteration and print it out.
48 $stdin_queue = "i = i - 1 ; a = a * i ; i\n" ;
49 }
50 }
51 },
52 ) ;
+40
-0
eg/factorial_pipe less more
0 #!/usr/bin/perl -w
1
2 ## Demonstration using a pipe to send input to a child process
3
4 use strict ;
5
6 use IPC::Run qw( start pump finish ) ;
7
8 die "usage: $0 <num>\n\nwhere <num> is a positive integer\n" unless @ARGV ;
9 my $i = shift ;
10 die "\$i must be > 0, not '$i'" unless $i =~ /^\d+$/ && $i > 0 ;
11
12 my $out ;
13
14 my $h = start ['bc'], '<pipe', \*IN, '>', \$out ;
15 my $tmp = select IN ; $|= 1 ; select $tmp ;
16
17 print IN "a = i = $i ; i\n" ;
18
19 while () {
20 $out = '' ;
21 pump $h until $out =~ s/.*?(\d+)\n/$1/g ;
22 print "bc said: $out\n" ;
23
24 if ( $out > $i ) {
25 ## i! is always >i for i > 0
26 print "result = ", $out, "\n" ;
27 close( IN ) ;
28 last ;
29 }
30 elsif ( $out == '1' ) {
31 ## End of calculation loop, get bc to output the result
32 print IN "a\n" ;
33 }
34 else {
35 print IN "i = i - 1 ; a = a * i ; i\n" ;
36 }
37 }
38
39 finish $h ;
+37
-0
eg/factorial_scalar less more
0 #!/usr/bin/perl -w
1
2 ## Demonstration of using a scalar to queue input to a child process
3
4 use strict ;
5
6 use IPC::Run qw( start timeout ) ;
7
8 die "usage: $0 <num>\n\nwhere <num> is a positive integer\n" unless @ARGV ;
9 my $i = shift ;
10 die "\$i must be > 0, not '$i'" unless $i =~ /^\d+$/ && $i > 0 ;
11
12 my ( $in, $out ) ;
13
14 my $h = start ['bc'], \$in, \$out, timeout( 5 ) ;
15
16 $in = "a = i = $i ; i\n" ;
17
18 while () {
19 $out = '' ;
20 $h->pump until $out =~ s/.*?(\d+)\n/$1/g ;
21 print "bc said: $out\n" ;
22 if ( $out > $i ) {
23 print "result = $out\n" ;
24 $in = undef ;
25 last ;
26 }
27 elsif ( $out == '1' ) {
28 ## End of calculation loop, get bc to output the result
29 $in = "a\n" ;
30 }
31 else {
32 $in = "i = i - 1 ; a = a * i ; i\n" ;
33 }
34 }
35
36 $h->finish ;
+19
-0
eg/run_daemon less more
0 #!/usr/local/bin/perl -w
1
2 ## An example of how to daemonize. See the IPC::Run LIMITATIONS section for
3 ## some reasons why this can be a bit dangerous.
4
5 use strict ;
6
7 use IPC::Run qw( run close_terminal ) ;
8
9 run(
10 sub {
11 # ... your code here ...
12 sleep 15 ;
13 },
14 init => sub {
15 close_terminal ;
16 exit if fork ;
17 }
18 ) ;
+37
-0
eg/runsh less more
0 #!/usr/bin/perl -w
1
2 ## Demonstration of chatting with a bash shell.
3
4 use strict ;
5
6 use IPC::Run qw( start pump finish timeout ) ;
7
8 my ( $in, $out, $err ) ;
9
10 my $h = start(
11 [qw(sh -login -i )], \$in, \$out, \$err,
12 debug => 0,
13 timeout( 5 ),
14 ) ;
15
16 ## The first thing we do is to convert the user's prompt. Normally, we would
17 ## do a '' as the first command in the for () loop so we could detect errors
18 ## that bash might emit on startup. In this case, we need to do this
19 ## initialization first so that we have a prompt to look for so we know that
20 ## it's ready to accept input. This is all because the startup scripts
21 ## that bash runs set PS1, and we can't have that.
22 $in = "PS1='<PROMPT> '\n" ;
23
24 ## bash prompts on stderr. Consume everything before the first
25 ## <PROMPT> (which is the second prompt bash issues).
26 pump $h until $err =~ s/.*(?=^<PROMPT> (?!\n)\Z)//ms ;
27
28 for ( qw( ls ps fOoBaR pwd ) ) {
29 $in = $_ . "\n" ;
30 $out = '' ;
31 pump $h until $err =~ s/\A(<PROMPT> .*)(?=^<PROMPT> (?!\n)\Z)//ms ;
32 print map { "sh err: $_\n" } split( /\n/m, $1 ) ;
33 print map { "sh: $_\n" } split( /\n/m, $out ) ;
34 }
35
36 finish $h ;
+46
-0
eg/runsu less more
0 #!/usr/bin/perl -w
1
2 ## Demonstration of chatting with a bash shell.
3
4 use strict ;
5
6 use IPC::Run qw( start pump finish timeout ) ;
7
8 $IPC::Run::debug = 10 ;
9
10 my ( $in, $out ) ;
11
12 die "usage: runsu <user> <password>" unless @ARGV ;
13
14 my $user = @ARGV > 1 ? shift : $ENV{USER} || $ENV{USERNAME} ;
15 my $passwd = shift ;
16
17 my $h = start(
18 [qw(su - ), $user], '<pty<', \$in, '>pty>', \$out,
19 timeout( 5 ),
20 ) ;
21
22 pump $h until $out =~ /^password/im ;
23
24 $in = "$passwd\n" ;
25
26 ## Assume atomic prompt writes
27 ## and that a non-word is the last char in the prompt.
28 $out = '' ;
29 pump $h until $out =~ /([^\r\n\w]\s*)(?!\n)$/ ;
30 my $prompt = $1 ;
31
32 print "Detected prompt string = '$prompt'\n" ;
33
34 $prompt = quotemeta $prompt ;
35
36 for ( qw( ls ps fOoBaR pwd ) ) {
37 $in = $_ . "\n" ;
38 $out = '' ;
39 $h->timeout( 5 ) ; # restart the timout
40 pump $h until $out =~ s/\A((?s:.*))(?=^.*?$prompt(?!\n)\Z)//m ;
41 print map { "su: $_\n" } split( /\n/m, $1 ) ;
42 }
43
44 $in = "exit\n" ;
45 finish $h ;
+24
-0
eg/synopsis_scripting less more
0 use strict ;
1
2 my @cat = qw( cat ) ;
3 my ( $in_q, $out_q, $err_q ) ;
4
5 use IPC::Run qw( start pump finish timeout ) ;
6
7 # Incrementally read from / write to scalars. Note that $in_q
8 # is a queue that is drained as it is used. $h is for "harness".
9 my $h = start \@cat, \$in_q, \$out_q, \$err_q, timeout( 10 ), debug => 1 ;
10
11 $in_q .= "some input\n" ;
12 pump $h until $out_q =~ /input\n/g ;
13
14 $in_q .= "some more input\n" ;
15 pump $h until $out_q =~ /\G.*more input\n/ ;
16
17 $in_q .= "some final input\n" ;
18 finish $h or die "cat returned $?" ;
19
20 warn $err_q if $err_q ;
21 print $out_q ; ## All of cat's output
22
23
+311
-0
lib/IPC/Run/Debug.pm less more
0 package IPC::Run::Debug;
1
2 =head1 NAME
3
4 IPC::Run::Debug - debugging routines for IPC::Run
5
6 =head1 SYNOPSIS
7
8 ##
9 ## Environment variable usage
10 ##
11 ## To force debugging off and shave a bit of CPU and memory
12 ## by compile-time optimizing away all debugging code in IPC::Run
13 ## (debug => ...) options to IPC::Run will be ignored.
14 export IPCRUNDEBUG=none
15
16 ## To force debugging on (levels are from 0..10)
17 export IPCRUNDEBUG=basic
18
19 ## Leave unset or set to "" to compile in debugging support and
20 ## allow runtime control of it using the debug option.
21
22 =head1 DESCRIPTION
23
24 Controls IPC::Run debugging. Debugging levels are now set by using words,
25 but the numbers shown are still supported for backwards compatability:
26
27 0 none disabled (special, see below)
28 1 basic what's running
29 2 data what's being sent/recieved
30 3 details what's going on in more detail
31 4 gory way too much detail for most uses
32 10 all use this when submitting bug reports
33 noopts optimizations forbidden due to inherited STDIN
34
35 The C<none> level is special when the environment variable IPCRUNDEBUG
36 is set to this the first time IPC::Run::Debug is loaded: it prevents
37 the debugging code from being compiled in to the remaining IPC::Run modules,
38 saving a bit of cpu.
39
40 To do this in a script, here's a way that allows it to be overridden:
41
42 BEGIN {
43 unless ( defined $ENV{IPCRUNDEBUG} ) {
44 eval 'local $ENV{IPCRUNDEBUG} = "none"; require IPC::Run::Debug"'
45 or die $@;
46 }
47 }
48
49 This should force IPC::Run to not be debuggable unless somebody sets
50 the IPCRUNDEBUG flag; modify this formula to grep @ARGV if need be:
51
52 BEGIN {
53 unless ( grep /^--debug/, @ARGV ) {
54 eval 'local $ENV{IPCRUNDEBUG} = "none"; require IPC::Run::Debug"'
55 or die $@;
56 }
57
58 Both of those are untested.
59
60 =cut
61
62 @ISA = qw( Exporter ) ;
63
64 ## We use @EXPORT for the end user's convenience: there's only one function
65 ## exported, it's homonymous with the module, it's an unusual name, and
66 ## it can be suppressed by "use IPC::Run () ;".
67
68 @EXPORT = qw(
69 _debug
70 _debug_desc_fd
71 _debugging
72 _debugging_data
73 _debugging_details
74 _debugging_gory_details
75 _debugging_not_optimized
76 _set_child_debug_name
77 );
78
79
80 @EXPORT_OK = qw(
81 _debug_init
82 _debugging_level
83 _map_fds
84 );
85
86 %EXPORT_TAGS = (
87 default => \@EXPORT,
88 all => [ @EXPORT, @EXPORT_OK ],
89 );
90
91 use strict ;
92 use Exporter ;
93
94 my $disable_debugging =
95 defined $ENV{IPCRUNDEBUG}
96 && (
97 ! $ENV{IPCRUNDEBUG}
98 || lc $ENV{IPCRUNDEBUG} eq "none"
99 );
100
101 eval( $disable_debugging ? <<'STUBS' : <<'SUBS' ) or die $@;
102 sub _map_fds() { "" }
103 sub _debug {}
104 sub _debug_desc_fd {}
105 sub _debug_init {}
106 sub _set_child_debug_name {}
107 sub _debugging() { 0 }
108 sub _debugging_level() { 0 }
109 sub _debugging_data() { 0 }
110 sub _debugging_details() { 0 }
111 sub _debugging_gory_details() { 0 }
112 sub _debugging_not_optimized() { 0 }
113
114 1;
115 STUBS
116
117 use POSIX;
118 use UNIVERSAL qw( isa );
119
120 sub _map_fds {
121 my $map = '' ;
122 my $digit = 0 ;
123 my $in_use ;
124 my $dummy ;
125 for my $fd (0..63) {
126 ## I'd like a quicker way (less user, cpu & expecially sys and kernal
127 ## calls) to detect open file descriptors. Let me know...
128 ## Hmmm, could do a 0 length read and check for bad file descriptor...
129 ## but that segfaults on Win32
130 my $test_fd = POSIX::dup( $fd ) ;
131 $in_use = defined $test_fd ;
132 POSIX::close $test_fd if $in_use ;
133 $map .= $in_use ? $digit : '-';
134 $digit = 0 if ++$digit > 9 ;
135 }
136 warn "No fds open???" unless $map =~ /\d/ ;
137 $map =~ s/(.{1,12})-*$/$1/ ;
138 return $map ;
139 }
140
141 use vars qw( $parent_pid ) ;
142
143 $parent_pid = $$ ;
144
145 ## TODO: move debugging to it's own module and make it compile-time
146 ## optimizable.
147
148 ## Give kid process debugging nice names
149 my $debug_name ;
150
151 sub _set_child_debug_name {
152 $debug_name = shift;
153 }
154
155 ## There's a bit of hackery going on here.
156 ##
157 ## We want to have any code anywhere be able to emit
158 ## debugging statements without knowing what harness the code is
159 ## being called in/from, since we'd need to pass a harness around to
160 ## everything.
161 ##
162 ## Thus, $cur_self was born.
163 #
164 my %debug_levels = (
165 none => 0,
166 basic => 1,
167 data => 2,
168 details => 3,
169 gore => 4,
170 gory_details => 4,
171 "gory details" => 4,
172 gory => 4,
173 gorydetails => 4,
174 all => 10,
175 notopt => 0,
176 );
177
178 my $warned;
179
180 sub _debugging_level() {
181 my $level = 0 ;
182
183 $level = $IPC::Run::cur_self->{debug} || 0
184 if $IPC::Run::cur_self
185 && ( $IPC::Run::cur_self->{debug} || 0 ) >= $level ;
186
187 if ( defined $ENV{IPCRUNDEBUG} ) {
188 my $v = $ENV{IPCRUNDEBUG};
189 $v = $debug_levels{lc $v} if $v =~ /[a-zA-Z]/;
190 unless ( defined $v ) {
191 $warned ||= warn "Unknown debug level $ENV{IPCRUNDEBUG}, assuming 'basic' (1)\n";
192 $v = 1;
193 }
194 $level = $v if $v > $level ;
195 }
196 return $level ;
197 }
198
199 sub _debugging_atleast($) {
200 my $min_level = shift || 1 ;
201
202 my $level = _debugging_level ;
203
204 return $level >= $min_level ? $level : 0 ;
205 }
206
207 sub _debugging() { _debugging_atleast 1 }
208 sub _debugging_data() { _debugging_atleast 2 }
209 sub _debugging_details() { _debugging_atleast 3 }
210 sub _debugging_gory_details() { _debugging_atleast 4 }
211 sub _debugging_not_optimized() { ( $ENV{IPCRUNDEBUG} || "" ) eq "notopt" }
212
213 sub _debug_init {
214 ## This routine is called only in spawned children to fake out the
215 ## debug routines so they'll emit debugging info.
216 $IPC::Run::cur_self = {} ;
217 ( $parent_pid,
218 $^T,
219 $IPC::Run::cur_self->{debug},
220 $IPC::Run::cur_self->{DEBUG_FD},
221 $debug_name
222 ) = @_ ;
223 }
224
225
226 sub _debug {
227 # return unless _debugging || _debugging_not_optimized ;
228
229 my $fd = defined &IPC::Run::_debug_fd
230 ? IPC::Run::_debug_fd()
231 : fileno STDERR;
232
233 my $s ;
234 my $debug_id ;
235 $debug_id = join(
236 " ",
237 join(
238 "",
239 defined $IPC::Run::cur_self ? "#$IPC::Run::cur_self->{ID}" : (),
240 "($$)",
241 ),
242 defined $debug_name && length $debug_name ? $debug_name : (),
243 ) ;
244 my $prefix = join(
245 "",
246 "IPC::Run",
247 sprintf( " %04d", time - $^T ),
248 ( _debugging_details ? ( " ", _map_fds ) : () ),
249 length $debug_id ? ( " [", $debug_id, "]" ) : (),
250 ": ",
251 ) ;
252
253 my $msg = join( '', map defined $_ ? $_ : "<undef>", @_ ) ;
254 chomp $msg ;
255 $msg =~ s{^}{$prefix}gm ;
256 $msg .= "\n" ;
257 POSIX::write( $fd, $msg, length $msg ) ;
258 }
259
260
261 my @fd_descs = ( 'stdin', 'stdout', 'stderr' ) ;
262
263 sub _debug_desc_fd {
264 return unless _debugging ;
265 my $text = shift ;
266 my $op = pop ;
267 my $kid = $_[0] ;
268
269 Carp::carp join " ", caller(0), $text, $op if defined $op && isa( $op, "IO::Pty" ) ;
270
271 _debug(
272 $text,
273 ' ',
274 ( defined $op->{FD}
275 ? $op->{FD} < 3
276 ? ( $fd_descs[$op->{FD}] )
277 : ( 'fd ', $op->{FD} )
278 : $op->{FD}
279 ),
280 ( defined $op->{KFD}
281 ? (
282 ' (kid',
283 ( defined $kid ? ( ' ', $kid->{NUM}, ) : () ),
284 "'s ",
285 ( $op->{KFD} < 3
286 ? $fd_descs[$op->{KFD}]
287 : defined $kid
288 && defined $kid->{DEBUG_FD}
289 && $op->{KFD} == $kid->{DEBUG_FD}
290 ? ( 'debug (', $op->{KFD}, ')' )
291 : ( 'fd ', $op->{KFD} )
292 ),
293 ')',
294 )
295 : ()
296 ),
297 ) ;
298 }
299
300 1;
301
302 SUBS
303
304 =head1 AUTHOR
305
306 Barrie Slaymaker <barries@slaysys.com>, with numerous suggestions by p5p.
307
308 =cut
309
310 1 ;
+562
-0
lib/IPC/Run/IO.pm less more
0 package IPC::Run::IO ;
1
2 =head1 NAME
3
4 IPC::Run::IO -- I/O channels for IPC::Run.
5
6 =head1 SYNOPSIS
7
8 B<NOT IMPLEMENTED YET ON Win32! Win32 does not allow select() on
9 normal file descriptors; IPC::RUN::IO needs to use IPC::Run::Win32Helper
10 to do this.>
11
12 use IPC::Run qw( io ) ;
13
14 ## The sense of '>' and '<' is opposite of perl's open(),
15 ## but agrees with IPC::Run.
16 $io = io( "filename", '>', \$recv ) ;
17 $io = io( "filename", 'r', \$recv ) ;
18
19 ## Append to $recv:
20 $io = io( "filename", '>>', \$recv ) ;
21 $io = io( "filename", 'ra', \$recv ) ;
22
23 $io = io( "filename", '<', \$send ) ;
24 $io = io( "filename", 'w', \$send ) ;
25
26 $io = io( "filename", '<<', \$send ) ;
27 $io = io( "filename", 'wa', \$send ) ;
28
29 ## Handles / IO objects that the caller opens:
30 $io = io( \*HANDLE, '<', \$send ) ;
31
32 $f = IO::Handle->new( ... ) ; # Any subclass of IO::Handle
33 $io = io( $f, '<', \$send ) ;
34
35 require IPC::Run::IO ;
36 $io = IPC::Run::IO->new( ... ) ;
37
38 ## Then run(), harness(), or start():
39 run $io, ... ;
40
41 ## You can, of course, use io() or IPC::Run::IO->new() as an
42 ## argument to run(), harness, or start():
43 run io( ... ) ;
44
45
46 =head1 DESCRIPTION
47
48 This class and module allows filehandles and filenames to be harnessed for
49 I/O when used IPC::Run, independant of anything else IPC::Run is doing
50 (except that errors & exceptions can affect all things that IPC::Run is
51 doing).
52
53 =head1 SUBCLASSING
54
55 INCOMPATIBLE CHANGE: due to the awkwardness introduced in ripping pseudohashes
56 out of Perl, this class I<no longer> uses the fields pragma.
57
58 =head1 TODO
59
60 Implement bidirectionality.
61
62 =head1 AUTHOR
63
64 Barrie Slaymaker <barries@slaysys.com>
65
66 =cut ;
67
68 ## This class is also used internally by IPC::Run in a very initimate way,
69 ## since this is a partial factoring of code from IPC::Run plus some code
70 ## needed to do standalone channels. This factoring process will continue
71 ## at some point. Don't know how far how fast.
72
73 use strict ;
74 use Carp ;
75 use Fcntl ;
76 use Symbol ;
77 use UNIVERSAL qw( isa ) ;
78
79 use IPC::Run::Debug;
80 use IPC::Run qw( Win32_MODE );
81
82 BEGIN {
83 if ( Win32_MODE ) {
84 eval "use IPC::Run::Win32Helper; require IPC::Run::Win32IO; 1"
85 or ( $@ && die ) or die "$!" ;
86 }
87 }
88
89 sub _empty($) ;
90
91 *_empty = \&IPC::Run::_empty ;
92
93
94 sub new {
95 my $class = shift ;
96 $class = ref $class || $class ;
97
98 my ( $external, $type, $internal ) = ( shift, shift, pop ) ;
99
100 croak "$class: '$_' is not a valid I/O operator"
101 unless $type =~ /^(?:<<?|>>?)$/ ;
102
103 my IPC::Run::IO $self = $class->_new_internal(
104 $type, undef, undef, $internal, undef, @_
105 ) ;
106
107 if ( ! ref $external ) {
108 $self->{FILENAME} = $external ;
109 }
110 elsif ( ref eq 'GLOB' || isa( $external, 'IO::Handle' ) ) {
111 $self->{HANDLE} = $external ;
112 $self->{DONT_CLOSE} = 1 ;
113 }
114 else {
115 croak "$class: cannot accept " . ref( $external ) . " to do I/O with" ;
116 }
117
118 return $self ;
119 }
120
121
122 ## IPC::Run uses this ctor, since it preparses things and needs more
123 ## smarts.
124 sub _new_internal {
125 my $class = shift ;
126 $class = ref $class || $class ;
127
128 $class = "IPC::Run::Win32IO"
129 if Win32_MODE && $class eq "IPC::Run::IO";
130
131 my IPC::Run::IO $self ;
132 $self = bless {}, $class ;
133
134 my ( $type, $kfd, $pty_id, $internal, $binmode, @filters ) = @_ ;
135
136 # Older perls (<=5.00503, at least) don't do list assign to
137 # psuedo-hashes well.
138 $self->{TYPE} = $type ;
139 $self->{KFD} = $kfd ;
140 $self->{PTY_ID} = $pty_id ;
141 $self->binmode( $binmode ) ;
142 $self->{FILTERS} = [ @filters ] ;
143
144 ## Add an adapter to the end of the filter chain (which is usually just the
145 ## read/writer sub pushed by IPC::Run) to the DEST or SOURCE, if need be.
146 if ( $self->op =~ />/ ) {
147 croak "'$_' missing a destination" if _empty $internal ;
148 $self->{DEST} = $internal ;
149 if ( isa( $self->{DEST}, 'CODE' ) ) {
150 ## Put a filter on the end of the filter chain to pass the
151 ## output on to the CODE ref. For SCALAR refs, the last
152 ## filter in the chain writes directly to the scalar itself. See
153 ## _init_filters(). For CODE refs, however, we need to adapt from
154 ## the SCALAR to calling the CODE.
155 unshift(
156 @{$self->{FILTERS}},
157 sub {
158 my ( $in_ref ) = @_ ;
159
160 return IPC::Run::input_avail() && do {
161 $self->{DEST}->( $$in_ref ) ;
162 $$in_ref = '' ;
163 1 ;
164 }
165 }
166 ) ;
167 }
168 }
169 else {
170 croak "'$_' missing a source" if _empty $internal ;
171 $self->{SOURCE} = $internal ;
172 if ( isa( $internal, 'CODE' ) ) {
173 push(
174 @{$self->{FILTERS}},
175 sub {
176 my ( $in_ref, $out_ref ) = @_ ;
177 return 0 if length $$out_ref ;
178
179 return undef
180 if $self->{SOURCE_EMPTY} ;
181
182 my $in = $internal->() ;
183 unless ( defined $in ) {
184 $self->{SOURCE_EMPTY} = 1 ;
185 return undef
186 }
187 return 0 unless length $in ;
188 $$out_ref = $in ;
189
190 return 1 ;
191 }
192 ) ;
193 }
194 elsif ( isa( $internal, 'SCALAR' ) ) {
195 push(
196 @{$self->{FILTERS}},
197 sub {
198 my ( $in_ref, $out_ref ) = @_ ;
199 return 0 if length $$out_ref ;
200
201 ## pump() clears auto_close_ins, finish() sets it.
202 return $self->{HARNESS}->{auto_close_ins} ? undef : 0
203 if IPC::Run::_empty ${$self->{SOURCE}}
204 || $self->{SOURCE_EMPTY} ;
205
206 $$out_ref = $$internal ;
207 eval { $$internal = '' }
208 if $self->{HARNESS}->{clear_ins} ;
209
210 $self->{SOURCE_EMPTY} = $self->{HARNESS}->{auto_close_ins} ;
211
212 return 1 ;
213 }
214 ) ;
215 }
216 }
217
218 return $self ;
219 }
220
221
222 =item filename
223
224 Gets/sets the filename. Returns the value after the name change, if
225 any.
226
227 =cut
228
229 sub filename {
230 my IPC::Run::IO $self = shift ;
231 $self->{FILENAME} = shift if @_ ;
232 return $self->{FILENAME} ;
233 }
234
235
236 =item init
237
238 Does initialization required before this can be run. This includes open()ing
239 the file, if necessary, and clearing the destination scalar if necessary.
240
241 =cut
242
243 sub init {
244 my IPC::Run::IO $self = shift ;
245
246 $self->{SOURCE_EMPTY} = 0 ;
247 ${$self->{DEST}} = ''
248 if $self->mode =~ /r/ && ref $self->{DEST} eq 'SCALAR' ;
249
250 $self->open if defined $self->filename ;
251 $self->{FD} = $self->fileno ;
252
253 if ( ! $self->{FILTERS} ) {
254 $self->{FBUFS} = undef ;
255 }
256 else {
257 @{$self->{FBUFS}} = map {
258 my $s = "" ;
259 \$s ;
260 } ( @{$self->{FILTERS}}, '' ) ;
261
262 $self->{FBUFS}->[0] = $self->{DEST}
263 if $self->{DEST} && ref $self->{DEST} eq 'SCALAR' ;
264 push @{$self->{FBUFS}}, $self->{SOURCE} ;
265 }
266
267 return undef ;
268 }
269
270
271 =item open
272
273 If a filename was passed in, opens it. Determines if the handle is open
274 via fileno(). Throws an exception on error.
275
276 =cut
277
278 my %open_flags = (
279 '>' => O_RDONLY,
280 '>>' => O_RDONLY,
281 '<' => O_WRONLY | O_CREAT | O_TRUNC,
282 '<<' => O_WRONLY | O_CREAT | O_APPEND,
283 ) ;
284
285 sub open {
286 my IPC::Run::IO $self = shift ;
287
288 croak "IPC::Run::IO: Can't open() a file with no name"
289 unless defined $self->{FILENAME} ;
290 $self->{HANDLE} = gensym unless $self->{HANDLE} ;
291
292 _debug
293 "opening '", $self->filename, "' mode '", $self->mode, "'"
294 if _debugging_data ;
295 sysopen(
296 $self->{HANDLE},
297 $self->filename,
298 $open_flags{$self->op},
299 ) or croak
300 "IPC::Run::IO: $! opening '$self->{FILENAME}', mode '" . $self->mode . "'" ;
301
302 return undef ;
303 }
304
305
306 =item open_pipe
307
308 If this is a redirection IO object, this opens the pipe in a platform
309 independant manner.
310
311 =cut
312
313 sub _do_open {
314 my $self = shift;
315 my ( $child_debug_fd, $parent_handle ) = @_ ;
316
317
318 if ( $self->dir eq "<" ) {
319 ( $self->{TFD}, $self->{FD} ) = IPC::Run::_pipe_nb ;
320 if ( $parent_handle ) {
321 CORE::open $parent_handle, ">&=$self->{FD}"
322 or croak "$! duping write end of pipe for caller" ;
323 }
324 }
325 else {
326 ( $self->{FD}, $self->{TFD} ) = IPC::Run::_pipe ;
327 if ( $parent_handle ) {
328 CORE::open $parent_handle, "<&=$self->{FD}"
329 or croak "$! duping read end of pipe for caller" ;
330 }
331 }
332 }
333
334 sub open_pipe {
335 my IPC::Run::IO $self = shift ;
336
337 ## Hmmm, Maybe allow named pipes one day. But until then...
338 croak "IPC::Run::IO: Can't pipe() when a file name has been set"
339 if defined $self->{FILENAME} ;
340
341 $self->_do_open( @_ );
342
343 ## return ( child_fd, parent_fd )
344 return $self->dir eq "<"
345 ? ( $self->{TFD}, $self->{FD} )
346 : ( $self->{FD}, $self->{TFD} ) ;
347 }
348
349
350 sub _cleanup { ## Called from Run.pm's _cleanup
351 my $self = shift;
352 undef $self->{FAKE_PIPE};
353 }
354
355
356 =item close
357
358 Closes the handle. Throws an exception on failure.
359
360
361 =cut
362
363 sub close {
364 my IPC::Run::IO $self = shift ;
365
366 if ( defined $self->{HANDLE} ) {
367 close $self->{HANDLE}
368 or croak( "IPC::Run::IO: $! closing "
369 . ( defined $self->{FILENAME}
370 ? "'$self->{FILENAME}'"
371 : "handle"
372 )
373 ) ;
374 }
375 else {
376 IPC::Run::_close( $self->{FD} ) ;
377 }
378
379 $self->{FD} = undef ;
380
381 return undef ;
382 }
383
384 =item fileno
385
386 Returns the fileno of the handle. Throws an exception on failure.
387
388
389 =cut
390
391 sub fileno {
392 my IPC::Run::IO $self = shift ;
393
394 my $fd = fileno $self->{HANDLE} ;
395 croak( "IPC::Run::IO: $! "
396 . ( defined $self->{FILENAME}
397 ? "'$self->{FILENAME}'"
398 : "handle"
399 )
400 ) unless defined $fd ;
401
402 return $fd ;
403 }
404
405 =item mode
406
407 Returns the operator in terms of 'r', 'w', and 'a'. There is a state
408 'ra', unlike Perl's open(), which indicates that data read from the
409 handle or file will be appended to the output if the output is a scalar.
410 This is only meaningful if the output is a scalar, it has no effect if
411 the output is a subroutine.
412
413 The redirection operators can be a little confusing, so here's a reference
414 table:
415
416 > r Read from handle in to process
417 < w Write from process out to handle
418 >> ra Read from handle in to process, appending it to existing
419 data if the destination is a scalar.
420 << wa Write from process out to handle, appending to existing
421 data if IPC::Run::IO opened a named file.
422
423 =cut
424
425 sub mode {
426 my IPC::Run::IO $self = shift ;
427
428 croak "IPC::Run::IO: unexpected arguments for mode(): @_" if @_ ;
429
430 ## TODO: Optimize this
431 return ( $self->{TYPE} =~ /</ ? 'w' : 'r' ) .
432 ( $self->{TYPE} =~ /<<|>>/ ? 'a' : '' ) ;
433 }
434
435
436 =item op
437
438 Returns the operation: '<', '>', '<<', '>>'. See L</mode> if you want
439 to spell these 'r', 'w', etc.
440
441 =cut
442
443 sub op {
444 my IPC::Run::IO $self = shift ;
445
446 croak "IPC::Run::IO: unexpected arguments for op(): @_" if @_ ;
447
448 return $self->{TYPE} ;
449 }
450
451 =item binmode
452
453 Sets/gets whether this pipe is in binmode or not. No effect off of Win32
454 OSs, of course, and on Win32, no effect after the harness is start()ed.
455
456 =cut
457
458 sub binmode {
459 my IPC::Run::IO $self = shift ;
460
461 $self->{BINMODE} = shift if @_ ;
462
463 return $self->{BINMODE} ;
464 }
465
466
467 =item dir
468
469 Returns the first character of $self->op. This is either "<" or ">".
470
471 =cut
472
473 sub dir {
474 my IPC::Run::IO $self = shift ;
475
476 croak "IPC::Run::IO: unexpected arguments for dir(): @_" if @_ ;
477
478 return substr $self->{TYPE}, 0, 1 ;
479 }
480
481
482 ##
483 ## Filter Scaffolding
484 ##
485 #my $filter_op ; ## The op running a filter chain right now
486 #my $filter_num ; ## Which filter is being run right now.
487
488 use vars (
489 '$filter_op', ## The op running a filter chain right now
490 '$filter_num' ## Which filter is being run right now.
491 ) ;
492
493 sub _init_filters {
494 my IPC::Run::IO $self = shift ;
495
496 confess "\$self not an IPC::Run::IO" unless isa( $self, "IPC::Run::IO" ) ;
497 $self->{FBUFS} = [] ;
498
499 $self->{FBUFS}->[0] = $self->{DEST}
500 if $self->{DEST} && ref $self->{DEST} eq 'SCALAR' ;
501
502 return unless $self->{FILTERS} && @{$self->{FILTERS}} ;
503
504 push @{$self->{FBUFS}}, map {
505 my $s = "" ;
506 \$s ;
507 } ( @{$self->{FILTERS}}, '' ) ;
508
509 push @{$self->{FBUFS}}, $self->{SOURCE} ;
510 }
511
512
513 sub poll {
514 my IPC::Run::IO $self = shift;
515 my ( $harness ) = @_;
516
517 if ( defined $self->{FD} ) {
518 my $d = $self->dir;
519 if ( $d eq "<" ) {
520 if ( vec $harness->{WOUT}, $self->{FD}, 1 ) {
521 _debug_desc_fd( "filtering data to", $self )
522 if _debugging_details ;
523 return $self->_do_filters( $harness );
524 }
525 }
526 elsif ( $d eq ">" ) {
527 if ( vec $harness->{ROUT}, $self->{FD}, 1 ) {
528 _debug_desc_fd( "filtering data from", $self )
529 if _debugging_details ;
530 return $self->_do_filters( $harness );
531 }
532 }
533 }
534 return 0;
535 }
536
537
538 sub _do_filters {
539 my IPC::Run::IO $self = shift ;
540
541 ( $self->{HARNESS} ) = @_ ;
542
543 my ( $saved_op, $saved_num ) =($IPC::Run::filter_op,$IPC::Run::filter_num) ;
544 $IPC::Run::filter_op = $self ;
545 $IPC::Run::filter_num = -1 ;
546 my $c = 0;
547 my $r;
548 {
549 $@ = '';
550 $r = eval { IPC::Run::get_more_input() ; } ;
551 $c++;
552 ##$@ and warn "redo ", substr($@, 0, 20) , " ";
553 (($c < 200) and ($@||'')=~ m/^Resource temporarily/) and redo;
554 }
555 ( $IPC::Run::filter_op, $IPC::Run::filter_num ) = ( $saved_op, $saved_num ) ;
556 $self->{HARNESS} = undef ;
557 die "ack ", $@ if $@ ;
558 return $r ;
559 }
560
561 1 ;
+688
-0
lib/IPC/Run/Timer.pm less more
0 package IPC::Run::Timer ;
1
2 =head1 NAME
3
4 IPC::Run::Timer -- Timer channels for IPC::Run.
5
6 =head1 SYNOPSIS
7
8 use IPC::Run qw( run timer timeout ) ;
9 ## or IPC::Run::Timer ( timer timeout ) ;
10 ## or IPC::Run::Timer ( :all ) ;
11
12 ## A non-fatal timer:
13 $t = timer( 5 ) ; # or...
14 $t = IO::Run::Timer->new( 5 ) ;
15 run $t, ... ;
16
17 ## A timeout (which is a timer that dies on expiry):
18 $t = timeout( 5 ) ; # or...
19 $t = IO::Run::Timer->new( 5, exception => "harness timed out" ) ;
20
21 =head1 DESCRIPTION
22
23 This class and module allows timers and timeouts to be created for use
24 by IPC::Run. A timer simply expires when it's time is up. A timeout
25 is a timer that throws an exception when it expires.
26
27 Timeouts are usually a bit simpler to use than timers: they throw an
28 exception on expiration so you don't need to check them:
29
30 ## Give @cmd 10 seconds to get started, then 5 seconds to respond
31 my $t = timeout( 10 ) ;
32 $h = start(
33 \@cmd, \$in, \$out,
34 $t,
35 ) ;
36 pump $h until $out =~ /prompt/ ;
37
38 $in = "some stimulus" ;
39 $out = '' ;
40 $t->time( 5 )
41 pump $h until $out =~ /expected response/ ;
42
43 You do need to check timers:
44
45 ## Give @cmd 10 seconds to get started, then 5 seconds to respond
46 my $t = timer( 10 ) ;
47 $h = start(
48 \@cmd, \$in, \$out,
49 $t,
50 ) ;
51 pump $h until $t->is_expired || $out =~ /prompt/ ;
52
53 $in = "some stimulus" ;
54 $out = '' ;
55 $t->time( 5 )
56 pump $h until $out =~ /expected response/ || $t->is_expired ;
57
58 Timers and timeouts that are reset get started by start() and
59 pump(). Timers change state only in pump(). Since run() and
60 finish() both call pump(), they act like pump() with repect to
61 timers.
62
63 Timers and timeouts have three states: reset, running, and expired.
64 Setting the timeout value resets the timer, as does calling
65 the reset() method. The start() method starts (or restarts) a
66 timer with the most recently set time value, no matter what state
67 it's in.
68
69 =head2 Time values
70
71 All time values are in seconds. Times may be specified as integer or
72 floating point seconds, optionally preceded by puncuation-separated
73 days, hours, and minutes.\
74
75 Examples:
76
77 1 1 second
78 1.1 1.1 seconds
79 60 60 seconds
80 1:0 1 minute
81 1:1 1 minute, 1 second
82 1:90 2 minutes, 30 seconds
83 1:2:3:4.5 1 day, 2 hours, 3 minutes, 4.5 seconds
84
85 Absolute date/time strings are *not* accepted: year, month and
86 day-of-month parsing is not available (patches welcome :-).
87
88 =head2 Interval fudging
89
90 When calculating an end time from a start time and an interval, IPC::Run::Timer
91 instances add a little fudge factor. This is to ensure that no time will
92 expire before the interval is up.
93
94 First a little background. Time is sampled in discrete increments. We'll
95 call the
96 exact moment that the reported time increments from one interval to the
97 next a tick, and the interval between ticks as the time period. Here's
98 a diagram of three ticks and the periods between them:
99
100
101 -0-0-0-0-0-0-0-0-0-0-1-1-1-1-1-1-1-1-1-1-2-...
102 ^ ^ ^
103 |<--- period 0 ---->|<--- period 1 ---->|
104 | | |
105 tick 0 tick 1 tick 2
106
107 To see why the fudge factor is necessary, consider what would happen
108 when a timer with an interval of 1 second is started right at the end of
109 period 0:
110
111
112 -0-0-0-0-0-0-0-0-0-0-1-1-1-1-1-1-1-1-1-1-2-...
113 ^ ^ ^ ^
114 | | | |
115 | | | |
116 tick 0 |tick 1 tick 2
117 |
118 start $t
119
120 Assuming that check() is called many times per period, then the timer
121 is likely to expire just after tick 1, since the time reported will have
122 lept from the value '0' to the value '1':
123
124 -0-0-0-0-0-0-0-0-0-0-1-1-1-1-1-1-1-1-1-1-2-...
125 ^ ^ ^ ^ ^
126 | | | | |
127 | | | | |
128 tick 0 |tick 1| tick 2
129 | |
130 start $t |
131 |
132 check $t
133
134 Adding a fudge of '1' in this example means that the timer is guaranteed
135 not to expire before tick 2.
136
137 The fudge is not added to an interval of '0'.
138
139 This means that intervals guarantee a minimum interval. Given that
140 the process running perl may be suspended for some period of time, or that
141 it gets busy doing something time-consuming, there are no other guarantees on
142 how long it will take a timer to expire.
143
144 =head1 SUBCLASSING
145
146 INCOMPATIBLE CHANGE: Due to the awkwardness introduced by ripping
147 pseudohashes out of Perl, this class I<no longer> uses the fields
148 pragma.
149
150 =head1 FUNCTIONS & METHODS
151
152 =over
153
154 =cut ;
155
156 use strict ;
157 use Carp ;
158 use Fcntl ;
159 use Symbol ;
160 use UNIVERSAL qw( isa ) ;
161 use Exporter ;
162 use vars qw( @EXPORT_OK %EXPORT_TAGS @ISA ) ;
163
164 @EXPORT_OK = qw(
165 check
166 end_time
167 exception
168 expire
169 interval
170 is_expired
171 is_reset
172 is_running
173 name
174 reset
175 start
176
177 timeout
178 timer
179 ) ;
180
181 %EXPORT_TAGS = ( 'all' => \@EXPORT_OK ) ;
182
183 @ISA = qw( Exporter ) ;
184
185 require IPC::Run ;
186 use IPC::Run::Debug ;
187
188 ##
189 ## Some helpers
190 ##
191 my $resolution = 1 ;
192
193 sub _parse_time {
194 for ( $_[0] ) {
195 return $_ unless defined $_ ;
196 return $_ if /^\d*(?:\.\d*)?$/ ;
197
198 my @f = reverse split( /[^\d\.]+/i ) ;
199 croak "IPC::Run: invalid time string '$_'" unless @f <= 4 ;
200 my ( $s, $m, $h, $d ) = @f ;
201 return
202 ( (
203 ( $d || 0 ) * 24
204 + ( $h || 0 ) ) * 60
205 + ( $m || 0 ) ) * 60
206 + ( $s || 0 ) ;
207 }
208 }
209
210
211 sub _calc_end_time {
212 my IPC::Run::Timer $self = shift ;
213
214 my $interval = $self->interval ;
215 $interval += $resolution if $interval ;
216
217 $self->end_time( $self->start_time + $interval ) ;
218 }
219
220
221 =item timer
222
223 A constructor function (not method) of IPC::Run::Timer instances:
224
225 $t = timer( 5 ) ;
226 $t = timer( 5, name => 'stall timer', debug => 1 ) ;
227
228 $t = timer ;
229 $t->interval( 5 ) ;
230
231 run ..., $t ;
232 run ..., $t = timer( 5 ) ;
233
234 This convenience function is a shortened spelling of
235
236 IPC::Run::Timer->new( ... ) ;
237
238 . It returns a timer in the reset state with a given interval.
239
240 If an exception is provided, it will be thrown when the timer notices that
241 it has expired (in check()). The name is for debugging usage, if you plan on
242 having multiple timers around. If no name is provided, a name like "timer #1"
243 will be provided.
244
245 =cut
246
247 sub timer {
248 return IPC::Run::Timer->new( @_ ) ;
249 }
250
251
252 =item timeout
253
254 A constructor function (not method) of IPC::Run::Timer instances:
255
256 $t = timeout( 5 ) ;
257 $t = timeout( 5, exception => "kablooey" ) ;
258 $t = timeout( 5, name => "stall", exception => "kablooey" ) ;
259
260 $t = timeout ;
261 $t->interval( 5 ) ;
262
263 run ..., $t ;
264 run ..., $t = timeout( 5 ) ;
265
266 A This convenience function is a shortened spelling of
267
268 IPC::Run::Timer->new( exception => "IPC::Run: timeout ...", ... ) ;
269
270 . It returns a timer in the reset state that will throw an
271 exception when it expires.
272
273 Takes the same parameters as L</timer>, any exception passed in overrides
274 the default exception.
275
276 =cut
277
278 sub timeout {
279 my $t = IPC::Run::Timer->new( @_ ) ;
280 $t->exception( "IPC::Run: timeout on " . $t->name )
281 unless defined $t->exception ;
282 return $t ;
283 }
284
285
286 =item new
287
288 IPC::Run::Timer->new() ;
289 IPC::Run::Timer->new( 5 ) ;
290 IPC::Run::Timer->new( 5, exception => 'kablooey' ) ;
291
292 Constructor. See L</timer> for details.
293
294 =cut
295
296 my $timer_counter ;
297
298
299 sub new {
300 my $class = shift ;
301 $class = ref $class || $class ;
302
303 my IPC::Run::Timer $self = bless {}, $class;
304
305 $self->{STATE} = 0 ;
306 $self->{DEBUG} = 0 ;
307 $self->{NAME} = "timer #" . ++$timer_counter ;
308
309 while ( @_ ) {
310 my $arg = shift ;
311 if ( $arg =~ /^(?:\d+[^\a\d]){0,3}\d*(?:\.\d*)?$/ ) {
312 $self->interval( $arg ) ;
313 }
314 elsif ( $arg eq 'exception' ) {
315 $self->exception( shift ) ;
316 }
317 elsif ( $arg eq 'name' ) {
318 $self->name( shift ) ;
319 }
320 elsif ( $arg eq 'debug' ) {
321 $self->debug( shift ) ;
322 }
323 else {
324 croak "IPC::Run: unexpected parameter '$arg'" ;
325 }
326 }
327
328 _debug $self->name . ' constructed'
329 if $self->{DEBUG} || _debugging_details ;
330
331 return $self ;
332 }
333
334 =item check
335
336 check $t ;
337 check $t, $now ;
338 $t->check ;
339
340 Checks to see if a timer has expired since the last check. Has no effect
341 on non-running timers. This will throw an exception if one is defined.
342
343 IPC::Run::pump() calls this routine for any timers in the harness.
344
345 You may pass in a version of now, which is useful in case you have
346 it lying around or you want to check several timers with a consistent
347 concept of the current time.
348
349 Returns the time left before end_time or 0 if end_time is no longer
350 in the future or the timer is not running
351 (unless, of course, check() expire()s the timer and this
352 results in an exception being thrown).
353
354 Returns undef if the timer is not running on entry, 0 if check() expires it,
355 and the time left if it's left running.
356
357 =cut
358
359 sub check {
360 my IPC::Run::Timer $self = shift ;
361 return undef if ! $self->is_running ;
362 return 0 if $self->is_expired ;
363
364 my ( $now ) = @_ ;
365 $now = _parse_time( $now ) ;
366 $now = time unless defined $now ;
367
368 _debug(
369 "checking ", $self->name, " (end time ", $self->end_time, ") at ", $now
370 ) if $self->{DEBUG} || _debugging_details ;
371
372 my $left = $self->end_time - $now ;
373 return $left if $left > 0 ;
374
375 $self->expire ;
376 return 0 ;
377 }
378
379
380 =item debug
381
382 Sets/gets the current setting of the debugging flag for this timer. This
383 has no effect if debugging is not enabled for the current harness.
384
385 =cut
386
387
388 sub debug {
389 my IPC::Run::Timer $self = shift ;
390 $self->{DEBUG} = shift if @_ ;
391 return $self->{DEBUG} ;
392 }
393
394
395 =item end_time
396
397 $et = $t->end_time ;
398 $et = end_time $t ;
399
400 $t->end_time( time + 10 ) ;
401
402 Returns the time when this timer will or did expire. Even if this time is
403 in the past, the timer may not be expired, since check() may not have been
404 called yet.
405
406 Note that this end_time is not start_time($t) + interval($t), since some
407 small extra amount of time is added to make sure that the timer does not
408 expire before interval() elapses. If this were not so, then
409
410 Changing end_time() while a timer is running will set the expiration time.
411 Changing it while it is expired has no affect, since reset()ing a timer always
412 clears the end_time().
413
414 =cut
415
416
417 sub end_time {
418 my IPC::Run::Timer $self = shift ;
419 if ( @_ ) {
420 $self->{END_TIME} = shift ;
421 _debug $self->name, ' end_time set to ', $self->{END_TIME}
422 if $self->{DEBUG} > 2 || _debugging_details ;
423 }
424 return $self->{END_TIME} ;
425 }
426
427
428 =item exception
429
430 $x = $t->exception ;
431 $t->exception( $x ) ;
432 $t->exception( undef ) ;
433
434 Sets/gets the exception to throw, if any. 'undef' means that no
435 exception will be thrown. Exception does not need to be a scalar: you
436 may ask that references be thrown.
437
438 =cut
439
440
441 sub exception {
442 my IPC::Run::Timer $self = shift ;
443 if ( @_ ) {
444 $self->{EXCEPTION} = shift ;
445 _debug $self->name, ' exception set to ', $self->{EXCEPTION}
446 if $self->{DEBUG} || _debugging_details ;
447 }
448 return $self->{EXCEPTION} ;
449 }
450
451
452 =item interval
453
454 $i = interval $t ;
455 $i = $t->interval ;
456 $t->interval( $i ) ;
457
458 Sets the interval. Sets the end time based on the start_time() and the
459 interval (and a little fudge) if the timer is running.
460
461 =cut
462
463 sub interval {
464 my IPC::Run::Timer $self = shift ;
465 if ( @_ ) {
466 $self->{INTERVAL} = _parse_time( shift ) ;
467 _debug $self->name, ' interval set to ', $self->{INTERVAL}
468 if $self->{DEBUG} > 2 || _debugging_details ;
469
470 $self->_calc_end_time if $self->state ;
471 }
472 return $self->{INTERVAL} ;
473 }
474
475
476 =item expire
477
478 expire $t ;
479 $t->expire ;
480
481 Sets the state to expired (undef).
482 Will throw an exception if one
483 is defined and the timer was not already expired. You can expire a
484 reset timer without starting it.
485
486 =cut
487
488
489 sub expire {
490 my IPC::Run::Timer $self = shift ;
491 if ( defined $self->state ) {
492 _debug $self->name . ' expired'
493 if $self->{DEBUG} || _debugging ;
494
495 $self->state( undef ) ;
496 croak $self->exception if $self->exception ;
497 }
498 return undef ;
499 }
500
501
502 =item is_running
503
504 =cut
505
506
507 sub is_running {
508 my IPC::Run::Timer $self = shift ;
509 return $self->state ? 1 : 0 ;
510 }
511
512
513 =item is_reset
514
515 =cut
516
517 sub is_reset {
518 my IPC::Run::Timer $self = shift ;
519 return defined $self->state && $self->state == 0 ;
520 }
521
522
523 =item is_expired
524
525 =cut
526
527 sub is_expired {
528 my IPC::Run::Timer $self = shift ;
529 return ! defined $self->state ;
530 }
531
532 =item name
533
534 Sets/gets this timer's name. The name is only used for debugging
535 purposes so you can tell which freakin' timer is doing what.
536
537 =cut
538
539 sub name {
540 my IPC::Run::Timer $self = shift ;
541
542 $self->{NAME} = shift if @_ ;
543 return defined $self->{NAME}
544 ? $self->{NAME}
545 : defined $self->{EXCEPTION}
546 ? 'timeout'
547 : 'timer' ;
548 }
549
550
551 =item reset
552
553 reset $t ;
554 $t->reset ;
555
556 Resets the timer to the non-running, non-expired state and clears
557 the end_time().
558
559 =cut
560
561 sub reset {
562 my IPC::Run::Timer $self = shift ;
563 $self->state( 0 ) ;
564 $self->end_time( undef ) ;
565 _debug $self->name . ' reset'
566 if $self->{DEBUG} || _debugging ;
567
568 return undef ;
569 }
570
571
572 =item start
573
574 start $t ;
575 $t->start ;
576 start $t, $interval ;
577 start $t, $interval, $now ;
578
579 Starts or restarts a timer. This always sets the start_time. It sets the
580 end_time based on the interval if the timer is running or if no end time
581 has been set.
582
583 You may pass an optional interval or current time value.
584
585 Not passing a defined interval causes the previous interval setting to be
586 re-used unless the timer is reset and an end_time has been set
587 (an exception is thrown if no interval has been set).
588
589 Not passing a defined current time value causes the current time to be used.
590
591 Passing a current time value is useful if you happen to have a time value
592 lying around or if you want to make sure that several timers are started
593 with the same concept of start time. You might even need to lie to an
594 IPC::Run::Timer, occasionally.
595
596 =cut
597
598 sub start {
599 my IPC::Run::Timer $self = shift ;
600
601 my ( $interval, $now ) = map { _parse_time( $_ ) } @_ ;
602 $now = _parse_time( $now ) ;
603 $now = time unless defined $now ;
604
605 $self->interval( $interval ) if defined $interval ;
606
607 ## start()ing a running or expired timer clears the end_time, so that the
608 ## interval is used. So does specifying an interval.
609 $self->end_time( undef ) if ! $self->is_reset || $interval ;
610
611 croak "IPC::Run: no timer interval or end_time defined for " . $self->name
612 unless defined $self->interval || defined $self->end_time ;
613
614 $self->state( 1 ) ;
615 $self->start_time( $now ) ;
616 ## The "+ 1" is in case the START_TIME was sampled at the end of a
617 ## tick (which are one second long in this module).
618 $self->_calc_end_time
619 unless defined $self->end_time ;
620
621 _debug(
622 $self->name, " started at ", $self->start_time,
623 ", with interval ", $self->interval, ", end_time ", $self->end_time
624 ) if $self->{DEBUG} || _debugging ;
625 return undef ;
626 }
627
628
629 =item start_time
630
631 Sets/gets the start time, in seconds since the epoch. Setting this manually
632 is a bad idea, it's better to call L</start>() at the correct time.
633
634 =cut
635
636
637 sub start_time {
638 my IPC::Run::Timer $self = shift ;
639 if ( @_ ) {
640 $self->{START_TIME} = _parse_time( shift ) ;
641 _debug $self->name, ' start_time set to ', $self->{START_TIME}
642 if $self->{DEBUG} > 2 || _debugging ;
643 }
644
645 return $self->{START_TIME} ;
646 }
647
648
649 =item state
650
651 $s = state $t ;
652 $t->state( $s ) ;
653
654 Get/Set the current state. Only use this if you really need to transfer the
655 state to/from some variable.
656 Use L</expire>, L</start>, L</reset>, L</is_expired>, L</is_running>,
657 L</is_reset>.
658
659 Note: Setting the state to 'undef' to expire a timer will not throw an
660 exception.
661
662 =cut
663
664 sub state {
665 my IPC::Run::Timer $self = shift ;
666 if ( @_ ) {
667 $self->{STATE} = shift ;
668 _debug $self->name, ' state set to ', $self->{STATE}
669 if $self->{DEBUG} > 2 || _debugging ;
670 }
671 return $self->{STATE} ;
672 }
673
674
675 =head1 TODO
676
677 use Time::HiRes ; if it's present.
678
679 Add detection and parsing of [[[HH:]MM:]SS formatted times and intervals.
680
681 =head1 AUTHOR
682
683 Barrie Slaymaker <barries@slaysys.com>
684
685 =cut
686
687 1 ;
+481
-0
lib/IPC/Run/Win32Helper.pm less more
0 package IPC::Run::Win32Helper ;
1
2 =head1 NAME
3
4 IPC::Run::Win32Helper - helper routines for IPC::Run on Win32 platforms.
5
6 =head1 SYNOPSIS
7
8 use IPC::Run::Win32Helper; # Exports all by default
9
10 =head1 DESCRIPTION
11
12 IPC::Run needs to use sockets to redirect subprocess I/O so that the select() loop
13 will work on Win32. This seems to only work on WinNT and Win2K at this time, not
14 sure if it will ever work on Win95 or Win98. If you have experience in this area, please
15 contact me at barries@slaysys.com, thanks!.
16
17 =cut
18
19 @ISA = qw( Exporter ) ;
20
21 @EXPORT = qw(
22 win32_spawn
23 win32_parse_cmd_line
24 _dont_inherit
25 _inherit
26 ) ;
27
28 use strict ;
29 use Carp ;
30 use IO::Handle ;
31 #use IPC::Open3 ();
32 require POSIX ;
33
34 use Text::ParseWords ;
35 use Win32::Process ;
36 use IPC::Run::Debug;
37 ## REMOVE OSFHandleOpen
38 use Win32API::File qw(
39 FdGetOsFHandle
40 SetHandleInformation
41 HANDLE_FLAG_INHERIT
42 INVALID_HANDLE_VALUE
43 ) ;
44
45 ## Takes an fd or a GLOB ref, never never never a Win32 handle.
46 sub _dont_inherit {
47 for ( @_ ) {
48 next unless defined $_ ;
49 my $fd = $_ ;
50 $fd = fileno $fd if ref $fd ;
51 _debug "disabling inheritance of ", $fd if _debugging_details ;
52 my $osfh = FdGetOsFHandle $fd ;
53 croak $^E if ! defined $osfh || $osfh == INVALID_HANDLE_VALUE ;
54
55 SetHandleInformation( $osfh, HANDLE_FLAG_INHERIT, 0 ) ;
56 }
57 }
58
59 sub _inherit { #### REMOVE
60 for ( @_ ) { #### REMOVE
61 next unless defined $_ ; #### REMOVE
62 my $fd = $_ ; #### REMOVE
63 $fd = fileno $fd if ref $fd ; #### REMOVE
64 _debug "enabling inheritance of ", $fd if _debugging_details ; #### REMOVE
65 my $osfh = FdGetOsFHandle $fd ; #### REMOVE
66 croak $^E if ! defined $osfh || $osfh == INVALID_HANDLE_VALUE ; #### REMOVE
67 #### REMOVE
68 SetHandleInformation( $osfh, HANDLE_FLAG_INHERIT, 1 ) ; #### REMOVE
69 } #### REMOVE
70 } #### REMOVE
71 #### REMOVE
72 #sub _inherit {
73 # for ( @_ ) {
74 # next unless defined $_ ;
75 # my $osfh = GetOsFHandle $_ ;
76 # croak $^E if ! defined $osfh || $osfh == INVALID_HANDLE_VALUE ;
77 # SetHandleInformation( $osfh, HANDLE_FLAG_INHERIT, HANDLE_FLAG_INHERIT ) ;
78 # }
79 #}
80
81 =head1 FUNCTIONS
82
83 =over
84
85 =cut
86
87 =item optimize()
88
89 Most common incantations of C<run()> (I<not> C<harness()>, C<start()>,
90 or C<finish()>) now use temporary files to redirect input and output
91 instead of pumper processes.
92
93 Temporary files are used when sending to child processes if input is
94 taken from a scalar with no filter subroutines. This is the only time
95 we can assume that the parent is not interacting with the child's
96 redirected input as it runs.
97
98 Temporary files are used when receiving from children when output is
99 to a scalar or subroutine with or without filters, but only if
100 the child in question closes its inputs or takes input from
101 unfiltered SCALARs or named files. Normally, a child inherits its STDIN
102 from its parent; to close it, use "0<&-" or the C<noinherit => 1> option.
103 If data is sent to the child from CODE refs, filehandles or from
104 scalars through filters than the child's outputs will not be optimized
105 because C<optimize()> assumes the parent is interacting with the child.
106 It is ok if the output is filtered or handled by a subroutine, however.
107
108 This assumes that all named files are real files (as opposed to named
109 pipes) and won't change; and that a process is not communicating with
110 the child indirectly (through means not visible to IPC::Run).
111 These can be an invalid assumptions, but are the 99% case.
112 Write me if you need an option to enable or disable optimizations; I
113 suspect it will work like the C<binary()> modifier.
114
115 To detect cases that you might want to optimize by closing inputs, try
116 setting the C<IPCRUNDEBUG> environment variable to the special C<notopt>
117 value:
118
119 C:> set IPCRUNDEBUG=notopt
120 C:> my_app_that_uses_IPC_Run.pl
121
122 =item optimizer() rationalizations
123
124 Only for that limited case can we be sure that it's ok to batch all the
125 input in to a temporary file. If STDIN is from a SCALAR or from a named
126 file or filehandle (again, only in C<run()>), then outputs to CODE refs
127 are also assumed to be safe enough to batch through a temp file,
128 otherwise only outputs to SCALAR refs are batched. This can cause a bit
129 of grief if the parent process benefits from or relies on a bit of
130 "early returns" coming in before the child program exits. As long as
131 the output is redirected to a SCALAR ref, this will not be visible.
132 When output is redirected to a subroutine or (deprecated) filters, the
133 subroutine will not get any data until after the child process exits,
134 and it is likely to get bigger chunks of data at once.
135
136 The reason for the optimization is that, without it, "pumper" processes
137 are used to overcome the inconsistancies of the Win32 API. We need to
138 use anonymous pipes to connect to the child processes' stdin, stdout,
139 and stderr, yet select() does not work on these. select() only works on
140 sockets on Win32. So for each redirected child handle, there is
141 normally a "pumper" process that connects to the parent using a
142 socket--so the parent can select() on that fd--and to the child on an
143 anonymous pipe--so the child can read/write a pipe.
144
145 Using a socket to connect directly to the child (as at least one MSDN
146 article suggests) seems to cause the trailing output from most children
147 to be lost. I think this is because child processes rarely close their
148 stdout and stderr explicitly, and the winsock dll does not seem to flush
149 output when a process that uses it exits without explicitly closing
150 them.
151
152 Because of these pumpers and the inherent slowness of Win32
153 CreateProcess(), child processes with redirects are quite slow to
154 launch; so this routine looks for the very common case of
155 reading/writing to/from scalar references in a run() routine and
156 converts such reads and writes in to temporary file reads and writes.
157
158 Such files are marked as FILE_ATTRIBUTE_TEMPORARY to increase speed and
159 as FILE_FLAG_DELETE_ON_CLOSE so it will be cleaned up when the child
160 process exits (for input files). The user's default permissions are
161 used for both the temporary files and the directory that contains them,
162 hope your Win32 permissions are secure enough for you. Files are
163 created with the Win32API::File defaults of
164 FILE_SHARE_READ|FILE_SHARE_WRITE.
165
166 Setting the debug level to "details" or "gory" will give detailed
167 information about the optimization process; setting it to "basic" or
168 higher will tell whether or not a given call is optimized. Setting
169 it to "notopt" will highligh those calls that aren't optimized.
170
171 =cut
172
173 sub optimize {
174 my ( $h ) = @_;
175
176 my @kids = @{$h->{KIDS}};
177
178 my $saw_pipe;
179
180 my ( $ok_to_optimize_outputs, $veto_output_optimization );
181
182 for my $kid ( @kids ) {
183 ( $ok_to_optimize_outputs, $veto_output_optimization ) = ()
184 unless $saw_pipe;
185
186 _debug
187 "Win32 optimizer: (kid $kid->{NUM}) STDIN piped, carrying over ok of non-SCALAR output optimization"
188 if _debugging_details && $ok_to_optimize_outputs;
189 _debug
190 "Win32 optimizer: (kid $kid->{NUM}) STDIN piped, carrying over veto of non-SCALAR output optimization"
191 if _debugging_details && $veto_output_optimization;
192
193 if ( $h->{noinherit} && ! $ok_to_optimize_outputs ) {
194 _debug
195 "Win32 optimizer: (kid $kid->{NUM}) STDIN not inherited from parent oking non-SCALAR output optimization"
196 if _debugging_details && $ok_to_optimize_outputs;
197 $ok_to_optimize_outputs = 1;
198 }
199
200 for ( @{$kid->{OPS}} ) {
201 if ( substr( $_->{TYPE}, 0, 1 ) eq "<" ) {
202 if ( $_->{TYPE} eq "<" ) {
203 if ( @{$_->{FILTERS}} > 1 ) {
204 ## Can't assume that the filters are idempotent.
205 }
206 elsif ( ref $_->{SOURCE} eq "SCALAR"
207 || ref $_->{SOURCE} eq "GLOB"
208 || UNIVERSAL::isa( $_, "IO::Handle" )
209 ) {
210 if ( $_->{KFD} == 0 ) {
211 _debug
212 "Win32 optimizer: (kid $kid->{NUM}) 0$_->{TYPE}",
213 ref $_->{SOURCE},
214 ", ok to optimize outputs"
215 if _debugging_details;
216 $ok_to_optimize_outputs = 1;
217 }
218 $_->{SEND_THROUGH_TEMP_FILE} = 1;
219 next;
220 }
221 elsif ( ! ref $_->{SOURCE} && defined $_->{SOURCE} ) {
222 if ( $_->{KFD} == 0 ) {
223 _debug
224 "Win32 optimizer: (kid $kid->{NUM}) 0<$_->{SOURCE}, ok to optimize outputs",
225 if _debugging_details;
226 $ok_to_optimize_outputs = 1;
227 }
228 next;
229 }
230 }
231 _debug
232 "Win32 optimizer: (kid $kid->{NUM}) ",
233 $_->{KFD},
234 $_->{TYPE},
235 defined $_->{SOURCE}
236 ? ref $_->{SOURCE} ? ref $_->{SOURCE}
237 : $_->{SOURCE}
238 : defined $_->{FILENAME}
239 ? $_->{FILENAME}
240 : "",
241 @{$_->{FILTERS}} > 1 ? " with filters" : (),
242 ", VETOING output opt."
243 if _debugging_details || _debugging_not_optimized;
244 $veto_output_optimization = 1;
245 }
246 elsif ( $_->{TYPE} eq "close" && $_->{KFD} == 0 ) {
247 $ok_to_optimize_outputs = 1;
248 _debug "Win32 optimizer: (kid $kid->{NUM}) saw 0<&-, ok to optimize outputs"
249 if _debugging_details;
250 }
251 elsif ( $_->{TYPE} eq "dup" && $_->{KFD2} == 0 ) {
252 $veto_output_optimization = 1;
253 _debug "Win32 optimizer: (kid $kid->{NUM}) saw 0<&$_->{KFD2}, VETOING output opt."
254 if _debugging_details || _debugging_not_optimized;
255 }
256 elsif ( $_->{TYPE} eq "|" ) {
257 $saw_pipe = 1;
258 }
259 }
260
261 if ( ! $ok_to_optimize_outputs && ! $veto_output_optimization ) {
262 _debug
263 "Win32 optimizer: (kid $kid->{NUM}) child STDIN not redirected, VETOING non-SCALAR output opt."
264 if _debugging_details || _debugging_not_optimized;
265 $veto_output_optimization = 1;
266 }
267
268 if ( $ok_to_optimize_outputs && $veto_output_optimization ) {
269 $ok_to_optimize_outputs = 0;
270 _debug "Win32 optimizer: (kid $kid->{NUM}) non-SCALAR output optimizations VETOed"
271 if _debugging_details || _debugging_not_optimized;
272 }
273
274 ## SOURCE/DEST ARRAY means it's a filter.
275 ## TODO: think about checking to see if the final input/output of
276 ## a filter chain (an ARRAY SOURCE or DEST) is a scalar...but
277 ## we may be deprecating filters.
278
279 for ( @{$kid->{OPS}} ) {
280 if ( $_->{TYPE} eq ">" ) {
281 if ( ref $_->{DEST} eq "SCALAR"
282 || (
283 ( @{$_->{FILTERS}} > 1
284 || ref $_->{DEST} eq "CODE"
285 || ref $_->{DEST} eq "ARRAY" ## Filters?
286 )
287 && ( $ok_to_optimize_outputs && ! $veto_output_optimization )
288 )
289 ) {
290 $_->{RECV_THROUGH_TEMP_FILE} = 1;
291 next;
292 }
293 _debug
294 "Win32 optimizer: NOT optimizing (kid $kid->{NUM}) ",
295 $_->{KFD},
296 $_->{TYPE},
297 defined $_->{DEST}
298 ? ref $_->{DEST} ? ref $_->{DEST}
299 : $_->{SOURCE}
300 : defined $_->{FILENAME}
301 ? $_->{FILENAME}
302 : "",
303 @{$_->{FILTERS}} ? " with filters" : (),
304 if _debugging_details;
305 }
306 }
307 }
308
309 }
310
311 =item win32_parse_cmd_line
312
313 @words = win32_parse_cmd_line( q{foo bar 'baz baz' "bat bat"} ) ;
314
315 returns 4 words. This parses like the bourne shell (see
316 the bit about shellwords() in L<Text::ParseWords>), assuming we're
317 trying to be a little cross-platform here. The only difference is
318 that "\" is *not* treated as an escape except when it precedes
319 punctuation, since it's used all over the place in DOS path specs.
320
321 TODO: globbing? probably not (it's unDOSish).
322
323 TODO: shebang emulation? Probably, but perhaps that should be part
324 of Run.pm so all spawned processes get the benefit.
325
326 LIMITATIONS: shellwords dies silently on malformed input like
327
328 a\"
329
330 =cut
331
332 sub win32_parse_cmd_line {
333 my $line = shift ;
334 $line =~ s{(\\[\w\s])}{\\$1}g ;
335 return shellwords $line ;
336 }
337
338
339 =item win32_spawn
340
341 Spawns a child process, possibly with STDIN, STDOUT, and STDERR (file descriptors 0, 1, and 2, respectively) redirected.
342
343 B<LIMITATIONS>.
344
345 Cannot redirect higher file descriptors due to lack of support for this in the
346 Win32 environment.
347
348 This can be worked around by marking a handle as inheritable in the
349 parent (or leaving it marked; this is the default in perl), obtaining it's
350 Win32 handle with C<Win32API::GetOSFHandle(FH)> or
351 C<Win32API::FdGetOsFHandle($fd)> and passing it to the child using the command
352 line, the environment, or any other IPC mechanism (it's a plain old integer).
353 The child can then use C<OsFHandleOpen()> or C<OsFHandleOpenFd()> and possibly
354 C<<open FOO ">&BAR">> or C<<open FOO ">&$fd>> as need be. Ach, the pain!
355
356 Remember to check the Win32 handle against INVALID_HANDLE_VALUE.
357
358 =cut
359
360 sub _save {
361 my ( $saved, $saved_as, $fd ) = @_ ;
362
363 ## We can only save aside the original fds once.
364 return if exists $saved->{$fd} ;
365
366 my $saved_fd = IPC::Run::_dup( $fd ) ;
367 _dont_inherit $saved_fd ;
368
369 $saved->{$fd} = $saved_fd ;
370 $saved_as->{$saved_fd} = $fd ;
371
372 _dont_inherit $saved->{$fd} ;
373 }
374
375 sub _dup2_gently {
376 my ( $saved, $saved_as, $fd1, $fd2 ) = @_ ;
377 _save $saved, $saved_as, $fd2 ;
378
379 if ( exists $saved_as->{$fd2} ) {
380 ## The target fd is colliding with a saved-as fd, gotta bump
381 ## the saved-as fd to another fd.
382 my $orig_fd = delete $saved_as->{$fd2} ;
383 my $saved_fd = IPC::Run::_dup( $fd2 ) ;
384 _dont_inherit $saved_fd ;
385
386 $saved->{$orig_fd} = $saved_fd ;
387 $saved_as->{$saved_fd} = $orig_fd ;
388 }
389 _debug "moving $fd1 to kid's $fd2" if _debugging_details ;
390 IPC::Run::_dup2_rudely( $fd1, $fd2 ) ;
391 }
392
393 sub win32_spawn {
394 my ( $cmd, $ops) = @_ ;
395
396 ## NOTE: The debug pipe write handle is passed to pump processes as STDOUT.
397 ## and is not to the "real" child process, since they would not know
398 ## what to do with it...unlike Unix, we have no code executing in the
399 ## child before the "real" child is exec()ed.
400
401 my %saved ; ## Map of parent's orig fd -> saved fd
402 my %saved_as ; ## Map of parent's saved fd -> orig fd, used to
403 ## detect collisions between a KFD and the fd a
404 ## parent's fd happened to be saved to.
405
406 for my $op ( @$ops ) {
407 _dont_inherit $op->{FD} if defined $op->{FD} ;
408
409 if ( defined $op->{KFD} && $op->{KFD} > 2 ) {
410 ## TODO: Detect this in harness()
411 ## TODO: enable temporary redirections if ever necessary, not
412 ## sure why they would be...
413 ## 4>&1 1>/dev/null 1>&4 4>&-
414 croak "Can't redirect fd #", $op->{KFD}, " on Win32" ;
415 }
416
417 ## This is very similar logic to IPC::Run::_do_kid_and_exit().
418 if ( defined $op->{TFD} ) {
419 unless ( $op->{TFD} == $op->{KFD} ) {
420 _dup2_gently \%saved, \%saved_as, $op->{TFD}, $op->{KFD} ;
421 _dont_inherit $op->{TFD} ;
422 }
423 }
424 elsif ( $op->{TYPE} eq "dup" ) {
425 _dup2_gently \%saved, \%saved_as, $op->{KFD1}, $op->{KFD2}
426 unless $op->{KFD1} == $op->{KFD2} ;
427 }
428 elsif ( $op->{TYPE} eq "close" ) {
429 _save \%saved, \%saved_as, $op->{KFD} ;
430 IPC::Run::_close( $op->{KFD} ) ;
431 }
432 elsif ( $op->{TYPE} eq "init" ) {
433 ## TODO: detect this in harness()
434 croak "init subs not allowed on Win32" ;
435 }
436 }
437
438 my $process ;
439 my $cmd_line = join " ", map {
440 ( my $s = $_ ) =~ s/"/"""/g;
441 $s = qq{"$s"} if /["\s]/;
442 $s ;
443 } @$cmd ;
444
445 _debug "cmd line: ", $cmd_line
446 if _debugging;
447
448 Win32::Process::Create(
449 $process,
450 $cmd->[0],
451 $cmd_line,
452 1, ## Inherit handles
453 NORMAL_PRIORITY_CLASS,
454 ".",
455 ) or croak "$!: Win32::Process::Create()" ;
456
457 for my $orig_fd ( keys %saved ) {
458 IPC::Run::_dup2_rudely( $saved{$orig_fd}, $orig_fd ) ;
459 IPC::Run::_close( $saved{$orig_fd} ) ;
460 }
461
462 return ( $process->GetProcessID(), $process ) ;
463 }
464
465
466 =back
467
468 =head1 AUTHOR
469
470 Barries Slaymaker <barries@slaysys.com>. Funded by Perforce Software, Inc.
471
472 =head1 COPYRIGHT
473
474 Copyright 2001, Barrie Slaymaker, All Rights Reserved.
475
476 You may use this under the terms of either the GPL 2.0 ir the Artistic License.
477
478 =cut
479
480 1 ;
+556
-0
lib/IPC/Run/Win32IO.pm less more
0 package IPC::Run::Win32IO;
1
2 =head1 NAME
3
4 IPC::Run::Win32IO - helper routines for IPC::Run on Win32 platforms.
5
6 =head1 SYNOPSIS
7
8 use IPC::Run::Win32IO; # Exports all by default
9
10 =head1 DESCRIPTION
11
12 IPC::Run needs to use sockets to redirect subprocess I/O so that the select()
13 loop will work on Win32. This seems to only work on WinNT and Win2K at this
14 time, not sure if it will ever work on Win95 or Win98. If you have experience
15 in this area, please contact me at barries@slaysys.com, thanks!.
16
17 =cut
18
19 =head1 DESCRIPTION
20
21 A specialized IO class used on Win32.
22
23 =cut
24
25 use strict ;
26 use Carp ;
27 use IO::Handle ;
28 use Socket ;
29 require POSIX ;
30
31 use Socket qw( IPPROTO_TCP TCP_NODELAY ) ;
32 use Symbol ;
33 use Text::ParseWords ;
34 use Win32::Process ;
35 use IPC::Run::Debug qw( :default _debugging_level );
36 use IPC::Run::Win32Helper qw( _inherit _dont_inherit );
37 use Fcntl qw( O_TEXT O_RDONLY );
38
39 use base qw( IPC::Run::IO );
40 my @cleanup_fields;
41 BEGIN {
42 ## These fields will be set to undef in _cleanup to close
43 ## the handles.
44 @cleanup_fields = (
45 'SEND_THROUGH_TEMP_FILE', ## Set by WinHelper::optimize()
46 'RECV_THROUGH_TEMP_FILE', ## Set by WinHelper::optimize()
47 'TEMP_FILE_NAME', ## The name of the temp file, needed for
48 ## error reporting / debugging only.
49
50 'PARENT_HANDLE', ## The handle of the socket for the parent
51 'PUMP_SOCKET_HANDLE', ## The socket handle for the pump
52 'PUMP_PIPE_HANDLE', ## The anon pipe handle for the pump
53 'CHILD_HANDLE', ## The anon pipe handle for the child
54
55 'TEMP_FILE_HANDLE', ## The Win32 filehandle for the temp file
56 );
57 }
58
59 ## REMOVE OSFHandleOpen
60 use Win32API::File qw(
61 GetOsFHandle
62 OsFHandleOpenFd
63 OsFHandleOpen
64 FdGetOsFHandle
65 SetHandleInformation
66 SetFilePointer
67 HANDLE_FLAG_INHERIT
68 INVALID_HANDLE_VALUE
69
70 createFile
71 WriteFile
72 ReadFile
73 CloseHandle
74
75 FILE_ATTRIBUTE_TEMPORARY
76 FILE_FLAG_DELETE_ON_CLOSE
77 FILE_FLAG_WRITE_THROUGH
78
79 FILE_BEGIN
80 ) ;
81
82 # FILE_ATTRIBUTE_HIDDEN
83 # FILE_ATTRIBUTE_SYSTEM
84
85
86 BEGIN {
87 ## Force AUTOLOADED constants to be, well, constant by getting them
88 ## to AUTOLOAD before compilation continues. Sigh.
89 () = (
90 SOL_SOCKET,
91 SO_REUSEADDR,
92 IPPROTO_TCP,
93 TCP_NODELAY,
94 HANDLE_FLAG_INHERIT,
95 INVALID_HANDLE_VALUE,
96 );
97 }
98
99
100 use constant temp_file_flags => (
101 FILE_ATTRIBUTE_TEMPORARY() |
102 FILE_FLAG_DELETE_ON_CLOSE() |
103 FILE_FLAG_WRITE_THROUGH()
104 );
105
106 # FILE_ATTRIBUTE_HIDDEN() |
107 # FILE_ATTRIBUTE_SYSTEM() |
108 my $tmp_file_counter;
109 my $tmp_dir;
110
111 sub _cleanup {
112 my IPC::Run::Win32IO $self = shift;
113 my ( $harness ) = @_;
114
115 $self->_recv_through_temp_file( $harness )
116 if $self->{RECV_THROUGH_TEMP_FILE};
117
118 CloseHandle( $self->{TEMP_FILE_HANDLE} )
119 if defined $self->{TEMP_FILE_HANDLE};
120
121 $self->{$_} = undef for @cleanup_fields;
122 }
123
124
125 sub _create_temp_file {
126 my IPC::Run::Win32IO $self = shift;
127
128 ## Create a hidden temp file that Win32 will delete when we close
129 ## it.
130 unless ( defined $tmp_dir ) {
131 $tmp_dir = File::Spec->catdir(
132 File::Spec->tmpdir, "IPC-Run.tmp"
133 );
134
135 ## Trust in the user's umask.
136 ## This could possibly be a security hole, perhaps
137 ## we should offer an option. Hmmmm, really, people coding
138 ## security conscious apps should audit this code and
139 ## tell me how to make it better. Nice cop-out :).
140 unless ( -d $tmp_dir ) {
141 mkdir $tmp_dir or croak "$!: $tmp_dir";
142 }
143 }
144
145 $self->{TEMP_FILE_NAME} = File::Spec->catfile(
146 ## File name is designed for easy sorting and not conflicting
147 ## with other processes. This should allow us to use "t"runcate
148 ## access in CreateFile in case something left some droppings
149 ## around (which should never happen because we specify
150 ## FLAG_DELETE_ON_CLOSE.
151 ## heh, belt and suspenders are better than bug reports; God forbid
152 ## that NT should ever crash before a temp file gets deleted!
153 $tmp_dir, sprintf "Win32io-%06d-%08d", $$, $tmp_file_counter++
154 );
155
156 $self->{TEMP_FILE_HANDLE} = createFile(
157 $self->{TEMP_FILE_NAME},
158 "trw", ## new, truncate, read, write
159 {
160 Flags => temp_file_flags,
161 },
162 ) or croak "Can't create temporary file, $self->{TEMP_FILE_NAME}: $^E";
163
164 $self->{TFD} = OsFHandleOpenFd $self->{TEMP_FILE_HANDLE}, 0;
165 $self->{FD} = undef;
166
167 _debug
168 "Win32 Optimizer: temp file (",
169 $self->{KFD},
170 $self->{TYPE},
171 $self->{TFD},
172 ", fh ",
173 $self->{TEMP_FILE_HANDLE},
174 "): ",
175 $self->{TEMP_FILE_NAME}
176 if _debugging_details;
177 }
178
179
180 sub _reset_temp_file_pointer {
181 my $self = shift;
182 SetFilePointer( $self->{TEMP_FILE_HANDLE}, 0, 0, FILE_BEGIN )
183 or confess "$^E seeking on (fd $self->{TFD}) $self->{TEMP_FILE_NAME} for kid's fd $self->{KFD}";
184 }
185
186
187 sub _send_through_temp_file {
188 my IPC::Run::Win32IO $self = shift;
189
190 _debug
191 "Win32 optimizer: optimizing "
192 . " $self->{KFD} $self->{TYPE} temp file instead of ",
193 ref $self->{SOURCE} || $self->{SOURCE}
194 if _debugging_details;
195
196 $self->_create_temp_file;
197
198 if ( defined ${$self->{SOURCE}} ) {
199 my $bytes_written = 0;
200 my $data_ref;
201 if ( $self->binmode ) {
202 $data_ref = $self->{SOURCE};
203 }
204 else {
205 my $data = ${$self->{SOURCE}}; # Ugh, a copy.
206 $data =~ s/(?<!\r)\n/\r\n/g;
207 $data_ref = \$data;
208 }
209
210 WriteFile(
211 $self->{TEMP_FILE_HANDLE},
212 $$data_ref,
213 0, ## Write entire buffer
214 $bytes_written,
215 [], ## Not overlapped.
216 ) or croak
217 "$^E writing $self->{TEMP_FILE_NAME} for kid to read on fd $self->{KFD}";
218 _debug
219 "Win32 optimizer: wrote $bytes_written to temp file $self->{TEMP_FILE_NAME}"
220 if _debugging_data;
221
222 $self->_reset_temp_file_pointer;
223
224 }
225
226
227 _debug "Win32 optimizer: kid to read $self->{KFD} from temp file on $self->{TFD}"
228 if _debugging_details;
229 }
230
231
232 sub _init_recv_through_temp_file {
233 my IPC::Run::Win32IO $self = shift;
234
235 $self->_create_temp_file;
236 }
237
238
239 ## TODO: USe the Win32 API in the select loop to see if the file has grown
240 ## and read it incrementally if it has.
241 sub _recv_through_temp_file {
242 my IPC::Run::Win32IO $self = shift;
243
244 ## This next line kicks in if the run() never got to initting things
245 ## and needs to clean up.
246 return undef unless defined $self->{TEMP_FILE_HANDLE};
247
248 push @{$self->{FILTERS}}, sub {
249 my ( undef, $out_ref ) = @_;
250
251 return undef unless defined $self->{TEMP_FILE_HANDLE};
252
253 my $r;
254 my $s;
255 ReadFile(
256 $self->{TEMP_FILE_HANDLE},
257 $s,
258 999_999, ## Hmmm, should read the size.
259 $r,
260 []
261 ) or croak "$^E reading from $self->{TEMP_FILE_NAME}";
262
263 _debug "ReadFile( $self->{TFD} ) = $r chars '$s'" if _debugging_data ;
264
265 return undef unless $r;
266
267 $s =~ s/\r\n/\n/g unless $self->binmode;
268
269 my $pos = pos $$out_ref;
270 $$out_ref .= $s;
271 pos( $out_ref ) = $pos;
272 return 1;
273 };
274
275 my ( $harness ) = @_;
276
277 $self->_reset_temp_file_pointer;
278
279 1 while $self->_do_filters( $harness );
280
281 pop @{$self->{FILTERS}};
282
283 IPC::Run::_close( $self->{TFD} );
284 }
285
286
287 sub poll {
288 my IPC::Run::Win32IO $self = shift;
289
290 return if $self->{SEND_THROUGH_TEMP_FILE} || $self->{RECV_THROUGH_TEMP_FILE};
291
292 return $self->SUPER::poll( @_ );
293 }
294
295
296 ## When threaded Perls get good enough, we should use threads here.
297 ## The problem with threaded perls is that they dup() all sorts of
298 ## filehandles and fds and don't allow sufficient control over
299 ## closing off the ones we don't want.
300
301 sub _spawn_pumper {
302 my ( $stdin, $stdout, $debug_fd, $binmode, $child_label, @opts ) = @_ ;
303 my ( $stdin_fd, $stdout_fd ) = ( fileno $stdin, fileno $stdout ) ;
304
305 _debug "pumper stdin = ", $stdin_fd if _debugging_details;
306 _debug "pumper stdout = ", $stdout_fd if _debugging_details;
307 _inherit $stdin_fd, $stdout_fd, $debug_fd ;
308 my @I_options = map qq{"-I$_"}, @INC;
309
310 my $cmd_line = join( " ",
311 qq{"$^X"},
312 @I_options,
313 qw(-MIPC::Run::Win32Pump -e 1 ),
314 ## I'm using this clunky way of passing filehandles to the child process
315 ## in order to avoid some kind of premature closure of filehandles
316 ## problem I was having with VCP's test suite when passing them
317 ## via CreateProcess. All of the ## REMOVE code is stuff I'd like
318 ## to be rid of and the ## ADD code is what I'd like to use.
319 FdGetOsFHandle( $stdin_fd ), ## REMOVE
320 FdGetOsFHandle( $stdout_fd ), ## REMOVE
321 FdGetOsFHandle( $debug_fd ), ## REMOVE
322 $binmode ? 1 : 0,
323 $$, $^T, _debugging_level, qq{"$child_label"},
324 @opts
325 ) ;
326
327 # open SAVEIN, "<&STDIN" or croak "$! saving STDIN" ; #### ADD
328 # open SAVEOUT, ">&STDOUT" or croak "$! saving STDOUT" ; #### ADD
329 # open SAVEERR, ">&STDERR" or croak "$! saving STDERR" ; #### ADD
330 # _dont_inherit \*SAVEIN ; #### ADD
331 # _dont_inherit \*SAVEOUT ; #### ADD
332 # _dont_inherit \*SAVEERR ; #### ADD
333 # open STDIN, "<&$stdin_fd" or croak "$! dup2()ing $stdin_fd (pumper's STDIN)" ; #### ADD
334 # open STDOUT, ">&$stdout_fd" or croak "$! dup2()ing $stdout_fd (pumper's STDOUT)" ; #### ADD
335 # open STDERR, ">&$debug_fd" or croak "$! dup2()ing $debug_fd (pumper's STDERR/debug_fd)" ; #### ADD
336
337 _debug "pump cmd line: ", $cmd_line if _debugging_details;
338
339 my $process ;
340 Win32::Process::Create(
341 $process,
342 $^X,
343 $cmd_line,
344 1, ## Inherit handles
345 NORMAL_PRIORITY_CLASS,
346 ".",
347 ) or croak "$!: Win32::Process::Create()" ;
348
349 # open STDIN, "<&SAVEIN" or croak "$! restoring STDIN" ; #### ADD
350 # open STDOUT, ">&SAVEOUT" or croak "$! restoring STDOUT" ; #### ADD
351 # open STDERR, ">&SAVEERR" or croak "$! restoring STDERR" ; #### ADD
352 # close SAVEIN or croak "$! closing SAVEIN" ; #### ADD
353 # close SAVEOUT or croak "$! closing SAVEOUT" ; #### ADD
354 # close SAVEERR or croak "$! closing SAVEERR" ; #### ADD
355
356 close $stdin or croak "$! closing pumper's stdin in parent" ;
357 close $stdout or croak "$! closing pumper's stdout in parent" ;
358 # Don't close $debug_fd, we need it, as do other pumpers.
359
360 # Pause a moment to allow the child to get up and running and emit
361 # debug messages. This does not always work.
362 # select undef, undef, undef, 1 if _debugging_details ;
363
364 _debug "_spawn_pumper pid = ", $process->GetProcessID
365 if _debugging_data;
366 }
367
368
369 my $next_port = 2048 ;
370 my $loopback = inet_aton "127.0.0.1" ;
371 my $tcp_proto = getprotobyname('tcp');
372 croak "$!: getprotobyname('tcp')" unless defined $tcp_proto ;
373
374 sub _socket {
375 my ( $server ) = @_ ;
376 $server ||= gensym ;
377 my $client = gensym ;
378
379 my $listener = gensym ;
380 socket $listener, PF_INET, SOCK_STREAM, $tcp_proto
381 or croak "$!: socket()";
382 setsockopt $listener, SOL_SOCKET, SO_REUSEADDR, pack("l", 0)
383 or croak "$!: setsockopt()";
384
385 my $port ;
386 my @errors ;
387 PORT_FINDER_LOOP:
388 {
389 $port = $next_port ;
390 $next_port = 2048 if ++$next_port > 65_535 ;
391 unless ( bind $listener, sockaddr_in( $port, INADDR_ANY ) ) {
392 push @errors, "$! on port $port" ;
393 croak join "\n", @errors if @errors > 10 ;
394 goto PORT_FINDER_LOOP;
395 }
396 }
397
398 _debug "win32 port = $port" if _debugging_details;
399
400 listen $listener, my $queue_size = 1
401 or croak "$!: listen()" ;
402
403 {
404 socket $client, PF_INET, SOCK_STREAM, $tcp_proto
405 or croak "$!: socket()";
406
407 my $paddr = sockaddr_in($port, $loopback );
408
409 connect $client, $paddr
410 or croak "$!: connect()" ;
411
412 croak "$!: accept" unless defined $paddr ;
413
414 ## The windows "default" is SO_DONTLINGER, which should make
415 ## sure all socket data goes through. I have my doubts based
416 ## on experimentation, but nothing prompts me to set SO_LINGER
417 ## at this time...
418 setsockopt $client, IPPROTO_TCP, TCP_NODELAY, pack("l", 0)
419 or croak "$!: setsockopt()";
420 }
421
422 {
423 _debug "accept()ing on port $port" if _debugging_details;
424 my $paddr = accept( $server, $listener ) ;
425 croak "$!: accept()" unless defined $paddr ;
426 }
427
428 _debug
429 "win32 _socket = ( ", fileno $server, ", ", fileno $client, " ) on port $port"
430 if _debugging_details;
431 return ( $server, $client ) ;
432 }
433
434
435 sub _open_socket_pipe {
436 my IPC::Run::Win32IO $self = shift;
437 my ( $debug_fd, $parent_handle ) = @_ ;
438
439 my $is_send_to_child = $self->dir eq "<";
440
441 $self->{CHILD_HANDLE} = gensym;
442 $self->{PUMP_PIPE_HANDLE} = gensym;
443
444 (
445 $self->{PARENT_HANDLE},
446 $self->{PUMP_SOCKET_HANDLE}
447 ) = _socket $parent_handle ;
448
449 ## These binmodes seem to have no effect on Win2K, but just to be safe
450 ## I do them.
451 binmode $self->{PARENT_HANDLE} or die $!;
452 binmode $self->{PUMP_SOCKET_HANDLE} or die $!;
453
454 _debug "PUMP_SOCKET_HANDLE = ", fileno $self->{PUMP_SOCKET_HANDLE}
455 if _debugging_details;
456 ##my $buf ;
457 ##$buf = "write on child end of " . fileno( $self->{WRITE_HANDLE} ) . "\n\n\n\n\n" ;
458 ##POSIX::write(fileno $self->{WRITE_HANDLE}, $buf, length $buf) or warn "$! in syswrite" ;
459 ##$buf = "write on parent end of " . fileno( $self->{CHILD_HANDLE} ) . "\r\n" ;
460 ##POSIX::write(fileno $self->{CHILD_HANDLE},$buf, length $buf) or warn "$! in syswrite" ;
461 ## $self->{CHILD_HANDLE}->autoflush( 1 ) ;
462 ## $self->{WRITE_HANDLE}->autoflush( 1 ) ;
463
464 ## Now fork off a data pump and arrange to return the correct fds.
465 if ( $is_send_to_child ) {
466 pipe $self->{CHILD_HANDLE}, $self->{PUMP_PIPE_HANDLE}
467 or croak "$! opening child pipe" ;
468 _debug "CHILD_HANDLE = ", fileno $self->{CHILD_HANDLE}
469 if _debugging_details;
470 _debug "PUMP_PIPE_HANDLE = ", fileno $self->{PUMP_PIPE_HANDLE}
471 if _debugging_details;
472 }
473 else {
474 pipe $self->{PUMP_PIPE_HANDLE}, $self->{CHILD_HANDLE}
475 or croak "$! opening child pipe" ;
476 _debug "CHILD_HANDLE = ", fileno $self->{CHILD_HANDLE}
477 if _debugging_details;
478 _debug "PUMP_PIPE_HANDLE = ", fileno $self->{PUMP_PIPE_HANDLE}
479 if _debugging_details;
480 }
481
482 ## These binmodes seem to have no effect on Win2K, but just to be safe
483 ## I do them.
484 binmode $self->{CHILD_HANDLE};
485 binmode $self->{PUMP_PIPE_HANDLE};
486
487 ## No child should ever see this.
488 _dont_inherit $self->{PARENT_HANDLE} ;
489
490 ## We clear the inherit flag so these file descriptors are not inherited.
491 ## It'll be dup()ed on to STDIN/STDOUT/STDERR before CreateProcess is
492 ## called and *that* fd will be inheritable.
493 _dont_inherit $self->{PUMP_SOCKET_HANDLE} ;
494 _dont_inherit $self->{PUMP_PIPE_HANDLE} ;
495 _dont_inherit $self->{CHILD_HANDLE} ;
496
497 ## Need to return $self so the HANDLEs don't get freed.
498 ## Return $self, $parent_fd, $child_fd
499 my ( $parent_fd, $child_fd ) = (
500 fileno $self->{PARENT_HANDLE},
501 fileno $self->{CHILD_HANDLE}
502 ) ;
503
504 ## Both PUMP_..._HANDLEs will be closed, no need to worry about
505 ## inheritance.
506 _debug "binmode on" if _debugging_data && $self->binmode;
507 _spawn_pumper(
508 $is_send_to_child
509 ? ( $self->{PUMP_SOCKET_HANDLE}, $self->{PUMP_PIPE_HANDLE} )
510 : ( $self->{PUMP_PIPE_HANDLE}, $self->{PUMP_SOCKET_HANDLE} ),
511 $debug_fd,
512 $self->binmode,
513 $child_fd . $self->dir . "pump" . $self->dir . $parent_fd,
514 ) ;
515
516 {
517 my $foo ;
518 confess "PARENT_HANDLE no longer open"
519 unless POSIX::read( $parent_fd, $foo, 0 ) ;
520 }
521
522 _debug "win32_fake_pipe = ( $parent_fd, $child_fd )"
523 if _debugging_details;
524
525 $self->{FD} = $parent_fd;
526 $self->{TFD} = $child_fd;
527 }
528
529 sub _do_open {
530 my IPC::Run::Win32IO $self = shift;
531
532 if ( $self->{SEND_THROUGH_TEMP_FILE} ) {
533 return $self->_send_through_temp_file( @_ );
534 }
535 elsif ( $self->{RECV_THROUGH_TEMP_FILE} ) {
536 return $self->_init_recv_through_temp_file( @_ );
537 }
538 else {
539 return $self->_open_socket_pipe( @_ );
540 }
541 }
542
543 =head1 AUTHOR
544
545 Barries Slaymaker <barries@slaysys.com>. Funded by Perforce Software, Inc.
546
547 =head1 COPYRIGHT
548
549 Copyright 2001, Barrie Slaymaker, All Rights Reserved.
550
551 You may use this under the terms of either the GPL 2.0 ir the Artistic License.
552
553 =cut
554
555 1;
+162
-0
lib/IPC/Run/Win32Pump.pm less more
0 package IPC::Run::Win32Pump;
1
2 =head1 NAME
3
4 IPC::Run::Win32Pump - helper processes to shovel data to/from parent, child
5
6 =head1 SYNOPSIS
7
8 Internal use only; see IPC::Run::Win32IO and best of luck to you.
9
10 =head1 DESCRIPTION
11
12 See L<IPC::Run::Win32Helper|IPC::Run::Win32Helper> for details. This
13 module is used in subprocesses that are spawned to shovel data to/from
14 parent processes from/to their child processes. Where possible, pumps
15 are optimized away.
16
17 NOTE: This is not a real module: it's a script in module form, designed
18 to be run like
19
20 $^X -MIPC::Run::Win32Pumper -e 1 ...
21
22 It parses a bunch of command line parameters from IPC::Run::Win32IO.
23
24 =cut
25
26 use strict ;
27
28 use Win32API::File qw(
29 OsFHandleOpen
30 ) ;
31
32
33 my ( $stdin_fh, $stdout_fh, $debug_fh, $binmode, $parent_pid, $parent_start_time, $debug, $child_label );
34 BEGIN {
35 ( $stdin_fh, $stdout_fh, $debug_fh, $binmode, $parent_pid, $parent_start_time, $debug, $child_label ) = @ARGV ;
36 ## Rather than letting IPC::Run::Debug export all-0 constants
37 ## when not debugging, we do it manually in order to not even
38 ## load IPC::Run::Debug.
39 if ( $debug ) {
40 eval "use IPC::Run::Debug qw( :default _debug_init ); 1;"
41 or die $@;
42 }
43 else {
44 eval <<STUBS_END or die $@;
45 sub _debug {}
46 sub _debug_init {}
47 sub _debugging() { 0 }
48 sub _debugging_data() { 0 }
49 sub _debugging_details() { 0 }
50 sub _debugging_gory_details() { 0 }
51 1;
52 STUBS_END
53 }
54 }
55
56 ## For some reason these get created with binmode on. AAargh, gotta #### REMOVE
57 ## do it by hand below. #### REMOVE
58 if ( $debug ) { #### REMOVE
59 close STDERR; #### REMOVE
60 OsFHandleOpen( \*STDERR, $debug_fh, "w" ) #### REMOVE
61 or print "$! opening STDERR as Win32 handle $debug_fh in pumper $$" ; #### REMOVE
62 } #### REMOVE
63 close STDIN; #### REMOVE
64 OsFHandleOpen( \*STDIN, $stdin_fh, "r" ) #### REMOVE
65 or die "$! opening STDIN as Win32 handle $stdin_fh in pumper $$" ; #### REMOVE
66 close STDOUT; #### REMOVE
67 OsFHandleOpen( \*STDOUT, $stdout_fh, "w" ) #### REMOVE
68 or die "$! opening STDOUT as Win32 handle $stdout_fh in pumper $$" ; #### REMOVE
69
70 binmode STDIN;
71 binmode STDOUT;
72 $| = 1 ;
73 select STDERR ; $| = 1 ; select STDOUT ;
74
75 $child_label ||= "pump" ;
76 _debug_init(
77 $parent_pid,
78 $parent_start_time,
79 $debug,
80 fileno STDERR,
81 $child_label,
82 ) ;
83
84 _debug "Entered" if _debugging_details ;
85
86 # No need to close all fds; win32 doesn't seem to pass any on to us.
87 $| = 1 ;
88 my $buf ;
89 my $total_count = 0 ;
90 while (1) {
91 my $count = sysread STDIN, $buf, 10_000 ;
92 last unless $count ;
93 if ( _debugging_gory_details ) {
94 my $msg = "'$buf'" ;
95 substr( $msg, 100, -1 ) = '...' if length $msg > 100 ;
96 $msg =~ s/\n/\\n/g ;
97 $msg =~ s/\r/\\r/g ;
98 $msg =~ s/\t/\\t/g ;
99 $msg =~ s/([\000-\037\177-\277])/sprintf "\0x%02x", ord $1/eg ;
100 _debug sprintf( "%5d chars revc: ", $count ), $msg ;
101 }
102 $total_count += $count ;
103 $buf =~ s/\r//g unless $binmode;
104 if ( _debugging_gory_details ) {
105 my $msg = "'$buf'" ;
106 substr( $msg, 100, -1 ) = '...' if length $msg > 100 ;
107 $msg =~ s/\n/\\n/g ;
108 $msg =~ s/\r/\\r/g ;
109 $msg =~ s/\t/\\t/g ;
110 $msg =~ s/([\000-\037\177-\277])/sprintf "\0x%02x", ord $1/eg ;
111 _debug sprintf( "%5d chars sent: ", $count ), $msg ;
112 }
113 print $buf ;
114 }
115
116 _debug "Exiting, transferred $total_count chars" if _debugging_details ;
117
118 ## Perform a graceful socket shutdown. Windows defaults to SO_DONTLINGER,
119 ## which should cause a "graceful shutdown in the background" on sockets.
120 ## but that's only true if the process closes the socket manually, it
121 ## seems; if the process exits and lets the OS clean up, the OS is not
122 ## so kind. STDOUT is not always a socket, of course, but it won't hurt
123 ## to close a pipe and may even help. With a closed source OS, who
124 ## can tell?
125 ##
126 ## In any case, this close() is one of the main reasons we have helper
127 ## processes; if the OS closed socket fds gracefully when an app exits,
128 ## we'd just redirect the client directly to what is now the pump end
129 ## of the socket. As it is, however, we need to let the client play with
130 ## pipes, which don't have the abort-on-app-exit behavior, and then
131 ## adapt to the sockets in the helper processes to allow the parent to
132 ## select.
133 ##
134 ## Possible alternatives / improvements:
135 ##
136 ## 1) use helper threads instead of processes. I don't trust perl's threads
137 ## as of 5.005 or 5.6 enough (which may be myopic of me).
138 ##
139 ## 2) figure out if/how to get at WaitForMultipleObjects() with pipe
140 ## handles. May be able to take the Win32 handle and pass it to
141 ## Win32::Event::wait_any, dunno.
142 ##
143 ## 3) Use Inline::C or a hand-tooled XS module to do helper threads.
144 ## This would be faster than #1, but would require a ppm distro.
145 ##
146 close STDOUT ;
147 close STDERR ;
148
149 =head1 AUTHOR
150
151 Barries Slaymaker <barries@slaysys.com>. Funded by Perforce Software, Inc.
152
153 =head1 COPYRIGHT
154
155 Copyright 2001, Barrie Slaymaker, All Rights Reserved.
156
157 You may use this under the terms of either the GPL 2.0 ir the Artistic License.
158
159 =cut
160
161 1 ;
+4476
-0
lib/IPC/Run.pm less more
0 package IPC::Run ;
1 #
2 # Copyright (c) 1999 by Barrie Slaymaker, barries@slaysys.com
3 #
4 # You may distribute under the terms of either the GNU General Public
5 # License or the Artistic License, as specified in the README file.
6 #
7
8 $VERSION = "0.80";
9
10 =head1 NAME
11
12 IPC::Run - system() and background procs w/ piping, redirs, ptys (Unix, Win32)
13
14 =head1 SYNOPSIS
15
16 ## First,a command to run:
17 my @cat = qw( cat ) ;
18
19 ## Using run() instead of system():
20 use IPC::Run qw( run timeout ) ;
21
22 run \@cmd, \$in, \$out, \$err, timeout( 10 ) or die "cat: $?"
23
24 # Can do I/O to sub refs and filenames, too:
25 run \@cmd, '<', "in.txt", \&out, \&err or die "cat: $?"
26 run \@cat, '<', "in.txt", '>>', "out.txt", '2>>', "err.txt" ;
27
28
29 # Redirecting using psuedo-terminals instad of pipes.
30 run \@cat, '<pty<', \$in, '>pty>', \$out_and_err ;
31
32 ## Scripting subprocesses (like Expect):
33
34 use IPC::Run qw( start pump finish timeout ) ;
35
36 # Incrementally read from / write to scalars.
37 # $in is drained as it is fed to cat's stdin,
38 # $out accumulates cat's stdout
39 # $err accumulates cat's stderr
40 # $h is for "harness".
41 my $h = start \@cat, \$in, \$out, \$err, timeout( 10 ) ;
42
43 $in .= "some input\n" ;
44 pump $h until $out =~ /input\n/g ;
45
46 $in .= "some more input\n" ;
47 pump $h until $out =~ /\G.*more input\n/ ;
48
49 $in .= "some final input\n" ;
50 finish $h or die "cat returned $?" ;
51
52 warn $err if $err ;
53 print $out ; ## All of cat's output
54
55 # Piping between children
56 run \@cat, '|', \@gzip ;
57
58 # Multiple children simultaneously (run() blocks until all
59 # children exit, use start() for background execution):
60 run \@foo1, '&', \@foo2 ;
61
62 # Calling \&set_up_child in the child before it executes the
63 # command (only works on systems with true fork() & exec())
64 # exceptions thrown in set_up_child() will be propagated back
65 # to the parent and thrown from run().
66 run \@cat, \$in, \$out,
67 init => \&set_up_child ;
68
69 # Read from / write to file handles you open and close
70 open IN, '<in.txt' or die $! ;
71 open OUT, '>out.txt' or die $! ;
72 print OUT "preamble\n" ;
73 run \@cat, \*IN, \*OUT or die "cat returned $?" ;
74 print OUT "postamble\n" ;
75 close IN ;
76 close OUT ;
77
78 # Create pipes for you to read / write (like IPC::Open2 & 3).
79 $h = start
80 \@cat,
81 '<pipe', \*IN,
82 '>pipe', \*OUT,
83 '2>pipe', \*ERR
84 or die "cat returned $?" ;
85 print IN "some input\n" ;
86 close IN ;
87 print <OUT>, <ERR> ;
88 finish $h ;
89
90 # Mixing input and output modes
91 run \@cat, 'in.txt', \&catch_some_out, \*ERR_LOG ) ;
92
93 # Other redirection constructs
94 run \@cat, '>&', \$out_and_err ;
95 run \@cat, '2>&1' ;
96 run \@cat, '0<&3' ;
97 run \@cat, '<&-' ;
98 run \@cat, '3<', \$in3 ;
99 run \@cat, '4>', \$out4 ;
100 # etc.
101
102 # Passing options:
103 run \@cat, 'in.txt', debug => 1 ;
104
105 # Call this system's shell, returns TRUE on 0 exit code
106 # THIS IS THE OPPOSITE SENSE OF system()'s RETURN VALUE
107 run "cat a b c" or die "cat returned $?" ;
108
109 # Launch a sub process directly, no shell. Can't do redirection
110 # with this form, it's here to behave like system() with an
111 # inverted result.
112 $r = run "cat a b c" ;
113
114 # Read from a file in to a scalar
115 run io( "filename", 'r', \$recv ) ;
116 run io( \*HANDLE, 'r', \$recv ) ;
117
118 =head1 DESCRIPTION
119
120 IPC::Run allows you run and interact with child processes using files, pipes,
121 and pseudo-ttys. Both system()-style and scripted usages are supported and
122 may be mixed. Likewise, functional and OO API styles are both supported and
123 may be mixed.
124
125 Various redirection operators reminiscent of those seen on common Unix and DOS
126 command lines are provided.
127
128 Before digging in to the details a few LIMITATIONS are important enough
129 to be mentioned right up front:
130
131 =over
132
133 =item Win32 Support
134
135 Win32 support is working but B<EXPERIMENTAL>, but does pass all relevant tests
136 on NT 4.0. See L</Win32 LIMITATIONS>.
137
138 =item pty Support
139
140 If you need pty support, IPC::Run should work well enough most of the
141 time, but IO::Pty is being improved, and IPC::Run will be improved to
142 use IO::Pty's new features when it is release.
143
144 The basic problem is that the pty needs to initialize itself before the
145 parent writes to the master pty, or the data written gets lost. So
146 IPC::Run does a sleep(1) in the parent after forking to (hopefully) give
147 the child a chance to run. This is a kludge that works well on non
148 heavily loaded systems :(.
149
150 ptys are not supported yet under Win32, but will be emulated...
151
152 =item Debugging Tip
153
154 You may use the environment variable C<IPCRUNDEBUG> to see what's going on
155 under the hood:
156
157 $ IPCRUNDEBUG=basic myscript # prints minimal debugging
158 $ IPCRUNDEBUG=data myscript # prints all data reads/writes
159 $ IPCRUNDEBUG=details myscript # prints lots of low-level details
160 $ IPCRUNDEBUG=gory myscript # (Win32 only) prints data moving through
161 # the helper processes.
162
163 =back
164
165 We now return you to your regularly scheduled documentation.
166
167 =head2 Harnesses
168
169 Child processes and I/O handles are gathered in to a harness, then
170 started and run until the processing is finished or aborted.
171
172 =head2 run() vs. start(); pump(); finish();
173
174 There are two modes you can run harnesses in: run() functions as an
175 enhanced system(), and start()/pump()/finish() allow for background
176 processes and scripted interactions with them.
177
178 When using run(), all data to be sent to the harness is set up in
179 advance (though one can feed subprocesses input from subroutine refs to
180 get around this limitation). The harness is run and all output is
181 collected from it, then any child processes are waited for:
182
183 run \@cmd, \<<IN, \$out ;
184 blah
185 IN
186
187 ## To precompile harnesses and run them later:
188 my $h = harness \@cmd, \<<IN, \$out ;
189 blah
190 IN
191
192 run $h ;
193
194 The background and scripting API is provided by start(), pump(), and
195 finish(): start() creates a harness if need be (by calling harness())
196 and launches any subprocesses, pump() allows you to poll them for
197 activity, and finish() then monitors the harnessed activities until they
198 complete.
199
200 ## Build the harness, open all pipes, and launch the subprocesses
201 my $h = start \@cat, \$in, \$out ;
202 $in = "first input\n" ;
203
204 ## Now do I/O. start() does no I/O.
205 pump $h while length $in ; ## Wait for all input to go
206
207 ## Now do some more I/O.
208 $in = "second input\n" ;
209 pump $h until $out =~ /second input/ ;
210
211 ## Clean up
212 finish $h or die "cat returned $?" ;
213
214 You can optionally compile the harness with harness() prior to
215 start()ing or run()ing, and you may omit start() between harness() and
216 pump(). You might want to do these things if you compile your harnesses
217 ahead of time.
218
219 =head2 Using regexps to match output
220
221 As shown in most of the scripting examples, the read-to-scalar facility
222 for gathering subcommand's output is often used with regular expressions
223 to detect stopping points. This is because subcommand output often
224 arrives in dribbles and drabs, often only a character or line at a time.
225 This output is input for the main program and piles up in variables like
226 the C<$out> and C<$err> in our examples.
227
228 Regular expressions can be used to wait for appropriate output in
229 several ways. The C<cat> example in the previous section demonstrates
230 how to pump() until some string appears in the output. Here's an
231 example that uses C<smb> to fetch files from a remote server:
232
233 $h = harness \@smbclient, \$in, \$out ;
234
235 $in = "cd /src\n" ;
236 $h->pump until $out =~ /^smb.*> \Z/m ;
237 die "error cding to /src:\n$out" if $out =~ "ERR" ;
238 $out = '' ;
239
240 $in = "mget *\n" ;
241 $h->pump until $out =~ /^smb.*> \Z/m ;
242 die "error retrieving files:\n$out" if $out =~ "ERR" ;
243
244 $in = "quit\n" ;
245 $h->finish ;
246
247 Notice that we carefully clear $out after the first command/response
248 cycle? That's because IPC::Run does not delete $out when we continue,
249 and we don't want to trip over the old output in the second
250 command/response cycle.
251
252 Say you want to accumulate all the output in $out and analyze it
253 afterwards. Perl offers incremental regular expression matching using
254 the C<m//gc> and pattern matching idiom and the C<\G> assertion.
255 IPC::Run is careful not to disturb the current C<pos()> value for
256 scalars it appends data to, so we could modify the above so as not to
257 destroy $out by adding a couple of C</gc> modifiers. The C</g> keeps us
258 from tripping over the previous prompt and the C</c> keeps us from
259 resetting the prior match position if the expected prompt doesn't
260 materialize immediately:
261
262 $h = harness \@smbclient, \$in, \$out ;
263
264 $in = "cd /src\n" ;
265 $h->pump until $out =~ /^smb.*> \Z/mgc ;
266 die "error cding to /src:\n$out" if $out =~ "ERR" ;
267
268 $in = "mget *\n" ;
269 $h->pump until $out =~ /^smb.*> \Z/mgc ;
270 die "error retrieving files:\n$out" if $out =~ "ERR" ;
271
272 $in = "quit\n" ;
273 $h->finish ;
274
275 analyze( $out ) ;
276
277 When using this technique, you may want to preallocate $out to have
278 plenty of memory or you may find that the act of growing $out each time
279 new input arrives causes an C<O(length($out)^2)> slowdown as $out grows.
280 Say we expect no more than 10,000 characters of input at the most. To
281 preallocate memory to $out, do something like:
282
283 my $out = "x" x 10_000 ;
284 $out = "" ;
285
286 C<perl> will allocate at least 10,000 characters' worth of space, then
287 mark the $out as having 0 length without freeing all that yummy RAM.
288
289 =head2 Timeouts and Timers
290
291 More than likely, you don't want your subprocesses to run forever, and
292 sometimes it's nice to know that they're going a little slowly.
293 Timeouts throw exceptions after a some time has elapsed, timers merely
294 cause pump() to return after some time has elapsed. Neither is
295 reset/restarted automatically.
296
297 Timeout objects are created by calling timeout( $interval ) and passing
298 the result to run(), start() or harness(). The timeout period starts
299 ticking just after all the child processes have been fork()ed or
300 spawn()ed, and are polled for expiration in run(), pump() and finish().
301 If/when they expire, an exception is thrown. This is typically useful
302 to keep a subprocess from taking too long.
303
304 If a timeout occurs in run(), all child processes will be terminated and
305 all file/pipe/ptty descriptors opened by run() will be closed. File
306 descriptors opened by the parent process and passed in to run() are not
307 closed in this event.
308
309 If a timeout occurs in pump(), pump_nb(), or finish(), it's up to you to
310 decide whether to kill_kill() all the children or to implement some more
311 graceful fallback. No I/O will be closed in pump(), pump_nb() or
312 finish() by such an exception (though I/O is often closed down in those
313 routines during the natural course of events).
314
315 Often an exception is too harsh. timer( $interval ) creates timer
316 objects that merely prevent pump() from blocking forever. This can be
317 useful for detecting stalled I/O or printing a soothing message or "."
318 to pacify an anxious user.
319
320 Timeouts and timers can both be restarted at any time using the timer's
321 start() method (this is not the start() that launches subprocesses). To
322 restart a timer, you need to keep a reference to the timer:
323
324 ## Start with a nice long timeout to let smbclient connect. If
325 ## pump or finish take too long, an exception will be thrown.
326
327 my $h ;
328 eval {
329 $h = harness \@smbclient, \$in, \$out, \$err, ( my $t = timeout 30 ) ;
330 sleep 11 ; # No effect: timer not running yet
331
332 start $h ;
333 $in = "cd /src\n" ;
334 pump $h until ! length $in ;
335
336 $in = "ls\n" ;
337 ## Now use a short timeout, since this should be faster
338 $t->start( 5 ) ;
339 pump $h until ! length $in ;
340
341 $t->start( 10 ) ; ## Give smbclient a little while to shut down.
342 $h->finish ;
343 } ;
344 if ( $@ ) {
345 my $x = $@ ; ## Preserve $@ in case another exception occurs
346 $h->kill_kill ; ## kill it gently, then brutally if need be, or just
347 ## brutally on Win32.
348 die $x ;
349 }
350
351 Timeouts and timers are I<not> checked once the subprocesses are shut
352 down; they will not expire in the interval between the last valid
353 process and when IPC::Run scoops up the processes' result codes, for
354 instance.
355
356 =head2 Spawning synchronization, child exception propagation
357
358 start() pauses the parent until the child executes the command or CODE
359 reference and propagates any exceptions thrown (including exec()
360 failure) back to the parent. This has several pleasant effects: any
361 exceptions thrown in the child, including exec() failure, come flying
362 out of start() or run() as though they had ocurred in the parent.
363
364 This includes exceptions your code thrown from init subs. In this
365 example:
366
367 eval {
368 run \@cmd, init => sub { die "blast it! foiled again!" } ;
369 } ;
370 print $@ ;
371
372 the exception "blast it! foiled again" will be thrown from the child
373 process (preventing the exec()) and printed by the parent.
374
375 In situations like
376
377 run \@cmd1, "|", \@cmd2, "|", \@cmd3 ;
378
379 @cmd1 will be initted and exec()ed before @cmd2, and @cmd2 before @cmd3.
380 This can save time and prevent oddball errors emitted by later commands
381 when earlier commands fail to execute. Note that IPC::Run doesn't start
382 any commands unless it can find the executables referenced by all
383 commands. These executables must pass both the C<-f> and C<-x> tests
384 described in L<perlfunc>.
385
386 Another nice effect is that init() subs can take their time doing things
387 and there will be no problems caused by a parent continuing to execute
388 before a child's init() routine is complete. Say the init() routine
389 needs to open a socket or a temp file that the parent wants to connect
390 to; without this synchronization, the parent will need to implement a
391 retry loop to wait for the child to run, since often, the parent gets a
392 lot of things done before the child's first timeslice is allocated.
393
394 This is also quite necessary for pseudo-tty initialization, which needs
395 to take place before the parent writes to the child via pty. Writes
396 that occur before the pty is set up can get lost.
397
398 A final, minor, nicety is that debugging output from the child will be
399 emitted before the parent continues on, making for much clearer debugging
400 output in complex situations.
401
402 The only drawback I can conceive of is that the parent can't continue to
403 operate while the child is being initted. If this ever becomes a
404 problem in the field, we can implement an option to avoid this behavior,
405 but I don't expect it to.
406
407 B<Win32>: executing CODE references isn't supported on Win32, see
408 L</Win32 LIMITATIONS> for details.
409
410 =head2 Syntax
411
412 run(), start(), and harness() can all take a harness specification
413 as input. A harness specification is either a single string to be passed
414 to the systems' shell:
415
416 run "echo 'hi there'" ;
417
418 or a list of commands, io operations, and/or timers/timeouts to execute.
419 Consecutive commands must be separated by a pipe operator '|' or an '&'.
420 External commands are passed in as array references, and, on systems
421 supporting fork(), Perl code may be passed in as subs:
422
423 run \@cmd ;
424 run \@cmd1, '|', \@cmd2 ;
425 run \@cmd1, '&', \@cmd2 ;
426 run \&sub1 ;
427 run \&sub1, '|', \&sub2 ;
428 run \&sub1, '&', \&sub2 ;
429
430 '|' pipes the stdout of \@cmd1 the stdin of \@cmd2, just like a
431 shell pipe. '&' does not. Child processes to the right of a '&'
432 will have their stdin closed unless it's redirected-to.
433
434 L<IPC::Run::IO> objects may be passed in as well, whether or not
435 child processes are also specified:
436
437 run io( "infile", ">", \$in ), io( "outfile", "<", \$in ) ;
438
439 as can L<IPC::Run::Timer> objects:
440
441 run \@cmd, io( "outfile", "<", \$in ), timeout( 10 ) ;
442
443 Commands may be followed by scalar, sub, or i/o handle references for
444 redirecting
445 child process input & output:
446
447 run \@cmd, \undef, \$out ;
448 run \@cmd, \$in, \$out ;
449 run \@cmd1, \&in, '|', \@cmd2, \*OUT ;
450 run \@cmd1, \*IN, '|', \@cmd2, \&out ;
451
452 This is known as succinct redirection syntax, since run(), start()
453 and harness(), figure out which file descriptor to redirect and how.
454 File descriptor 0 is presumed to be an input for
455 the child process, all others are outputs. The assumed file
456 descriptor always starts at 0, unless the command is being piped to,
457 in which case it starts at 1.
458
459 To be explicit about your redirects, or if you need to do more complex
460 things, there's also a redirection operator syntax:
461
462 run \@cmd, '<', \undef, '>', \$out ;
463 run \@cmd, '<', \undef, '>&', \$out_and_err ;
464 run(
465 \@cmd1,
466 '<', \$in,
467 '|', \@cmd2,
468 \$out
469 ) ;
470
471 Operator syntax is required if you need to do something other than simple
472 redirection to/from scalars or subs, like duping or closing file descriptors
473 or redirecting to/from a named file. The operators are covered in detail
474 below.
475
476 After each \@cmd (or \&foo), parsing begins in succinct mode and toggles to
477 operator syntax mode when an operator (ie plain scalar, not a ref) is seen.
478 Once in
479 operator syntax mode, parsing only reverts to succinct mode when a '|' or
480 '&' is seen.
481
482 In succinct mode, each parameter after the \@cmd specifies what to
483 do with the next highest file descriptor. These File descriptor start
484 with 0 (stdin) unless stdin is being piped to (C<'|', \@cmd>), in which
485 case they start with 1 (stdout). Currently, being on the left of
486 a pipe (C<\@cmd, \$out, \$err, '|'>) does I<not> cause stdout to be
487 skipped, though this may change since it's not as DWIMerly as it
488 could be. Only stdin is assumed to be an
489 input in succinct mode, all others are assumed to be outputs.
490
491 If no piping or redirection is specified for a child, it will inherit
492 the parent's open file handles as dictated by your system's
493 close-on-exec behavior and the $^F flag, except that processes after a
494 '&' will not inherit the parent's stdin. Also note that $^F does not
495 affect file desciptors obtained via POSIX, since it only applies to
496 full-fledged Perl file handles. Such processes will have their stdin
497 closed unless it has been redirected-to.
498
499 If you want to close a child processes stdin, you may do any of:
500
501 run \@cmd, \undef ;
502 run \@cmd, \"" ;
503 run \@cmd, '<&-' ;
504 run \@cmd, '0<&-' ;
505
506 Redirection is done by placing redirection specifications immediately
507 after a command or child subroutine:
508
509 run \@cmd1, \$in, '|', \@cmd2, \$out ;
510 run \@cmd1, '<', \$in, '|', \@cmd2, '>', \$out ;
511
512 If you omit the redirection operators, descriptors are counted
513 starting at 0. Descriptor 0 is assumed to be input, all others
514 are outputs. A leading '|' consumes descriptor 0, so this
515 works as expected.
516
517 run \@cmd1, \$in, '|', \@cmd2, \$out ;
518
519 The parameter following a redirection operator can be a scalar ref,
520 a subroutine ref, a file name, an open filehandle, or a closed
521 filehandle.
522
523 If it's a scalar ref, the child reads input from or sends output to
524 that variable:
525
526 $in = "Hello World.\n" ;
527 run \@cat, \$in, \$out ;
528 print $out ;
529
530 Scalars used in incremental (start()/pump()/finish()) applications are treated
531 as queues: input is removed from input scalers, resulting in them dwindling
532 to '', and output is appended to output scalars. This is not true of
533 harnesses run() in batch mode.
534
535 It's usually wise to append new input to be sent to the child to the input
536 queue, and you'll often want to zap output queues to '' before pumping.
537
538 $h = start \@cat, \$in ;
539 $in = "line 1\n" ;
540 pump $h ;
541 $in .= "line 2\n" ;
542 pump $h ;
543 $in .= "line 3\n" ;
544 finish $h ;
545
546 The final call to finish() must be there: it allows the child process(es)
547 to run to completion and waits for their exit values.
548
549 =head1 OBSTINATE CHILDREN
550
551 Interactive applications are usually optimized for human use. This
552 can help or hinder trying to interact with them through modules like
553 IPC::Run. Frequently, programs alter their behavior when they detect
554 that stdin, stdout, or stderr are not connected to a tty, assuming that
555 they are being run in batch mode. Whether this helps or hurts depends
556 on which optimizations change. And there's often no way of telling
557 what a program does in these areas other than trial and error and,
558 occasionally, reading the source. This includes different versions
559 and implementations of the same program.
560
561 All hope is not lost, however. Most programs behave in reasonably
562 tractable manners, once you figure out what it's trying to do.
563
564 Here are some of the issues you might need to be aware of.
565
566 =over
567
568 =item *
569
570 fflush()ing stdout and stderr
571
572 This lets the user see stdout and stderr immediately. Many programs
573 undo this optimization if stdout is not a tty, making them harder to
574 manage by things like IPC::Run.
575
576 Many programs decline to fflush stdout or stderr if they do not
577 detect a tty there. Some ftp commands do this, for instance.
578
579 If this happens to you, look for a way to force interactive behavior,
580 like a command line switch or command. If you can't, you will
581 need to use a pseudo terminal ('<pty<' and '>pty>').
582
583 =item *
584
585 false prompts
586
587 Interactive programs generally do not guarantee that output from user
588 commands won't contain a prompt string. For example, your shell prompt
589 might be a '$', and a file named '$' might be the only file in a directory
590 listing.
591
592 This can make it hard to guarantee that your output parser won't be fooled
593 into early termination of results.
594
595 To help work around this, you can see if the program can alter it's
596 prompt, and use something you feel is never going to occur in actual
597 practice.
598
599 You should also look for your prompt to be the only thing on a line:
600
601 pump $h until $out =~ /^<SILLYPROMPT>\s?\z/m ;
602
603 (use C<(?!\n)\Z> in place of C<\z> on older perls).
604
605 You can also take the approach that IPC::ChildSafe takes and emit a
606 command with known output after each 'real' command you issue, then
607 look for this known output. See new_appender() and new_chunker() for
608 filters that can help with this task.
609
610 If it's not convenient or possibly to alter a prompt or use a known
611 command/response pair, you might need to autodetect the prompt in case
612 the local version of the child program is different then the one
613 you tested with, or if the user has control over the look & feel of
614 the prompt.
615
616 =item *
617
618 Refusing to accept input unless stdin is a tty.
619
620 Some programs, for security reasons, will only accept certain types
621 of input from a tty. su, notable, will not prompt for a password unless
622 it's connected to a tty.
623
624 If this is your situation, use a pseudo terminal ('<pty<' and '>pty>').
625
626 =item *
627
628 Not prompting unless connected to a tty.
629
630 Some programs don't prompt unless stdin or stdout is a tty. See if you can
631 turn prompting back on. If not, see if you can come up with a command that
632 you can issue after every real command and look for it's output, as
633 IPC::ChildSafe does. There are two filters included with IPC::Run that
634 can help with doing this: appender and chunker (see new_appender() and
635 new_chunker()).
636
637 =item *
638
639 Different output format when not connected to a tty.
640
641 Some commands alter their formats to ease machine parsability when they
642 aren't connected to a pipe. This is actually good, but can be surprising.
643
644 =back
645
646 =head1 PSEUDO TERMINALS
647
648 On systems providing pseudo terminals under /dev, IPC::Run can use IO::Pty
649 (available on CPAN) to provide a terminal environment to subprocesses.
650 This is necessary when the subprocess really wants to think it's connected
651 to a real terminal.
652
653 =head2 CAVEATS
654
655 Psuedo-terminals are not pipes, though they are similar. Here are some
656 differences to watch out for.
657
658 =over
659
660 =item Echoing
661
662 Sending to stdin will cause an echo on stdout, which occurs before each
663 line is passed to the child program. There is currently no way to
664 disable this, although the child process can and should disable it for
665 things like passwords.
666
667 =item Shutdown
668
669 IPC::Run cannot close a pty until all output has been collected. This
670 means that it is not possible to send an EOF to stdin by half-closing
671 the pty, as we can when using a pipe to stdin.
672
673 This means that you need to send the child process an exit command or
674 signal, or run() / finish() will time out. Be careful not to expect a
675 prompt after sending the exit command.
676
677 =item Command line editing
678
679 Some subprocesses, notable shells that depend on the user's prompt
680 settings, will reissue the prompt plus the command line input so far
681 once for each character.
682
683 =item '>pty>' means '&>pty>', not '1>pty>'
684
685 The pseudo terminal redirects both stdout and stderr unless you specify
686 a file descriptor. If you want to grab stderr separately, do this:
687
688 start \@cmd, '<pty<', \$in, '>pty>', \$out, '2>', \$err ;
689
690 =item stdin, stdout, and stderr not inherited
691
692 Child processes harnessed to a pseudo terminal have their stdin, stdout,
693 and stderr completely closed before any redirection operators take
694 effect. This casts of the bonds of the controlling terminal. This is
695 not done when using pipes.
696
697 Right now, this affects all children in a harness that has a pty in use,
698 even if that pty would not affect a particular child. That's a bug and
699 will be fixed. Until it is, it's best not to mix-and-match children.
700
701 =back
702
703 =head2 Redirection Operators
704
705 Operator SHNP Description
706 ======== ==== ===========
707 <, N< SHN Redirects input to a child's fd N (0 assumed)
708
709 >, N> SHN Redirects output from a child's fd N (1 assumed)
710 >>, N>> SHN Like '>', but appends to scalars or named files
711 >&, &> SHN Redirects stdout & stderr from a child process
712
713 <pty, N<pty S Like '<', but uses a pseudo-tty instead of a pipe
714 >pty, N>pty S Like '>', but uses a pseudo-tty instead of a pipe
715
716 N<&M Dups input fd N to input fd M
717 M>&N Dups output fd N to input fd M
718 N<&- Closes fd N
719
720 <pipe, N<pipe P Pipe opens H for caller to read, write, close.
721 >pipe, N>pipe P Pipe opens H for caller to read, write, close.
722
723 'N' and 'M' are placeholders for integer file descriptor numbers. The
724 terms 'input' and 'output' are from the child process's perspective.
725
726 The SHNP field indicates what parameters an operator can take:
727
728 S: \$scalar or \&function references. Filters may be used with
729 these operators (and only these).
730 H: \*HANDLE or IO::Handle for caller to open, and close
731 N: "file name".
732 P: \*HANDLE opened by IPC::Run as the parent end of a pipe, but read
733 and written to and closed by the caller (like IPC::Open3).
734
735 =over
736
737 =item Redirecting input: [n]<, [n]<pipe
738
739 You can input the child reads on file descriptor number n to come from a
740 scalar variable, subroutine, file handle, or a named file. If stdin
741 is not redirected, the parent's stdin is inherited.
742
743 run \@cat, \undef ## Closes child's stdin immediately
744 or die "cat returned $?" ;
745
746 run \@cat, \$in ;
747
748 run \@cat, \<<TOHERE ;
749 blah
750 TOHERE
751
752 run \@cat, \&input ; ## Calls &input, feeding data returned
753 ## to child's. Closes child's stdin
754 ## when undef is returned.
755
756 Redirecting from named files requires you to use the input
757 redirection operator:
758
759 run \@cat, '<.profile' ;
760 run \@cat, '<', '.profile' ;
761
762 open IN, "<foo" ;
763 run \@cat, \*IN ;
764 run \@cat, *IN{IO} ;
765
766 The form used second example here is the safest,
767 since filenames like "0" and "&more\n" won't confuse &run:
768
769 You can't do either of
770
771 run \@a, *IN ; ## INVALID
772 run \@a, '<', *IN ; ## BUGGY: Reads file named like "*main::A"
773
774 because perl passes a scalar containing a string that
775 looks like "*main::A" to &run, and &run can't tell the difference
776 between that and a redirection operator or a file name. &run guarantees
777 that any scalar you pass after a redirection operator is a file name.
778
779 If your child process will take input from file descriptors other
780 than 0 (stdin), you can use a redirection operator with any of the
781 valid input forms (scalar ref, sub ref, etc.):
782
783 run \@cat, '3<', \$in3 ;
784
785 When redirecting input from a scalar ref, the scalar ref is
786 used as a queue. This allows you to use &harness and pump() to
787 feed incremental bits of input to a coprocess. See L</Coprocesses>
788 below for more information.
789
790 The <pipe operator opens the write half of a pipe on the filehandle
791 glob reference it takes as an argument:
792
793 $h = start \@cat, '<pipe', \*IN ;
794 print IN "hello world\n" ;
795 pump $h ;
796 close IN ;
797 finish $h ;
798
799 Unlike the other '<' operators, IPC::Run does nothing further with
800 it: you are responsible for it. The previous example is functionally
801 equivalent to:
802
803 pipe( \*R, \*IN ) or die $! ;
804 $h = start \@cat, '<', \*IN ;
805 print IN "hello world\n" ;
806 pump $h ;
807 close IN ;
808 finish $h ;
809
810 This is like the behavior of IPC::Open2 and IPC::Open3.
811
812 B<Win32>: The handle returned is actually a socket handle, so you can
813 use select() on it.
814
815 =item Redirecting output: [n]>, [n]>>, [n]>&[m], [n]>pipe
816
817 You can redirect any output the child emits
818 to a scalar variable, subroutine, file handle, or file name. You
819 can have &run truncate or append to named files or scalars. If
820 you are redirecting stdin as well, or if the command is on the
821 receiving end of a pipeline ('|'), you can omit the redirection
822 operator:
823
824 @ls = ( 'ls' ) ;
825 run \@ls, \undef, \$out
826 or die "ls returned $?" ;
827
828 run \@ls, \undef, \&out ; ## Calls &out each time some output
829 ## is received from the child's
830 ## when undef is returned.
831
832 run \@ls, \undef, '2>ls.err' ;
833 run \@ls, '2>', 'ls.err' ;
834
835 The two parameter form guarantees that the filename
836 will not be interpreted as a redirection operator:
837
838 run \@ls, '>', "&more" ;
839 run \@ls, '2>', ">foo\n" ;
840
841 You can pass file handles you've opened for writing:
842
843 open( *OUT, ">out.txt" ) ;
844 open( *ERR, ">err.txt" ) ;
845 run \@cat, \*OUT, \*ERR ;
846
847 Passing a scalar reference and a code reference requires a little
848 more work, but allows you to capture all of the output in a scalar
849 or each piece of output by a callback:
850
851 These two do the same things:
852
853 run( [ 'ls' ], '2>', sub { $err_out .= $_[0] } ) ;
854
855 does the same basic thing as:
856
857 run( [ 'ls' ], '2>', \$err_out ) ;
858
859 The subroutine will be called each time some data is read from the child.
860
861 The >pipe operator is different in concept than the other '>' operators,
862 although it's syntax is similar:
863
864 $h = start \@cat, $in, '>pipe', \*OUT, '2>pipe', \*ERR ;
865 $in = "hello world\n" ;
866 finish $h ;
867 print <OUT> ;
868 print <ERR> ;
869 close OUT ;
870 close ERR ;
871
872 causes two pipe to be created, with one end attached to cat's stdout
873 and stderr, respectively, and the other left open on OUT and ERR, so
874 that the script can manually
875 read(), select(), etc. on them. This is like
876 the behavior of IPC::Open2 and IPC::Open3.
877
878 B<Win32>: The handle returned is actually a socket handle, so you can
879 use select() on it.
880
881 =item Duplicating output descriptors: >&m, n>&m
882
883 This duplicates output descriptor number n (default is 1 if n is omitted)
884 from descriptor number m.
885
886 =item Duplicating input descriptors: <&m, n<&m
887
888 This duplicates input descriptor number n (default is 0 if n is omitted)
889 from descriptor number m
890
891 =item Closing descriptors: <&-, 3<&-
892
893 This closes descriptor number n (default is 0 if n is omitted). The
894 following commands are equivalent:
895
896 run \@cmd, \undef ;
897 run \@cmd, '<&-' ;
898 run \@cmd, '<in.txt', '<&-' ;
899
900 Doing
901
902 run \@cmd, \$in, '<&-' ; ## SIGPIPE recipe.
903
904 is dangerous: the parent will get a SIGPIPE if $in is not empty.
905
906 =item Redirecting both stdout and stderr: &>, >&, &>pipe, >pipe&
907
908 The following pairs of commands are equivalent:
909
910 run \@cmd, '>&', \$out ; run \@cmd, '>', \$out, '2>&1' ;
911 run \@cmd, '>&', 'out.txt' ; run \@cmd, '>', 'out.txt', '2>&1' ;
912
913 etc.
914
915 File descriptor numbers are not permitted to the left or the right of
916 these operators, and the '&' may occur on either end of the operator.
917
918 The '&>pipe' and '>pipe&' variants behave like the '>pipe' operator, except
919 that both stdout and stderr write to the created pipe.
920
921 =item Redirection Filters
922
923 Both input redirections and output redirections that use scalars or
924 subs as endpoints may have an arbitrary number of filter subs placed
925 between them and the child process. This is useful if you want to
926 receive output in chunks, or if you want to massage each chunk of
927 data sent to the child. To use this feature, you must use operator
928 syntax:
929
930 run(
931 \@cmd
932 '<', \&in_filter_2, \&in_filter_1, $in,
933 '>', \&out_filter_1, \&in_filter_2, $out,
934 ) ;
935
936 This capability is not provided for IO handles or named files.
937
938 Two filters are provided by IPC::Run: appender and chunker. Because
939 these may take an argument, you need to use the constructor functions
940 new_appender() and new_chunker() rather than using \& syntax:
941
942 run(
943 \@cmd
944 '<', new_appender( "\n" ), $in,
945 '>', new_chunker, $out,
946 ) ;
947
948 =back
949
950 =head2 Just doing I/O
951
952 If you just want to do I/O to a handle or file you open yourself, you
953 may specify a filehandle or filename instead of a command in the harness
954 specification:
955
956 run io( "filename", '>', \$recv ) ;
957
958 $h = start io( $io, '>', \$recv ) ;
959
960 $h = harness \@cmd, '&', io( "file", '<', \$send ) ;
961
962 =head2 Options
963
964 Options are passed in as name/value pairs:
965
966 run \@cat, \$in, debug => 1 ;
967
968 If you pass the debug option, you may want to pass it in first, so you
969 can see what parsing is going on:
970
971 run debug => 1, \@cat, \$in ;
972
973 =over
974
975 =item debug
976
977 Enables debugging output in parent and child. Debugging info is emitted
978 to the STDERR that was present when IPC::Run was first C<use()>ed (it's
979 C<dup()>ed out of the way so that it can be redirected in children without
980 having debugging output emitted on it).
981
982 =back
983
984 =head1 RETURN VALUES
985
986 harness() and start() return a reference to an IPC::Run harness. This is
987 blessed in to the IPC::Run package, so you may make later calls to
988 functions as members if you like:
989
990 $h = harness( ... ) ;
991 $h->start ;
992 $h->pump ;
993 $h->finish ;
994
995 $h = start( .... ) ;
996 $h->pump ;
997 ...
998
999 Of course, using method call syntax lets you deal with any IPC::Run
1000 subclasses that might crop up, but don't hold your breath waiting for
1001 any.
1002
1003 run() and finish() return TRUE when all subcommands exit with a 0 result
1004 code. B<This is the opposite of perl's system() command>.
1005
1006 All routines raise exceptions (via die()) when error conditions are
1007 recognized. A non-zero command result is not treated as an error
1008 condition, since some commands are tests whose results are reported
1009 in their exit codes.
1010
1011 =head1 ROUTINES
1012
1013 =over
1014
1015 =cut
1016
1017 @ISA = qw( Exporter ) ;
1018
1019 ## We use @EXPORT for the end user's convenience: there's only one function
1020 ## exported, it's homonymous with the module, it's an unusual name, and
1021 ## it can be suppressed by "use IPC::Run () ;".
1022
1023 my @FILTER_IMP = qw( input_avail get_more_input ) ;
1024 my @FILTERS = qw(
1025 new_appender
1026 new_chunker
1027 new_string_source
1028 new_string_sink
1029 ) ;
1030 my @API = qw(
1031 run
1032 harness start pump pumpable finish
1033 signal kill_kill reap_nb
1034 io timer timeout
1035 close_terminal
1036 binary
1037 ) ;
1038
1039 @EXPORT_OK = ( @API, @FILTER_IMP, @FILTERS, qw( filter_tests Win32_MODE ) ) ;
1040 %EXPORT_TAGS = (
1041 'filter_imp' => \@FILTER_IMP,
1042 'all' => \@EXPORT_OK,
1043 'filters' => \@FILTERS,
1044 'api' => \@API,
1045 ) ;
1046
1047 use strict ;
1048
1049 use IPC::Run::Debug;
1050 use Exporter ;
1051 use Fcntl ;
1052 use POSIX () ;
1053 use Symbol ;
1054 use Carp ;
1055 use File::Spec ;
1056 use IO::Handle ;
1057 require IPC::Run::IO ;
1058 require IPC::Run::Timer ;
1059 use UNIVERSAL qw( isa ) ;
1060
1061 use constant Win32_MODE => $^O =~ /os2|Win32/i ;
1062
1063 BEGIN {
1064 if ( Win32_MODE ) {
1065 eval "use IPC::Run::Win32Helper; 1;"
1066 or ( $@ && die ) or die "$!" ;
1067 }
1068 else {
1069 eval "use File::Basename; 1;" or die $! ;
1070 }
1071 }
1072
1073
1074 sub input_avail() ;
1075 sub get_more_input() ;
1076
1077 ###############################################################################
1078
1079 ##
1080 ## State machine states, set in $self->{STATE}
1081 ##
1082 ## These must be in ascending order numerically
1083 ##
1084 sub _newed() {0}
1085 sub _harnessed(){1}
1086 sub _finished() {2} ## _finished behave almost exactly like _harnessed
1087 sub _started() {3}
1088
1089 ##
1090 ## Which fds have been opened in the parent. This may have extra fds, since
1091 ## we aren't all that rigorous about closing these off, but that's ok. This
1092 ## is used on Unixish OSs to close all fds in the child that aren't needed
1093 ## by that particular child.
1094 my %fds ;
1095
1096 ## There's a bit of hackery going on here.
1097 ##
1098 ## We want to have any code anywhere be able to emit
1099 ## debugging statements without knowing what harness the code is
1100 ## being called in/from, since we'd need to pass a harness around to
1101 ## everything.
1102 ##
1103 ## Thus, $cur_self was born.
1104
1105 use vars qw( $cur_self ) ;
1106
1107 sub _debug_fd {
1108 return fileno STDERR unless defined $cur_self ;
1109
1110 if ( _debugging && ! defined $cur_self->{DEBUG_FD} ) {
1111 my $fd = select STDERR ; $| = 1 ; select $fd ;
1112 $cur_self->{DEBUG_FD} = POSIX::dup fileno STDERR ;
1113 _debug( "debugging fd is $cur_self->{DEBUG_FD}\n" )
1114 if _debugging_details ;
1115 }
1116
1117 return fileno STDERR unless defined $cur_self->{DEBUG_FD} ;
1118
1119 return $cur_self->{DEBUG_FD}
1120 }
1121
1122 sub DESTROY {
1123 ## We absolutely do not want to do anything else here. We are likely
1124 ## to be in a child process and we don't want to do things like kill_kill
1125 ## ourself or cause other destruction.
1126 my IPC::Run $self = shift ;
1127 POSIX::close $self->{DEBUG_FD} if defined $self->{DEBUG_FD} ;
1128 $self->{DEBUG_FD} = undef ;
1129 }
1130
1131 ##
1132 ## Support routines (NOT METHODS)
1133 ##
1134 my %cmd_cache ;
1135
1136 sub _search_path {
1137 my ( $cmd_name ) = @_ ;
1138 if ( File::Spec->file_name_is_absolute( $cmd_name ) && -x $cmd_name) {
1139 _debug "'", $cmd_name, "' is absolute"
1140 if _debugging_details ;
1141 return $cmd_name ;
1142 }
1143
1144 my $dirsep =
1145 ( Win32_MODE
1146 ? '[/\\\\]'
1147 : $^O =~ /MacOS/
1148 ? ':'
1149 : $^O =~ /VMS/
1150 ? '[\[\]]'
1151 : '/'
1152 ) ;
1153
1154 if ( Win32_MODE
1155 && ( $cmd_name =~ /$dirsep/ )
1156 && ( $cmd_name !~ /\..+$/ ) ## Only run if cmd_name has no extension?
1157 ) {
1158 for ( split /;/, $ENV{PATHEXT} || ".COM;.BAT;.EXE" ) {
1159 my $name = "$cmd_name$_";
1160 $cmd_name = $name, last if -f $name && -x _;
1161 }
1162 }
1163
1164 if ( $cmd_name =~ /($dirsep)/ ) {
1165 _debug "'$cmd_name' contains '$1'" if _debugging;
1166 croak "file not found: $cmd_name" unless -e $cmd_name ;
1167 croak "not a file: $cmd_name" unless -f $cmd_name ;
1168 croak "permission denied: $cmd_name" unless -x $cmd_name ;
1169 return $cmd_name ;
1170 }
1171
1172 if ( exists $cmd_cache{$cmd_name} ) {
1173 _debug "'$cmd_name' found in cache: '$cmd_cache{$cmd_name}'"
1174 if _debugging;
1175 return $cmd_cache{$cmd_name} if -x $cmd_cache{$cmd_name} ;
1176 _debug "'$cmd_cache{$cmd_name}' no longer executable, searching..."
1177 if _debugging;
1178 delete $cmd_cache{$cmd_name} ;
1179 }
1180
1181 my @searched_in ;
1182
1183 ## This next bit is Unix/Win32 specific, unfortunately.
1184 ## There's been some conversation about extending File::Spec to provide
1185 ## a universal interface to PATH, but I haven't seen it yet.
1186 my $re = Win32_MODE ? qr/;/ : qr/:/ ;
1187
1188 LOOP:
1189 for ( split( $re, $ENV{PATH}, -1 ) ) {
1190 $_ = "." unless length $_ ;
1191 push @searched_in, $_ ;
1192
1193 my $prospect = File::Spec->catfile( $_, $cmd_name ) ;
1194 my @prospects ;
1195
1196 @prospects =
1197 ( Win32_MODE && ! ( -f $prospect && -x _ ) )
1198 ? map "$prospect$_", split /;/, $ENV{PATHEXT} || ".COM;.BAT;.EXE"
1199 : ( $prospect ) ;
1200
1201 for my $found ( @prospects ) {
1202 if ( -f $found && -x _ ) {
1203 $cmd_cache{$cmd_name} = $found ;
1204 last LOOP ;
1205 }
1206 }
1207 }
1208
1209 if ( exists $cmd_cache{$cmd_name} ) {
1210 _debug "'", $cmd_name, "' added to cache: '", $cmd_cache{$cmd_name}, "'"
1211 if _debugging_details ;
1212 return $cmd_cache{$cmd_name} ;
1213 }
1214
1215 croak "Command '$cmd_name' not found in " . join( ", ", @searched_in ) ;
1216 }
1217
1218
1219 sub _empty($) { ! ( defined $_[0] && length $_[0] ) }
1220
1221 ## 'safe' versions of otherwise fun things to do. See also IPC::Run::Win32Helper.
1222 sub _close {
1223 confess 'undef' unless defined $_[0] ;
1224 no strict 'refs' ;
1225 my $fd = $_[0] =~ /^\d+$/ ? $_[0] : fileno $_[0] ;
1226 my $r = POSIX::close $fd ;
1227 $r = $r ? '' : " ERROR $!" ;
1228 delete $fds{$fd} ;
1229 _debug "close( $fd ) = " . ( $r || 0 ) if _debugging_details ;
1230 }
1231
1232 sub _dup {
1233 confess 'undef' unless defined $_[0] ;
1234 my $r = POSIX::dup( $_[0] ) ;
1235 croak "$!: dup( $_[0] )" unless defined $r ;
1236 $r = 0 if $r eq '0 but true' ;
1237 _debug "dup( $_[0] ) = $r" if _debugging_details ;
1238 $fds{$r} = 1 ;
1239 return $r ;
1240 }
1241
1242
1243 sub _dup2_rudely {
1244 confess 'undef' unless defined $_[0] && defined $_[1] ;
1245 my $r = POSIX::dup2( $_[0], $_[1] ) ;
1246 croak "$!: dup2( $_[0], $_[1] )" unless defined $r ;
1247 $r = 0 if $r eq '0 but true' ;
1248 _debug "dup2( $_[0], $_[1] ) = $r" if _debugging_details ;
1249 $fds{$r} = 1 ;
1250 return $r ;
1251 }
1252
1253 sub _exec {
1254 confess 'undef passed' if grep !defined, @_ ;
1255 # exec @_ or croak "$!: exec( " . join( ', ', @_ ) . " )" ;
1256 _debug 'exec()ing ', join " ", map "'$_'", @_ if _debugging_details ;
1257
1258 # {
1259 ## Commented out since we don't call this on Win32.
1260 # # This works around the bug where 5.6.1 complains
1261 # # "Can't exec ...: No error" after an exec on NT, where
1262 # # exec() is simulated and actually returns in Perl's C
1263 # # code, though Perl's &exec does not...
1264 # no warnings "exec" ;
1265 #
1266 # # Just in case the no warnings workaround
1267 # # stops beign a workaround, we don't want
1268 # # old values of $! causing spurious strerr()
1269 # # messages to appear in the "Can't exec" message
1270 # undef $! ;
1271 exec @_ ;
1272 # }
1273 # croak "$!: exec( " . join( ', ', map "'$_'", @_ ) . " )" ;
1274 ## Fall through so $! can be reported to parent.
1275 }
1276
1277
1278 sub _sysopen {
1279 confess 'undef' unless defined $_[0] && defined $_[1] ;
1280 _debug sprintf( "O_RDONLY=0x%02x ", O_RDONLY ),
1281 sprintf( "O_WRONLY=0x%02x ", O_WRONLY ),
1282 sprintf( "O_RDWR=0x%02x ", O_RDWR ),
1283 sprintf( "O_TRUNC=0x%02x ", O_TRUNC),
1284 sprintf( "O_CREAT=0x%02x ", O_CREAT),
1285 sprintf( "O_APPEND=0x%02x ", O_APPEND),
1286 if _debugging_details ;
1287 my $r = POSIX::open( $_[0], $_[1], 0644 ) ;
1288 croak "$!: open( $_[0], ", sprintf( "0x%03x", $_[1] ), " )" unless defined $r ;
1289 _debug "open( $_[0], ", sprintf( "0x%03x", $_[1] ), " ) = $r"
1290 if _debugging_data ;
1291 $fds{$r} = 1 ;
1292 return $r ;
1293 }
1294
1295 sub _pipe {
1296 ## Normal, blocking write for pipes that we read and the child writes,
1297 ## since most children expect writes to stdout to block rather than
1298 ## do a partial write.
1299 my ( $r, $w ) = POSIX::pipe ;
1300 croak "$!: pipe()" unless defined $r ;
1301 _debug "pipe() = ( $r, $w ) " if _debugging_details ;
1302 $fds{$r} = $fds{$w} = 1 ;
1303 return ( $r, $w ) ;
1304 }
1305
1306 sub _pipe_nb {
1307 ## For pipes that we write, unblock the write side, so we can fill a buffer
1308 ## and continue to select().
1309 ## Contributed by Borislav Deianov <borislav@ensim.com>, with minor
1310 ## bugfix on fcntl result by me.
1311 local ( *R, *W ) ;
1312 my $f = pipe( R, W ) ;
1313 croak "$!: pipe()" unless defined $f ;
1314 my ( $r, $w ) = ( fileno R, fileno W ) ;
1315 _debug "pipe_nb pipe() = ( $r, $w )" if _debugging_details ;
1316 unless ( Win32_MODE ) {
1317 ## POSIX::fcntl doesn't take fd numbers, so gotta use Perl's and
1318 ## then _dup the originals (which get closed on leaving this block)
1319 my $fres = fcntl( W, &F_SETFL, O_WRONLY | O_NONBLOCK );
1320 croak "$!: fcntl( $w, F_SETFL, O_NONBLOCK )" unless $fres ;
1321 _debug "fcntl( $w, F_SETFL, O_NONBLOCK )" if _debugging_details ;
1322 }
1323 ( $r, $w ) = ( _dup( $r ), _dup( $w ) ) ;
1324 _debug "pipe_nb() = ( $r, $w )" if _debugging_details ;
1325 return ( $r, $w ) ;
1326 }
1327
1328 sub _pty {
1329 require IO::Pty ;
1330 my $pty = IO::Pty->new() ;
1331 croak "$!: pty ()" unless $pty ;
1332 $pty->autoflush() ;
1333 $pty->blocking( 0 ) or croak "$!: pty->blocking ( 0 )" ;
1334 _debug "pty() = ( ", $pty->fileno, ", ", $pty->slave->fileno, " )"
1335 if _debugging_details ;
1336 $fds{$pty->fileno} = $fds{$pty->slave->fileno} = 1 ;
1337 return $pty ;
1338 }
1339
1340
1341 sub _read {
1342 confess 'undef' unless defined $_[0] ;
1343 my $s = '' ;
1344 my $r = POSIX::read( $_[0], $s, 10_000 ) ;
1345 croak "$!: read( $_[0] )" if not($r) and $! != POSIX::EINTR;
1346 $r ||= 0;
1347 _debug "read( $_[0] ) = $r chars '$s'" if _debugging_data ;
1348 return $s ;
1349 }
1350
1351
1352 ## A METHOD, not a function.
1353 sub _spawn {
1354 my IPC::Run $self = shift ;
1355 my ( $kid ) = @_ ;
1356
1357 _debug "opening sync pipe ", $kid->{PID} if _debugging_details ;
1358 my $sync_reader_fd ;
1359 ( $sync_reader_fd, $self->{SYNC_WRITER_FD} ) = _pipe ;
1360 $kid->{PID} = fork() ;
1361 croak "$! during fork" unless defined $kid->{PID} ;
1362
1363 unless ( $kid->{PID} ) {
1364 ## _do_kid_and_exit closes sync_reader_fd since it closes all unwanted and
1365 ## unloved fds.
1366 $self->_do_kid_and_exit( $kid ) ;
1367 }
1368 _debug "fork() = ", $kid->{PID} if _debugging_details ;
1369
1370 ## Wait for kid to get to it's exec() and see if it fails.
1371 _close $self->{SYNC_WRITER_FD} ;
1372 my $sync_pulse = _read $sync_reader_fd ;
1373 _close $sync_reader_fd ;
1374
1375 if ( ! defined $sync_pulse || length $sync_pulse ) {
1376 if ( waitpid( $kid->{PID}, 0 ) >= 0 ) {
1377 $kid->{RESULT} = $? ;
1378 }
1379 else {
1380 $kid->{RESULT} = -1 ;
1381 }
1382 $sync_pulse =
1383 "error reading synchronization pipe for $kid->{NUM}, pid $kid->{PID}"
1384 unless length $sync_pulse ;
1385 croak $sync_pulse ;
1386 }
1387 return $kid->{PID} ;
1388
1389 ## Wait for pty to get set up. This is a hack until we get synchronous
1390 ## selects.
1391 if ( keys %{$self->{PTYS}} && $IO::Pty::VERSION < 0.9 ) {
1392 _debug "sleeping to give pty a chance to init, will fix when newer IO::Pty arrives." ;
1393 sleep 1 ;
1394 }
1395 }
1396
1397
1398 sub _write {
1399 confess 'undef' unless defined $_[0] && defined $_[1] ;
1400 my $r = POSIX::write( $_[0], $_[1], length $_[1] ) ;
1401 croak "$!: write( $_[0], '$_[1]' )" unless $r ;
1402 _debug "write( $_[0], '$_[1]' ) = $r" if _debugging_data ;
1403 return $r ;
1404 }
1405
1406
1407 =item run
1408
1409 Run takes a harness or harness specification and runs it, pumping
1410 all input to the child(ren), closing the input pipes when no more
1411 input is available, collecting all output that arrives, until the
1412 pipes delivering output are closed, then waiting for the children to
1413 exit and reaping their result codes.
1414
1415 You may think of C<run( ... )> as being like
1416
1417 start( ... )->finish() ;
1418
1419 , though there is one subtle difference: run() does not
1420 set \$input_scalars to '' like finish() does. If an exception is thrown
1421 from run(), all children will be killed off "gently", and then "annihilated"
1422 if they do not go gently (in to that dark night. sorry).
1423
1424 If any exceptions are thrown, this does a L</kill_kill> before propogating
1425 them.
1426
1427 =cut
1428
1429 use vars qw( $in_run ); ## No, not Enron ;)
1430
1431 sub run {
1432 local $in_run = 1; ## Allow run()-only optimizations.
1433 my IPC::Run $self = start( @_ );
1434 my $r = eval {
1435 $self->{clear_ins} = 0 ;
1436 $self->finish ;
1437 } ;
1438 if ( $@ ) {
1439 my $x = $@ ;
1440 $self->kill_kill ;
1441 die $x ;
1442 }
1443 return $r ;
1444 }
1445
1446
1447 =item signal
1448
1449 ## To send it a specific signal by name ("USR1"):
1450 signal $h, "USR1" ;
1451 $h->signal ( "USR1" ) ;
1452
1453 If $signal is provided and defined, sends a signal to all child processes. Try
1454 not to send numeric signals, use C<"KILL"> instead of C<9>, for instance.
1455 Numeric signals aren't portable.
1456
1457 Throws an exception if $signal is undef.
1458
1459 This will I<not> clean up the harness, C<finish> it if you kill it.
1460
1461 Normally TERM kills a process gracefully (this is what the command line utility
1462 C<kill> does by default), INT is sent by one of the keys C<^C>, C<Backspace> or
1463 C<E<lt>DelE<gt>>, and C<QUIT> is used to kill a process and make it coredump.
1464
1465 The C<HUP> signal is often used to get a process to "restart", rereading
1466 config files, and C<USR1> and C<USR2> for really application-specific things.
1467
1468 Often, running C<kill -l> (that's a lower case "L") on the command line will
1469 list the signals present on your operating system.
1470
1471 B<WARNING>: The signal subsystem is not at all portable. We *may* offer
1472 to simulate C<TERM> and C<KILL> on some operating systems, submit code
1473 to me if you want this.
1474
1475 B<WARNING 2>: Up to and including perl v5.6.1, doing almost anything in a
1476 signal handler could be dangerous. The most safe code avoids all
1477 mallocs and system calls, usually by preallocating a flag before
1478 entering the signal handler, altering the flag's value in the
1479 handler, and responding to the changed value in the main system:
1480
1481 my $got_usr1 = 0 ;
1482 sub usr1_handler { ++$got_signal }
1483
1484 $SIG{USR1} = \&usr1_handler ;
1485 while () { sleep 1 ; print "GOT IT" while $got_usr1-- ; }
1486
1487 Even this approach is perilous if ++ and -- aren't atomic on your system
1488 (I've never heard of this on any modern CPU large enough to run perl).
1489
1490 =cut
1491
1492 sub signal {
1493 my IPC::Run $self = shift ;
1494
1495 local $cur_self = $self ;
1496
1497 $self->_kill_kill_kill_pussycat_kill unless @_ ;
1498
1499 Carp::cluck "Ignoring extra parameters passed to kill()" if @_ > 1 ;
1500
1501 my ( $signal ) = @_ ;
1502 croak "Undefined signal passed to signal" unless defined $signal ;
1503 for ( grep $_->{PID} && ! defined $_->{RESULT}, @{$self->{KIDS}} ) {
1504 _debug "sending $signal to $_->{PID}"
1505 if _debugging;
1506 kill $signal, $_->{PID}
1507 or _debugging && _debug "$! sending $signal to $_->{PID}" ;
1508 }
1509
1510 return ;
1511 }
1512
1513
1514 =item kill_kill
1515
1516 ## To kill off a process:
1517 $h->kill_kill ;
1518 kill_kill $h ;
1519
1520 ## To specify the grace period other than 30 seconds:
1521 kill_kill $h, grace => 5 ;
1522
1523 ## To send QUIT instead of KILL if a process refuses to die:
1524 kill_kill $h, coup_d_grace => "QUIT" ;
1525
1526 Sends a C<TERM>, waits for all children to exit for up to 30 seconds, then
1527 sends a C<KILL> to any that survived the C<TERM>.
1528
1529 Will wait for up to 30 more seconds for the OS to sucessfully C<KILL> the
1530 processes.
1531
1532 The 30 seconds may be overriden by setting the C<grace> option, this
1533 overrides both timers.
1534
1535 The harness is then cleaned up.
1536
1537 The doubled name indicates that this function may kill again and avoids
1538 colliding with the core Perl C<kill> function.
1539
1540 Returns a 1 if the C<TERM> was sufficient, or a 0 if C<KILL> was
1541 required. Throws an exception if C<KILL> did not permit the children
1542 to be reaped.
1543
1544 B<NOTE>: The grace period is actually up to 1 second longer than that
1545 given. This is because the granularity of C<time> is 1 second. Let me
1546 know if you need finer granularity, we can leverage Time::HiRes here.
1547
1548 B<Win32>: Win32 does not know how to send real signals, so C<TERM> is
1549 a full-force kill on Win32. Thus all talk of grace periods, etc. do
1550 not apply to Win32.
1551
1552 =cut
1553
1554 sub kill_kill {
1555 my IPC::Run $self = shift ;
1556
1557 my %options = @_ ;
1558 my $grace = $options{grace} ;
1559 $grace = 30 unless defined $grace ;
1560 ++$grace ; ## Make grace time a _minimum_
1561
1562 my $coup_d_grace = $options{coup_d_grace} ;
1563 $coup_d_grace = "KILL" unless defined $coup_d_grace ;
1564
1565 delete $options{$_} for qw( grace coup_d_grace ) ;
1566 Carp::cluck "Ignoring unknown options for kill_kill: ",
1567 join " ",keys %options
1568 if keys %options ;
1569
1570 $self->signal( "TERM" ) ;
1571
1572 my $quitting_time = time + $grace ;
1573 my $delay = 0.01 ;
1574 my $accum_delay ;
1575
1576 my $have_killed_before ;
1577
1578 while () {
1579 ## delay first to yeild to other processes
1580 select undef, undef, undef, $delay ;
1581 $accum_delay += $delay ;
1582
1583 $self->reap_nb ;
1584 last unless $self->_running_kids ;
1585
1586 if ( $accum_delay >= $grace*0.8 ) {
1587 ## No point in checking until delay has grown some.
1588 if ( time >= $quitting_time ) {
1589 if ( ! $have_killed_before ) {
1590 $self->signal( $coup_d_grace ) ;
1591 $have_killed_before = 1 ;
1592 $quitting_time += $grace ;
1593 $delay = 0.01 ;
1594 $accum_delay = 0 ;
1595 next ;
1596 }
1597 croak "Unable to reap all children, even after KILLing them"
1598 }
1599 }
1600
1601 $delay *= 2 ;
1602 $delay = 0.5 if $delay >= 0.5 ;
1603 }
1604
1605 $self->_cleanup ;
1606 return $have_killed_before ;
1607 }
1608
1609
1610 =item harness
1611
1612 Takes a harness specification and returns a harness. This harness is
1613 blessed in to IPC::Run, allowing you to use method call syntax for
1614 run(), start(), et al if you like.
1615
1616 harness() is provided so that you can pre-build harnesses if you
1617 would like to, but it's not required..
1618
1619 You may proceed to run(), start() or pump() after calling harness() (pump()
1620 calls start() if need be). Alternatively, you may pass your
1621 harness specification to run() or start() and let them harness() for
1622 you. You can't pass harness specifications to pump(), though.
1623
1624 =cut
1625
1626 ##
1627 ## Notes: I've avoided handling a scalar that doesn't look like an
1628 ## opcode as a here document or as a filename, though I could DWIM
1629 ## those. I'm not sure that the advantages outweight the danger when
1630 ## the DWIMer guesses wrong.
1631 ##
1632 ## TODO: allow user to spec default shell. Hmm, globally, in the
1633 ## lexical scope hash, or per instance? 'Course they can do that
1634 ## now by using a [...] to hold the command.
1635 ##
1636 my $harness_id = 0 ;
1637 sub harness {
1638 my $options ;
1639 if ( @_ && ref $_[-1] eq 'HASH' ) {
1640 $options = pop ;
1641 require Data::Dumper ;
1642 carp "Passing in options as a hash is deprecated:\n", Data::Dumper::Dumper( $options ) ;
1643 }
1644
1645 # local $IPC::Run::debug = $options->{debug}
1646 # if $options && defined $options->{debug} ;
1647
1648 my @args ;
1649
1650 if ( @_ == 1 && ! ref $_[0] ) {
1651 if ( Win32_MODE ) {
1652 @args = ( [ qw( command /c ), win32_parse_cmd_line $_[0] ] ) ;
1653 }
1654 else {
1655 @args = ( [ qw( sh -c ), @_ ] ) ;
1656 }
1657 }
1658 elsif ( @_ > 1 && ! grep ref $_, @_ ) {
1659 @args = ( [ @_ ] ) ;
1660 }
1661 else {
1662 @args = @_ ;
1663 }
1664
1665 my @errs ; # Accum errors, emit them when done.
1666
1667 my $succinct ; # set if no redir ops are required yet. Cleared
1668 # if an op is seen.
1669
1670 my $cur_kid ; # references kid or handle being parsed
1671
1672 my $assumed_fd = 0 ; # fd to assume in succinct mode (no redir ops)
1673 my $handle_num = 0 ; # 1... is which handle we're parsing
1674
1675 my IPC::Run $self = bless {}, __PACKAGE__;
1676
1677 local $cur_self = $self ;
1678
1679 $self->{ID} = ++$harness_id ;
1680 $self->{IOS} = [] ;
1681 $self->{KIDS} = [] ;
1682 $self->{PIPES} = [] ;
1683 $self->{PTYS} = {} ;
1684 $self->{STATE} = _newed ;
1685
1686 if ( $options ) {
1687 $self->{$_} = $options->{$_}
1688 for keys %$options ;
1689 }
1690
1691 _debug "****** harnessing *****" if _debugging;
1692
1693 my $first_parse ;
1694 local $_ ;
1695 my $arg_count = @args ;
1696 while ( @args ) { for ( shift @args ) {
1697 eval {
1698 $first_parse = 1 ;
1699 _debug(
1700 "parsing ",
1701 defined $_
1702 ? ref $_ eq 'ARRAY'
1703 ? ( '[ ', join( ', ', map "'$_'", @$_ ), ' ]' )
1704 : ( ref $_
1705 || ( length $_ < 50
1706 ? "'$_'"
1707 : join( '', "'", substr( $_, 0, 10 ), "...'" )
1708 )
1709 )
1710 : '<undef>'
1711 ) if _debugging;
1712
1713 REPARSE:
1714 if ( ref eq 'ARRAY' || ( ! $cur_kid && ref eq 'CODE' ) ) {
1715 croak "Process control symbol ('|', '&') missing" if $cur_kid ;
1716 croak "Can't spawn a subroutine on Win32"
1717 if Win32_MODE && ref eq "CODE" ;
1718 $cur_kid = {
1719 TYPE => 'cmd',
1720 VAL => $_,
1721 NUM => @{$self->{KIDS}} + 1,
1722 OPS => [],
1723 PID => '',
1724 RESULT => undef,
1725 } ;
1726 push @{$self->{KIDS}}, $cur_kid ;
1727 $succinct = 1 ;
1728 }
1729
1730 elsif ( isa( $_, 'IPC::Run::IO' ) ) {
1731 push @{$self->{IOS}}, $_ ;
1732 $cur_kid = undef ;
1733 $succinct = 1 ;
1734 }
1735
1736 elsif ( isa( $_, 'IPC::Run::Timer' ) ) {
1737 push @{$self->{TIMERS}}, $_ ;
1738 $cur_kid = undef ;
1739 $succinct = 1 ;
1740 }
1741
1742 elsif ( /^(\d*)>&(\d+)$/ ) {
1743 croak "No command before '$_'" unless $cur_kid ;
1744 push @{$cur_kid->{OPS}}, {
1745 TYPE => 'dup',
1746 KFD1 => $2,
1747 KFD2 => length $1 ? $1 : 1,
1748 } ;
1749 _debug "redirect operators now required" if _debugging_details ;
1750 $succinct = ! $first_parse ;
1751 }
1752
1753 elsif ( /^(\d*)<&(\d+)$/ ) {
1754 croak "No command before '$_'" unless $cur_kid ;
1755 push @{$cur_kid->{OPS}}, {
1756 TYPE => 'dup',
1757 KFD1 => $2,
1758 KFD2 => length $1 ? $1 : 0,
1759 } ;
1760 $succinct = ! $first_parse ;
1761 }
1762
1763 elsif ( /^(\d*)<&-$/ ) {
1764 croak "No command before '$_'" unless $cur_kid ;
1765 push @{$cur_kid->{OPS}}, {
1766 TYPE => 'close',
1767 KFD => length $1 ? $1 : 0,
1768 } ;
1769 $succinct = ! $first_parse ;
1770 }
1771
1772 elsif (
1773 /^(\d*) (<pipe)() () () $/x
1774 || /^(\d*) (<pty) ((?:\s+\S+)?) (<) () $/x
1775 || /^(\d*) (<) () () (.*)$/x
1776 ) {
1777 croak "No command before '$_'" unless $cur_kid ;
1778
1779 $succinct = ! $first_parse ;
1780
1781 my $type = $2 . $4 ;
1782
1783 my $kfd = length $1 ? $1 : 0 ;
1784
1785 my $pty_id ;
1786 if ( $type eq '<pty<' ) {
1787 $pty_id = length $3 ? $3 : '0' ;
1788 ## do the require here to cause early error reporting
1789 require IO::Pty ;
1790 ## Just flag the pyt's existence for now. It'll be
1791 ## converted to a real IO::Pty by _open_pipes.
1792 $self->{PTYS}->{$pty_id} = undef ;
1793 }
1794
1795 my $source = $5 ;
1796
1797 my @filters ;
1798 my $binmode ;
1799
1800 unless ( length $source ) {
1801 if ( ! $succinct ) {
1802 while ( @args > 1
1803 && (
1804 ( ref $args[1] && ! isa $args[1], "IPC::Run::Timer" )
1805 || isa $args[0], "IPC::Run::binmode_pseudo_filter"
1806 )
1807 ) {
1808 if ( isa $args[0], "IPC::Run::binmode_pseudo_filter" ) {
1809 $binmode = shift( @args )->() ;
1810 }
1811 else {
1812 push @filters, shift @args
1813 }
1814 }
1815 }
1816 $source = shift @args ;
1817 croak "'$_' missing a source" if _empty $source ;
1818
1819 _debug(
1820 'Kid ', $cur_kid->{NUM}, "'s input fd ", $kfd,
1821 ' has ', scalar( @filters ), ' filters.'
1822 ) if _debugging_details && @filters ;
1823 } ;
1824
1825 my IPC::Run::IO $pipe = IPC::Run::IO->_new_internal(
1826 $type, $kfd, $pty_id, $source, $binmode, @filters
1827 ) ;
1828
1829 if ( ( ref $source eq 'GLOB' || isa $source, 'IO::Handle' )
1830 && $type !~ /^<p(ty<|ipe)$/
1831 ) {
1832 _debug "setting DONT_CLOSE" if _debugging_details ;
1833 $pipe->{DONT_CLOSE} = 1 ; ## this FD is not closed by us.
1834 _dont_inherit( $source ) if Win32_MODE ;
1835 }
1836
1837 push @{$cur_kid->{OPS}}, $pipe ;
1838 }
1839
1840 elsif ( /^() (>>?) (&) () (.*)$/x
1841 || /^() (&) (>pipe) () () $/x
1842 || /^() (>pipe)(&) () () $/x
1843 || /^(\d*)() (>pipe) () () $/x
1844 || /^() (&) (>pty) ( \w*)> () $/x
1845 ## TODO: || /^() (>pty) (\d*)> (&) () $/x
1846 || /^(\d*)() (>pty) ( \w*)> () $/x
1847 || /^() (&) (>>?) () (.*)$/x
1848 || /^(\d*)() (>>?) () (.*)$/x
1849 ) {
1850 croak "No command before '$_'" unless $cur_kid ;
1851
1852 $succinct = ! $first_parse ;
1853
1854 my $type = (
1855 $2 eq '>pipe' || $3 eq '>pipe'
1856 ? '>pipe'
1857 : $2 eq '>pty' || $3 eq '>pty'
1858 ? '>pty>'
1859 : '>'
1860 ) ;
1861 my $kfd = length $1 ? $1 : 1 ;
1862 my $trunc = ! ( $2 eq '>>' || $3 eq '>>' ) ;
1863 my $pty_id = (
1864 $2 eq '>pty' || $3 eq '>pty'
1865 ? length $4 ? $4 : 0
1866 : undef
1867 ) ;
1868
1869 my $stderr_too =
1870 $2 eq '&'
1871 || $3 eq '&'
1872 || ( ! length $1 && substr( $type, 0, 4 ) eq '>pty' ) ;
1873
1874 my $dest = $5 ;
1875 my @filters ;
1876 my $binmode = 0 ;
1877 unless ( length $dest ) {
1878 if ( ! $succinct ) {
1879 ## unshift...shift: '>' filters source...sink left...right
1880 while ( @args > 1
1881 && (
1882 ( ref $args[1] && ! isa $args[1], "IPC::Run::Timer" )
1883 || isa $args[0], "IPC::Run::binmode_pseudo_filter"
1884 )
1885 ) {
1886 if ( isa $args[0], "IPC::Run::binmode_pseudo_filter" ) {
1887 $binmode = shift( @args )->() ;
1888 }
1889 else {
1890 unshift @filters, shift @args ;
1891 }
1892 }
1893 }
1894
1895 $dest = shift @args ;
1896
1897 _debug(
1898 'Kid ', $cur_kid->{NUM}, "'s output fd ", $kfd,
1899 ' has ', scalar( @filters ), ' filters.'
1900 ) if _debugging_details && @filters ;
1901
1902 if ( $type eq '>pty>' ) {
1903 ## do the require here to cause early error reporting
1904 require IO::Pty ;
1905 ## Just flag the pyt's existence for now. _open_pipes()
1906 ## will new an IO::Pty for each key.
1907 $self->{PTYS}->{$pty_id} = undef ;
1908 }
1909 }
1910
1911 croak "'$_' missing a destination" if _empty $dest ;
1912 my $pipe = IPC::Run::IO->_new_internal(
1913 $type, $kfd, $pty_id, $dest, $binmode, @filters
1914 ) ;
1915 $pipe->{TRUNC} = $trunc ;
1916
1917 if ( ( isa( $dest, 'GLOB' ) || isa( $dest, 'IO::Handle' ) )
1918 && $type !~ /^>(pty>|pipe)$/
1919 ) {
1920 _debug "setting DONT_CLOSE" if _debugging_details ;
1921 $pipe->{DONT_CLOSE} = 1 ; ## this FD is not closed by us.
1922 }
1923 push @{$cur_kid->{OPS}}, $pipe ;
1924 push @{$cur_kid->{OPS}}, {
1925 TYPE => 'dup',
1926 KFD1 => 1,
1927 KFD2 => 2,
1928 } if $stderr_too ;
1929 }
1930
1931 elsif ( $_ eq "|" ) {
1932 croak "No command before '$_'" unless $cur_kid ;
1933 unshift @{$cur_kid->{OPS}}, {
1934 TYPE => '|',
1935 KFD => 1,
1936 } ;
1937 $succinct = 1 ;
1938 $assumed_fd = 1 ;
1939 $cur_kid = undef ;
1940 }
1941
1942 elsif ( $_ eq "&" ) {
1943 croak "No command before '$_'" unless $cur_kid ;
1944 unshift @{$cur_kid->{OPS}}, {
1945 TYPE => 'close',
1946 KFD => 0,
1947 } ;
1948 $succinct = 1 ;
1949 $assumed_fd = 0 ;
1950 $cur_kid = undef ;
1951 }
1952
1953 elsif ( $_ eq 'init' ) {
1954 croak "No command before '$_'" unless $cur_kid ;
1955 push @{$cur_kid->{OPS}}, {
1956 TYPE => 'init',
1957 SUB => shift @args,
1958 } ;
1959 }
1960
1961 elsif ( ! ref $_ ) {
1962 $self->{$_} = shift @args;
1963 }
1964
1965 elsif ( $_ eq 'init' ) {
1966 croak "No command before '$_'" unless $cur_kid ;
1967 push @{$cur_kid->{OPS}}, {
1968 TYPE => 'init',
1969 SUB => shift @args,
1970 } ;
1971 }
1972
1973 elsif ( $succinct && $first_parse ) {
1974 ## It's not an opcode, and no explicit opcodes have been
1975 ## seen yet, so assume it's a file name.
1976 unshift @args, $_ ;
1977 if ( ! $assumed_fd ) {
1978 $_ = "$assumed_fd<",
1979 }
1980 else {
1981 $_ = "$assumed_fd>",
1982 }
1983 _debug "assuming '", $_, "'" if _debugging_details ;
1984 ++$assumed_fd ;
1985 $first_parse = 0 ;
1986 goto REPARSE ;
1987 }
1988
1989 else {
1990 croak join(
1991 '',
1992 'Unexpected ',
1993 ( ref() ? $_ : 'scalar' ),
1994 ' in harness() parameter ',
1995 $arg_count - @args
1996 ) ;
1997 }
1998 } ;
1999 if ( $@ ) {
2000 push @errs, $@ ;
2001 _debug 'caught ', $@ if _debugging;
2002 }
2003 } }
2004
2005 die join( '', @errs ) if @errs ;
2006
2007
2008 $self->{STATE} = _harnessed ;
2009 # $self->timeout( $options->{timeout} ) if exists $options->{timeout} ;
2010 return $self ;
2011 }
2012
2013
2014 sub _open_pipes {
2015 my IPC::Run $self = shift ;
2016
2017 my @errs ;
2018
2019 my @close_on_fail ;
2020
2021 ## When a pipe character is seen, a pipe is created. $pipe_read_fd holds
2022 ## the dangling read end of the pipe until we get to the next process.
2023 my $pipe_read_fd ;
2024
2025 ## Output descriptors for the last command are shared by all children.
2026 ## @output_fds_accum accumulates the current set of output fds.
2027 my @output_fds_accum ;
2028
2029 for ( sort keys %{$self->{PTYS}} ) {
2030 _debug "opening pty '", $_, "'" if _debugging_details ;
2031 my $pty = _pty ;
2032 $self->{PTYS}->{$_} = $pty ;
2033 }
2034
2035 for ( @{$self->{IOS}} ) {
2036 eval { $_->init ; } ;
2037 if ( $@ ) {
2038 push @errs, $@ ;
2039 _debug 'caught ', $@ if _debugging;
2040 }
2041 else {
2042 push @close_on_fail, $_ ;
2043 }
2044 }
2045
2046 ## Loop through the kids and their OPS, interpreting any that require
2047 ## parent-side actions.
2048 for my $kid ( @{$self->{KIDS}} ) {
2049 unless ( ref $kid->{VAL} eq 'CODE' ) {
2050 $kid->{PATH} = _search_path $kid->{VAL}->[0] ;
2051 }
2052 if ( defined $pipe_read_fd ) {
2053 _debug "placing write end of pipe on kid $kid->{NUM}'s stdin"
2054 if _debugging_details ;
2055 unshift @{$kid->{OPS}}, {
2056 TYPE => 'PIPE', ## Prevent next loop from triggering on this
2057 KFD => 0,
2058 TFD => $pipe_read_fd,
2059 } ;
2060 $pipe_read_fd = undef ;
2061 }
2062 @output_fds_accum = () ;
2063 for my $op ( @{$kid->{OPS}} ) {
2064 # next if $op->{IS_DEBUG} ;
2065 my $ok = eval {
2066 if ( $op->{TYPE} eq '<' ) {
2067 my $source = $op->{SOURCE};
2068 if ( ! ref $source ) {
2069 _debug(
2070 "kid ", $kid->{NUM}, " to read ", $op->{KFD},
2071 " from '" . $source, "' (read only)"
2072 ) if _debugging_details ;
2073 croak "simulated open failure"
2074 if $self->{_simulate_open_failure} ;
2075 $op->{TFD} = _sysopen( $source, O_RDONLY ) ;
2076 push @close_on_fail, $op->{TFD} ;
2077 }
2078 elsif ( isa( $source, 'GLOB' )
2079 || isa( $source, 'IO::Handle' )
2080 ) {
2081 croak
2082 "Unopened filehandle in input redirect for $op->{KFD}"
2083 unless defined fileno $source ;
2084 $op->{TFD} = fileno $source ;
2085 _debug(
2086 "kid ", $kid->{NUM}, " to read ", $op->{KFD},
2087 " from fd ", $op->{TFD}
2088 ) if _debugging_details ;
2089 }
2090 elsif ( isa( $source, 'SCALAR' ) ) {
2091 _debug(
2092 "kid ", $kid->{NUM}, " to read ", $op->{KFD},
2093 " from SCALAR"
2094 ) if _debugging_details ;
2095
2096 $op->open_pipe( $self->_debug_fd ) ;
2097 push @close_on_fail, $op->{KFD}, $op->{FD} ;
2098
2099 my $s = '' ;
2100 $op->{KIN_REF} = \$s ;
2101 }
2102 elsif ( isa( $source, 'CODE' ) ) {
2103 _debug(
2104 'kid ', $kid->{NUM}, ' to read ', $op->{KFD}, ' from CODE'
2105 ) if _debugging_details ;
2106
2107 $op->open_pipe( $self->_debug_fd ) ;
2108 push @close_on_fail, $op->{KFD}, $op->{FD} ;
2109
2110 my $s = '' ;
2111 $op->{KIN_REF} = \$s ;
2112 }
2113 else {
2114 croak(
2115 "'"
2116 . ref( $source )
2117 . "' not allowed as a source for input redirection"
2118 ) ;
2119 }
2120 $op->_init_filters ;
2121 }
2122 elsif ( $op->{TYPE} eq '<pipe' ) {
2123 _debug(
2124 'kid to read ', $op->{KFD},
2125 ' from a pipe IPC::Run opens and returns',
2126 ) if _debugging_details ;
2127
2128 my ( $r, $w ) = $op->open_pipe( $self->_debug_fd, $op->{SOURCE} ) ;
2129 _debug "caller will write to ", fileno $op->{SOURCE}
2130 if _debugging_details;
2131
2132 $op->{TFD} = $r ;
2133 $op->{FD} = undef ; # we don't manage this fd
2134 $op->_init_filters ;
2135 }
2136 elsif ( $op->{TYPE} eq '<pty<' ) {
2137 _debug(
2138 'kid to read ', $op->{KFD}, " from pty '", $op->{PTY_ID}, "'",
2139 ) if _debugging_details ;
2140
2141 for my $source ( $op->{SOURCE} ) {
2142 if ( isa( $source, 'SCALAR' ) ) {
2143 _debug(
2144 "kid ", $kid->{NUM}, " to read ", $op->{KFD},
2145 " from SCALAR via pty '", $op->{PTY_ID}, "'"
2146 ) if _debugging_details ;
2147
2148 my $s = '' ;
2149 $op->{KIN_REF} = \$s ;
2150 }
2151 elsif ( isa( $source, 'CODE' ) ) {
2152 _debug(
2153 "kid ", $kid->{NUM}, " to read ", $op->{KFD},
2154 " from CODE via pty '", $op->{PTY_ID}, "'"
2155 ) if _debugging_details ;
2156 my $s = '' ;
2157 $op->{KIN_REF} = \$s ;
2158 }
2159 else {
2160 croak(
2161 "'"
2162 . ref( $source )
2163 . "' not allowed as a source for '<pty<' redirection"
2164 ) ;
2165 }
2166 }
2167 $op->{FD} = $self->{PTYS}->{$op->{PTY_ID}}->fileno ;
2168 $op->{TFD} = undef ; # The fd isn't known until after fork().
2169 $op->_init_filters ;
2170 }
2171 elsif ( $op->{TYPE} eq '>' ) {
2172 ## N> output redirection.
2173 my $dest = $op->{DEST} ;
2174 if ( ! ref $dest ) {
2175 _debug(
2176 "kid ", $kid->{NUM}, " to write ", $op->{KFD},
2177 " to '", $dest, "' (write only, create, ",
2178 ( $op->{TRUNC} ? 'truncate' : 'append' ),
2179 ")"
2180 ) if _debugging_details ;
2181 croak "simulated open failure"
2182 if $self->{_simulate_open_failure} ;
2183 $op->{TFD} = _sysopen(
2184 $dest,
2185 ( O_WRONLY
2186 | O_CREAT
2187 | ( $op->{TRUNC} ? O_TRUNC : O_APPEND )
2188 )
2189 ) ;
2190 if ( Win32_MODE ) {
2191 ## I have no idea why this is needed to make the current
2192 ## file position survive the gyrations TFD must go
2193 ## through...
2194 POSIX::lseek( $op->{TFD}, 0, POSIX::SEEK_END() ) ;
2195 }
2196 push @close_on_fail, $op->{TFD} ;
2197 }
2198 elsif ( isa( $dest, 'GLOB' ) ) {
2199 croak(
2200 "Unopened filehandle in output redirect, command $kid->{NUM}"
2201 ) unless defined fileno $dest ;
2202 ## Turn on autoflush, mostly just to flush out
2203 ## existing output.
2204 my $old_fh = select( $dest ) ; $| = 1 ; select( $old_fh ) ;
2205 $op->{TFD} = fileno $dest ;
2206 _debug(
2207 'kid to write ', $op->{KFD}, ' to handle ', $op->{TFD}
2208 ) if _debugging_details ;
2209 }
2210 elsif ( isa( $dest, 'SCALAR' ) ) {
2211 _debug(
2212 "kid ", $kid->{NUM}, " to write $op->{KFD} to SCALAR"
2213 ) if _debugging_details ;
2214
2215 $op->open_pipe( $self->_debug_fd ) ;
2216 push @close_on_fail, $op->{FD}, $op->{TFD} ;
2217 $$dest = '' if $op->{TRUNC} ;
2218 }
2219 elsif ( isa( $dest, 'CODE' ) ) {
2220 _debug(
2221 "kid $kid->{NUM} to write $op->{KFD} to CODE"
2222 ) if _debugging_details ;
2223
2224 $op->open_pipe( $self->_debug_fd ) ;
2225 push @close_on_fail, $op->{FD}, $op->{TFD} ;
2226 }
2227 else {
2228 croak(
2229 "'"
2230 . ref( $dest )
2231 . "' not allowed as a sink for output redirection"
2232 ) ;
2233 }
2234 $output_fds_accum[$op->{KFD}] = $op ;
2235 $op->_init_filters ;
2236 }
2237
2238 elsif ( $op->{TYPE} eq '>pipe' ) {
2239 ## N> output redirection to a pipe we open, but don't select()
2240 ## on.
2241 _debug(
2242 "kid ", $kid->{NUM}, " to write ", $op->{KFD},
2243 ' to a pipe IPC::Run opens and returns'
2244 ) if _debugging_details ;
2245
2246 my ( $r, $w ) = $op->open_pipe( $self->_debug_fd, $op->{DEST} ) ;
2247 _debug "caller will read from ", fileno $op->{DEST}
2248 if _debugging_details ;
2249
2250 $op->{TFD} = $w ;
2251 $op->{FD} = undef ; # we don't manage this fd
2252 $op->_init_filters ;
2253
2254 $output_fds_accum[$op->{KFD}] = $op ;
2255 }
2256 elsif ( $op->{TYPE} eq '>pty>' ) {
2257 my $dest = $op->{DEST} ;
2258 if ( isa( $dest, 'SCALAR' ) ) {
2259 _debug(
2260 "kid ", $kid->{NUM}, " to write ", $op->{KFD},
2261 " to SCALAR via pty '", $op->{PTY_ID}, "'"
2262 ) if _debugging_details ;
2263
2264 $$dest = '' if $op->{TRUNC} ;
2265 }
2266 elsif ( isa( $dest, 'CODE' ) ) {
2267 _debug(
2268 "kid ", $kid->{NUM}, " to write ", $op->{KFD},
2269 " to CODE via pty '", $op->{PTY_ID}, "'"
2270 ) if _debugging_details ;
2271 }
2272 else {
2273 croak(
2274 "'"
2275 . ref( $dest )
2276 . "' not allowed as a sink for output redirection"
2277 ) ;
2278 }
2279
2280 $op->{FD} = $self->{PTYS}->{$op->{PTY_ID}}->fileno ;
2281 $op->{TFD} = undef ; # The fd isn't known until after fork().
2282 $output_fds_accum[$op->{KFD}] = $op ;
2283 $op->_init_filters ;
2284 }
2285 elsif ( $op->{TYPE} eq '|' ) {
2286 _debug(
2287 "pipelining $kid->{NUM} and "
2288 . ( $kid->{NUM} + 1 )
2289 ) if _debugging_details ;
2290 ( $pipe_read_fd, $op->{TFD} ) = _pipe ;
2291 if ( Win32_MODE ) {
2292 _dont_inherit( $pipe_read_fd ) ;
2293 _dont_inherit( $op->{TFD} ) ;
2294 }
2295 @output_fds_accum = () ;
2296 }
2297 elsif ( $op->{TYPE} eq '&' ) {
2298 @output_fds_accum = () ;
2299 } # end if $op->{TYPE} tree
2300 1;
2301 } ; # end eval
2302 unless ( $ok ) {
2303 push @errs, $@ ;
2304 _debug 'caught ', $@ if _debugging;
2305 }
2306 } # end for ( OPS }
2307 }
2308
2309 if ( @errs ) {
2310 for ( @close_on_fail ) {
2311 _close( $_ ) ;
2312 $_ = undef ;
2313 }
2314 for ( keys %{$self->{PTYS}} ) {
2315 next unless $self->{PTYS}->{$_} ;
2316 close $self->{PTYS}->{$_} ;
2317 $self->{PTYS}->{$_} = undef ;
2318 }
2319 die join( '', @errs )
2320 }
2321
2322 ## give all but the last child all of the output file descriptors
2323 ## These will be reopened (and thus rendered useless) if the child
2324 ## dup2s on to these descriptors, since we unshift these. This way
2325 ## each process emits output to the same file descriptors that the
2326 ## last child will write to. This is probably not quite correct,
2327 ## since each child should write to the file descriptors inherited
2328 ## from the parent.
2329 ## TODO: fix the inheritance of output file descriptors.
2330 ## NOTE: This sharing of OPS among kids means that we can't easily put
2331 ## a kid number in each OPS structure to ping the kid when all ops
2332 ## have closed (when $self->{PIPES} has emptied). This means that we
2333 ## need to scan the KIDS whenever @{$self->{PIPES}} is empty to see
2334 ## if there any of them are still alive.
2335 for ( my $num = 0 ; $num < $#{$self->{KIDS}} ; ++$num ) {
2336 for ( reverse @output_fds_accum ) {
2337 next unless defined $_ ;
2338 _debug(
2339 'kid ', $self->{KIDS}->[$num]->{NUM}, ' also to write ', $_->{KFD},
2340 ' to ', ref $_->{DEST}
2341 ) if _debugging_details ;
2342 unshift @{$self->{KIDS}->[$num]->{OPS}}, $_ ;
2343 }
2344 }
2345
2346 ## Open the debug pipe if we need it
2347 ## Create the list of PIPES we need to scan and the bit vectors needed by
2348 ## select(). Do this first so that _cleanup can _clobber() them if an
2349 ## exception occurs.
2350 @{$self->{PIPES}} = () ;
2351 $self->{RIN} = '' ;
2352 $self->{WIN} = '' ;
2353 $self->{EIN} = '' ;
2354 ## PIN is a vec()tor that indicates who's paused.
2355 $self->{PIN} = '' ;
2356 for my $kid ( @{$self->{KIDS}} ) {
2357 for ( @{$kid->{OPS}} ) {
2358 if ( defined $_->{FD} ) {
2359 _debug(
2360 'kid ', $kid->{NUM}, '[', $kid->{PID}, "]'s ", $_->{KFD},
2361 ' is my ', $_->{FD}
2362 ) if _debugging_details ;
2363 vec( $self->{ $_->{TYPE} =~ /^</ ? 'WIN' : 'RIN' }, $_->{FD}, 1 ) = 1 ;
2364 # vec( $self->{EIN}, $_->{FD}, 1 ) = 1 ;
2365 push @{$self->{PIPES}}, $_ ;
2366 }
2367 }
2368 }
2369
2370 for my $io ( @{$self->{IOS}} ) {
2371 my $fd = $io->fileno ;
2372 vec( $self->{RIN}, $fd, 1 ) = 1 if $io->mode =~ /r/ ;
2373 vec( $self->{WIN}, $fd, 1 ) = 1 if $io->mode =~ /w/ ;
2374 # vec( $self->{EIN}, $fd, 1 ) = 1 ;
2375 push @{$self->{PIPES}}, $io ;
2376 }
2377
2378 ## Put filters on the end of the filter chains to read & write the pipes.
2379 ## Clear pipe states
2380 for my $pipe ( @{$self->{PIPES}} ) {
2381 $pipe->{SOURCE_EMPTY} = 0 ;
2382 $pipe->{PAUSED} = 0 ;
2383 if ( $pipe->{TYPE} =~ /^>/ ) {
2384 my $pipe_reader = sub {
2385 my ( undef, $out_ref ) = @_ ;
2386
2387 return undef unless defined $pipe->{FD} ;
2388 return 0 unless vec( $self->{ROUT}, $pipe->{FD}, 1 ) ;
2389
2390 vec( $self->{ROUT}, $pipe->{FD}, 1 ) = 0 ;
2391
2392 _debug_desc_fd( 'reading from', $pipe ) if _debugging_details ;
2393 my $in = eval { _read( $pipe->{FD} ) } ;
2394 if ( $@ ) {
2395 $in = '' ;
2396 ## IO::Pty throws the Input/output error if the kid dies.
2397 ## read() throws the bad file descriptor message if the
2398 ## kid dies on Win32.
2399 die $@ unless
2400 $@ =~ /^Input\/output error: read/ ||
2401 ($@ =~ /input or output/ && $^O =~ /aix/)
2402 || ( Win32_MODE && $@ =~ /Bad file descriptor/ ) ;
2403 }
2404
2405 unless ( length $in ) {
2406 $self->_clobber( $pipe ) ;
2407 return undef ;
2408 }
2409
2410 ## Protect the position so /.../g matches may be used.
2411 my $pos = pos $$out_ref ;
2412 $$out_ref .= $in ;
2413 pos( $$out_ref ) = $pos ;
2414 return 1 ;
2415 } ;
2416 ## Input filters are the last filters
2417 push @{$pipe->{FILTERS}}, $pipe_reader ;
2418 push @{$self->{TEMP_FILTERS}}, $pipe_reader ;
2419 }
2420 else {
2421 my $pipe_writer = sub {
2422 my ( $in_ref, $out_ref ) = @_ ;
2423 return undef unless defined $pipe->{FD} ;
2424 return 0
2425 unless vec( $self->{WOUT}, $pipe->{FD}, 1 )
2426 || $pipe->{PAUSED} ;
2427
2428 vec( $self->{WOUT}, $pipe->{FD}, 1 ) = 0 ;
2429
2430 if ( ! length $$in_ref ) {
2431 if ( ! defined get_more_input ) {
2432 $self->_clobber( $pipe ) ;
2433 return undef ;
2434 }
2435 }
2436
2437 unless ( length $$in_ref ) {
2438 unless ( $pipe->{PAUSED} ) {
2439 _debug_desc_fd( 'pausing', $pipe ) if _debugging_details ;
2440 vec( $self->{WIN}, $pipe->{FD}, 1 ) = 0 ;
2441 # vec( $self->{EIN}, $pipe->{FD}, 1 ) = 0 ;
2442 vec( $self->{PIN}, $pipe->{FD}, 1 ) = 1 ;
2443 $pipe->{PAUSED} = 1 ;
2444 }
2445 return 0 ;
2446 }
2447 _debug_desc_fd( 'writing to', $pipe ) if _debugging_details ;
2448
2449 my $c = _write( $pipe->{FD}, $$in_ref ) ;
2450 substr( $$in_ref, 0, $c, '' ) ;
2451 return 1 ;
2452 } ;
2453 ## Output filters are the first filters
2454 unshift @{$pipe->{FILTERS}}, $pipe_writer ;
2455 push @{$self->{TEMP_FILTERS}}, $pipe_writer ;
2456 }
2457 }
2458 }
2459
2460
2461 sub _dup2_gently {
2462 ## A METHOD, NOT A FUNCTION, NEEDS $self!
2463 my IPC::Run $self = shift ;
2464 my ( $files, $fd1, $fd2 ) = @_ ;
2465 ## Moves TFDs that are using the destination fd out of the
2466 ## way before calling _dup2
2467 for ( @$files ) {
2468 next unless defined $_->{TFD} ;
2469 $_->{TFD} = _dup( $_->{TFD} ) if $_->{TFD} == $fd2 ;
2470 }
2471 $self->{DEBUG_FD} = _dup $self->{DEBUG_FD}
2472 if defined $self->{DEBUG_FD} && $self->{DEBUG_FD} == $fd2 ;
2473
2474 _dup2_rudely( $fd1, $fd2 ) ;
2475 }
2476
2477 =item close_terminal
2478
2479 This is used as (or in) an init sub to cast off the bonds of a controlling
2480 terminal. It must precede all other redirection ops that affect
2481 STDIN, STDOUT, or STDERR to be guaranteed effective.
2482
2483 =cut
2484
2485
2486 sub close_terminal {
2487 ## Cast of the bonds of a controlling terminal
2488
2489 POSIX::setsid() || croak "POSIX::setsid() failed" ;
2490 _debug "closing stdin, out, err"
2491 if _debugging_details ;
2492 close STDIN ;
2493 close STDERR ;
2494 close STDOUT ;
2495 }
2496
2497
2498 sub _do_kid_and_exit {
2499 my IPC::Run $self = shift ;
2500 my ( $kid ) = @_ ;
2501
2502 ## For unknown reasons, placing these two statements in the eval{}
2503 ## causes the eval {} to not catch errors after they are executed in
2504 ## perl 5.6.0, godforsaken version that it is...not sure about 5.6.1.
2505 ## Part of this could be that these symbols get destructed when
2506 ## exiting the eval, and that destruction might be what's (wrongly)
2507 ## confusing the eval{}, allowing the exception to probpogate.
2508 my $s1 = gensym ;
2509 my $s2 = gensym ;
2510
2511 eval {
2512 local $cur_self = $self ;
2513
2514 _set_child_debug_name( ref $kid->{VAL} eq "CODE"
2515 ? "CODE"
2516 : basename( $kid->{VAL}->[0] )
2517 );
2518
2519 ## close parent FD's first so they're out of the way.
2520 ## Don't close STDIN, STDOUT, STDERR: they should be inherited or
2521 ## overwritten below.
2522 my @needed = $self->{noinherit} ? () : ( 1, 1, 1 ) ;
2523 $needed[ $self->{SYNC_WRITER_FD} ] = 1 ;
2524 $needed[ $self->{DEBUG_FD} ] = 1 if defined $self->{DEBUG_FD} ;
2525
2526 for ( @{$kid->{OPS}} ) {
2527 $needed[ $_->{TFD} ] = 1 if defined $_->{TFD} ;
2528 }
2529
2530 ## TODO: use the forthcoming IO::Pty to close the terminal and
2531 ## make the first pty for this child the controlling terminal.
2532 ## This will also make it so that pty-laden kids don't cause
2533 ## other kids to lose stdin/stdout/stderr.
2534 my @closed ;
2535 if ( %{$self->{PTYS}} ) {
2536 ## Clean up the parent's fds.
2537 for ( keys %{$self->{PTYS}} ) {
2538 _debug "Cleaning up parent's ptty '$_'" if _debugging_details ;
2539 my $slave = $self->{PTYS}->{$_}->slave ;
2540 $closed[ $self->{PTYS}->{$_}->fileno ] = 1 ;
2541 close $self->{PTYS}->{$_} ;
2542 $self->{PTYS}->{$_} = $slave ;
2543 }
2544
2545 close_terminal ;
2546 $closed[ $_ ] = 1 for ( 0..2 ) ;
2547 }
2548
2549 for my $sibling ( @{$self->{KIDS}} ) {
2550 for ( @{$sibling->{OPS}} ) {
2551 if ( $_->{TYPE} =~ /^.pty.$/ ) {
2552 $_->{TFD} = $self->{PTYS}->{$_->{PTY_ID}}->fileno ;
2553 $needed[$_->{TFD}] = 1 ;
2554 }
2555
2556 # for ( $_->{FD}, ( $sibling != $kid ? $_->{TFD} : () ) ) {
2557 # if ( defined $_ && ! $closed[$_] && ! $needed[$_] ) {
2558 # _close( $_ ) ;
2559 # $closed[$_] = 1 ;
2560 # $_ = undef ;
2561 # }
2562 # }
2563 }
2564 }
2565
2566 ## This is crude: we have no way of keeping track of browsing all open
2567 ## fds, so we scan to a fairly high fd.
2568 _debug "open fds: ", join " ", keys %fds if _debugging_details ;
2569 for (keys %fds) {
2570 if ( ! $closed[$_] && ! $needed[$_] ) {
2571 _close( $_ ) ;
2572 $closed[$_] = 1 ;
2573 }
2574 }
2575
2576 ## Lazy closing is so the same fd (ie the same TFD value) can be dup2'ed on
2577 ## several times.
2578 my @lazy_close ;
2579 for ( @{$kid->{OPS}} ) {
2580 if ( defined $_->{TFD} ) {
2581 unless ( $_->{TFD} == $_->{KFD} ) {
2582 $self->_dup2_gently( $kid->{OPS}, $_->{TFD}, $_->{KFD} ) ;
2583 push @lazy_close, $_->{TFD} ;
2584 }
2585 }
2586 elsif ( $_->{TYPE} eq 'dup' ) {
2587 $self->_dup2_gently( $kid->{OPS}, $_->{KFD1}, $_->{KFD2} )
2588 unless $_->{KFD1} == $_->{KFD2} ;
2589 }
2590 elsif ( $_->{TYPE} eq 'close' ) {
2591 for ( $_->{KFD} ) {
2592 if ( ! $closed[$_] ) {
2593 _close( $_ ) ;
2594 $closed[$_] = 1 ;
2595 $_ = undef ;
2596 }
2597 }
2598 }
2599 elsif ( $_->{TYPE} eq 'init' ) {
2600 $_->{SUB}->() ;
2601 }
2602 }
2603
2604 for ( @lazy_close ) {
2605 unless ( $closed[$_] ) {
2606 _close( $_ ) ;
2607 $closed[$_] = 1 ;
2608 }
2609 }
2610
2611 if ( ref $kid->{VAL} ne 'CODE' ) {
2612 open $s1, ">&=$self->{SYNC_WRITER_FD}"
2613 or croak "$! setting filehandle to fd SYNC_WRITER_FD" ;
2614 fcntl $s1, F_SETFD, 1 ;
2615
2616 if ( defined $self->{DEBUG_FD} ) {
2617 open $s2, ">&=$self->{DEBUG_FD}"
2618 or croak "$! setting filehandle to fd DEBUG_FD" ;
2619 fcntl $s2, F_SETFD, 1 ;
2620 }
2621
2622 my @cmd = ( $kid->{PATH}, @{$kid->{VAL}}[1..$#{$kid->{VAL}}] ) ;
2623 _debug 'execing ', join " ", map { /[\s"]/ ? "'$_'" : $_ } @cmd
2624 if _debugging ;
2625
2626 die "exec failed: simulating exec() failure"
2627 if $self->{_simulate_exec_failure} ;
2628
2629 _exec $kid->{PATH}, @{$kid->{VAL}}[1..$#{$kid->{VAL}}] ;
2630
2631 croak "exec failed: $!" ;
2632 }
2633 } ;
2634 if ( $@ ) {
2635 _write $self->{SYNC_WRITER_FD}, $@ ;
2636 ## Avoid DESTROY.
2637 POSIX::exit 1 ;
2638 }
2639
2640 ## We must be executing code in the child, otherwise exec() would have
2641 ## prevented us from being here.
2642 _close $self->{SYNC_WRITER_FD} ;
2643 _debug 'calling fork()ed CODE ref' if _debugging;
2644 POSIX::close $self->{DEBUG_FD} if defined $self->{DEBUG_FD} ;
2645 ## TODO: Overload CORE::GLOBAL::exit...
2646 $kid->{VAL}->() ;
2647
2648 ## There are bugs in perl closures up to and including 5.6.1
2649 ## that may keep this next line from having any effect, and it
2650 ## won't have any effect if our caller has kept a copy of it, but
2651 ## this may cause the closure to be cleaned up. Maybe.
2652 $kid->{VAL} = undef ;
2653
2654 ## Use POSIX::exit to avoid global destruction, since this might
2655 ## cause DESTROY() to be called on objects created in the parent
2656 ## and thus cause double cleanup. For instance, if DESTROY() unlinks
2657 ## a file in the child, we don't want the parent to suddenly miss
2658 ## it.
2659 POSIX::exit 0 ;
2660 }
2661
2662
2663 =item start
2664
2665 $h = start(
2666 \@cmd, \$in, \$out, ...,
2667 timeout( 30, name => "process timeout" ),
2668 $stall_timeout = timeout( 10, name => "stall timeout" ),
2669 ) ;
2670
2671 $h = start \@cmd, '<', \$in, '|', \@cmd2, ... ;
2672
2673 start() accepts a harness or harness specification and returns a harness
2674 after building all of the pipes and launching (via fork()/exec(), or, maybe
2675 someday, spawn()) all the child processes. It does not send or receive any
2676 data on the pipes, see pump() and finish() for that.
2677
2678 You may call harness() and then pass it's result to start() if you like,
2679 but you only need to if it helps you structure or tune your application.
2680 If you do call harness(), you may skip start() and proceed directly to
2681 pump.
2682
2683 start() also starts all timers in the harness. See L<IPC::Run::Timer>
2684 for more information.
2685
2686 start() flushes STDOUT and STDERR to help you avoid duplicate output.
2687 It has no way of asking Perl to flush all your open filehandles, so
2688 you are going to need to flush any others you have open. Sorry.
2689
2690 Here's how if you don't want to alter the state of $| for your
2691 filehandle:
2692
2693 $ofh = select HANDLE ; $of = $| ; $| = 1 ; $| = $of ; select $ofh;
2694
2695 If you don't mind leaving output unbuffered on HANDLE, you can do
2696 the slightly shorter
2697
2698 $ofh = select HANDLE ; $| = 1 ; select $ofh;
2699
2700 Or, you can use IO::Handle's flush() method:
2701
2702 use IO::Handle ;
2703 flush HANDLE ;
2704
2705 Perl needs the equivalent of C's fflush( (FILE *)NULL ).
2706
2707 =cut
2708
2709 sub start {
2710 # $SIG{__DIE__} = sub { my $s = shift ; Carp::cluck $s ; die $s } ;
2711 my $options ;
2712 if ( @_ && ref $_[-1] eq 'HASH' ) {
2713 $options = pop ;
2714 require Data::Dumper ;
2715 carp "Passing in options as a hash is deprecated:\n", Data::Dumper::Dumper( $options ) ;
2716 }
2717
2718 my IPC::Run $self ;
2719 if ( @_ == 1 && isa( $_[0], __PACKAGE__ ) ) {
2720 $self = shift ;
2721 $self->{$_} = $options->{$_} for keys %$options ;
2722 }
2723 else {
2724 $self = harness( @_, $options ? $options : () ) ;
2725 }
2726
2727 local $cur_self = $self ;
2728
2729 $self->kill_kill if $self->{STATE} == _started ;
2730
2731 _debug "** starting" if _debugging;
2732
2733 $_->{RESULT} = undef for @{$self->{KIDS}} ;
2734
2735 ## Assume we're not being called from &run. It will correct our
2736 ## assumption if need be. This affects whether &_select_loop clears
2737 ## input queues to '' when they're empty.
2738 $self->{clear_ins} = 1 ;
2739
2740 IPC::Run::Win32Helper::optimize $self
2741 if Win32_MODE && $in_run;
2742
2743 my @errs ;
2744
2745 for ( @{$self->{TIMERS}} ) {
2746 eval { $_->start } ;
2747 if ( $@ ) {
2748 push @errs, $@ ;
2749 _debug 'caught ', $@ if _debugging;
2750 }
2751 }
2752
2753 eval { $self->_open_pipes } ;
2754 if ( $@ ) {
2755 push @errs, $@ ;
2756 _debug 'caught ', $@ if _debugging;
2757 }
2758
2759 if ( ! @errs ) {
2760 ## This is a bit of a hack, we should do it for all open filehandles.
2761 ## Since there's no way I know of to enumerate open filehandles, we
2762 ## autoflush STDOUT and STDERR. This is done so that the children don't
2763 ## inherit output buffers chock full o' redundant data. It's really
2764 ## confusing to track that down.
2765 { my $ofh = select STDOUT ; local $| = 1 ; select $ofh; }
2766 { my $ofh = select STDERR ; local $| = 1 ; select $ofh; }
2767 for my $kid ( @{$self->{KIDS}} ) {
2768 $kid->{RESULT} = undef ;
2769 _debug "child: ",
2770 ref( $kid->{VAL} ) eq "CODE"
2771 ? "CODE ref"
2772 : (
2773 "`",
2774 join( " ", map /[^\w.-]/ ? "'$_'" : $_, @{$kid->{VAL}} ),
2775 "`"
2776 ) if _debugging_details ;
2777 eval {
2778 croak "simulated failure of fork"
2779 if $self->{_simulate_fork_failure} ;
2780 unless ( Win32_MODE ) {
2781 $self->_spawn( $kid ) ;
2782 }
2783 else {
2784 ## TODO: Test and debug spawing code. Someday.
2785 _debug(
2786 'spawning ',
2787 join(
2788 ' ',
2789 map(
2790 "'$_'",
2791 ( $kid->{PATH}, @{$kid->{VAL}}[1..$#{$kid->{VAL}}] )
2792 )
2793 )
2794 ) if _debugging;
2795 ## The external kid wouldn't know what to do with it anyway.
2796 ## This is only used by the "helper" pump processes on Win32.
2797 _dont_inherit( $self->{DEBUG_FD} ) ;
2798 ( $kid->{PID}, $kid->{PROCESS} ) =
2799 IPC::Run::Win32Helper::win32_spawn(
2800 [ $kid->{PATH}, @{$kid->{VAL}}[1..$#{$kid->{VAL}}] ],
2801 $kid->{OPS},
2802 ) ;
2803 _debug "spawn() = ", $kid->{PID} if _debugging;
2804 }
2805 } ;
2806 if ( $@ ) {
2807 push @errs, $@ ;
2808 _debug 'caught ', $@ if _debugging;
2809 }
2810 }
2811 }
2812
2813 ## Close all those temporary filehandles that the kids needed.
2814 for my $pty ( values %{$self->{PTYS}} ) {
2815 close $pty->slave ;
2816 }
2817
2818 my @closed ;
2819 for my $kid ( @{$self->{KIDS}} ) {
2820 for ( @{$kid->{OPS}} ) {
2821 my $close_it = eval {
2822 defined $_->{TFD}
2823 && ! $_->{DONT_CLOSE}
2824 && ! $closed[$_->{TFD}]
2825 && ( ! Win32_MODE || ! $_->{RECV_THROUGH_TEMP_FILE} ) ## Win32 hack
2826 } ;
2827 if ( $@ ) {
2828 push @errs, $@ ;
2829 _debug 'caught ', $@ if _debugging;
2830 }
2831 if ( $close_it || $@ ) {
2832 eval {
2833 _close( $_->{TFD} ) ;
2834 $closed[$_->{TFD}] = 1 ;
2835 $_->{TFD} = undef ;
2836 } ;
2837 if ( $@ ) {
2838 push @errs, $@ ;
2839 _debug 'caught ', $@ if _debugging;
2840 }
2841 }
2842 }
2843 }
2844 confess "gak!" unless defined $self->{PIPES} ;
2845
2846 if ( @errs ) {
2847 eval { $self->_cleanup } ;
2848 warn $@ if $@ ;
2849 die join( '', @errs ) ;
2850 }
2851
2852 $self->{STATE} = _started ;
2853 return $self ;
2854 }
2855
2856
2857 sub adopt {
2858 ## NOT FUNCTIONAL YET, NEED TO CLOSE FDS BETTER IN CHILDREN. SEE
2859 ## t/adopt.t for a test suite.
2860 my IPC::Run $self = shift ;
2861
2862 for my $adoptee ( @_ ) {
2863 push @{$self->{IOS}}, @{$adoptee->{IOS}} ;
2864 ## NEED TO RENUMBER THE KIDS!!
2865 push @{$self->{KIDS}}, @{$adoptee->{KIDS}} ;
2866 push @{$self->{PIPES}}, @{$adoptee->{PIPES}} ;
2867 $self->{PTYS}->{$_} = $adoptee->{PTYS}->{$_}
2868 for keys %{$adoptee->{PYTS}} ;
2869 push @{$self->{TIMERS}}, @{$adoptee->{TIMERS}} ;
2870 $adoptee->{STATE} = _finished ;
2871 }
2872 }
2873
2874
2875 sub _clobber {
2876 my IPC::Run $self = shift ;
2877 my ( $file ) = @_ ;
2878 _debug_desc_fd( "closing", $file ) if _debugging_details ;
2879 my $doomed = $file->{FD} ;
2880 my $dir = $file->{TYPE} =~ /^</ ? 'WIN' : 'RIN' ;
2881 vec( $self->{$dir}, $doomed, 1 ) = 0 ;
2882 # vec( $self->{EIN}, $doomed, 1 ) = 0 ;
2883 vec( $self->{PIN}, $doomed, 1 ) = 0 ;
2884 if ( $file->{TYPE} =~ /^(.)pty.$/ ) {
2885 if ( $1 eq '>' ) {
2886 ## Only close output ptys. This is so that ptys as inputs are
2887 ## never autoclosed, which would risk losing data that was
2888 ## in the slave->parent queue.
2889 _debug_desc_fd "closing pty", $file if _debugging_details ;
2890 close $self->{PTYS}->{$file->{PTY_ID}}
2891 if defined $self->{PTYS}->{$file->{PTY_ID}} ;
2892 $self->{PTYS}->{$file->{PTY_ID}} = undef ;
2893 }
2894 }
2895 elsif ( isa( $file, 'IPC::Run::IO' ) ) {
2896 $file->close unless $file->{DONT_CLOSE} ;
2897 }
2898 else {
2899 _close( $doomed ) ;
2900 }
2901
2902 @{$self->{PIPES}} = grep
2903 defined $_->{FD} && ( $_->{TYPE} ne $file->{TYPE} || $_->{FD} ne $doomed),
2904 @{$self->{PIPES}} ;
2905
2906 $file->{FD} = undef ;
2907 }
2908
2909 sub _select_loop {
2910 my IPC::Run $self = shift ;
2911
2912 my $io_occurred ;
2913
2914 my $not_forever = 0.01 ;
2915
2916 SELECT:
2917 while ( $self->pumpable ) {
2918 if ( $io_occurred && $self->{break_on_io} ) {
2919 _debug "exiting _select(): io occured and break_on_io set"
2920 if _debugging_details ;
2921 last ;
2922 }
2923
2924 my $timeout = $self->{non_blocking} ? 0 : undef ;
2925
2926 if ( @{$self->{TIMERS}} ) {
2927 my $now = time ;
2928 my $time_left ;
2929 for ( @{$self->{TIMERS}} ) {
2930 next unless $_->is_running ;
2931 $time_left = $_->check( $now ) ;
2932 ## Return when a timer expires
2933 return if defined $time_left && ! $time_left ;
2934 $timeout = $time_left
2935 if ! defined $timeout || $time_left < $timeout ;
2936 }
2937 }
2938
2939 ##
2940 ## See if we can unpause any input channels
2941 ##
2942 my $paused = 0 ;
2943
2944 for my $file ( @{$self->{PIPES}} ) {
2945 next unless $file->{PAUSED} && $file->{TYPE} =~ /^</ ;
2946
2947 _debug_desc_fd( "checking for more input", $file ) if _debugging_details ;
2948 my $did ;
2949 1 while $did = $file->_do_filters( $self ) ;
2950 if ( defined $file->{FD} && ! defined( $did ) || $did ) {
2951 _debug_desc_fd( "unpausing", $file ) if _debugging_details ;
2952 $file->{PAUSED} = 0 ;
2953 vec( $self->{WIN}, $file->{FD}, 1 ) = 1 ;
2954 # vec( $self->{EIN}, $file->{FD}, 1 ) = 1 ;
2955 vec( $self->{PIN}, $file->{FD}, 1 ) = 0 ;
2956 }
2957 else {
2958 ## This gets incremented occasionally when the IO channel
2959 ## was actually closed. That's a bug, but it seems mostly
2960 ## harmless: it causes us to exit if break_on_io, or to set
2961 ## the timeout to not be forever. I need to fix it, though.
2962 ++$paused ;
2963 }
2964 }
2965
2966 if ( _debugging_details ) {
2967 my $map = join(
2968 '',
2969 map {
2970 my $out ;
2971 $out = 'r' if vec( $self->{RIN}, $_, 1 ) ;
2972 $out = $out ? 'b' : 'w' if vec( $self->{WIN}, $_, 1 ) ;
2973 $out = 'p' if ! $out && vec( $self->{PIN}, $_, 1 ) ;
2974 $out = $out ? uc( $out ) : 'x' if vec( $self->{EIN}, $_, 1 ) ;
2975 $out = '-' unless $out ;
2976 $out ;
2977 } (0..1024)
2978 ) ;
2979 $map =~ s/((?:[a-zA-Z-]|\([^\)]*\)){12,}?)-*$/$1/ ;
2980 _debug 'fds for select: ', $map if _debugging_details ;
2981 }
2982
2983 ## _do_filters may have closed our last fd, and we need to see if
2984 ## we have I/O, or are just waiting for children to exit.
2985 my $p = $self->pumpable;
2986 last unless $p;
2987 if ( $p > 0 && ( ! defined $timeout || $timeout > 0.1 ) ) {
2988 ## No I/O will wake the select loop up, but we have children
2989 ## lingering, so we need to poll them with a short timeout.
2990 ## Otherwise, assume more input will be coming.
2991 $timeout = $not_forever ;
2992 $not_forever *= 2 ;
2993 $not_forever = 0.5 if $not_forever >= 0.5 ;
2994 }
2995
2996 ## Make sure we don't block forever in select() because inputs are
2997 ## paused.
2998 if ( ! defined $timeout && ! ( @{$self->{PIPES}} - $paused ) ) {
2999 ## Need to return if we're in pump and all input is paused, or
3000 ## we'll loop until all inputs are unpaused, which is darn near
3001 ## forever. And a day.
3002 if ( $self->{break_on_io} ) {
3003 _debug "exiting _select(): no I/O to do and timeout=forever"
3004 if _debugging;
3005 last ;
3006 }
3007
3008 ## Otherwise, assume more input will be coming.
3009 $timeout = $not_forever ;
3010 $not_forever *= 2 ;
3011 $not_forever = 0.5 if $not_forever >= 0.5 ;
3012 }
3013
3014 _debug 'timeout=', defined $timeout ? $timeout : 'forever'
3015 if _debugging_details ;
3016
3017 my $nfound ;
3018 unless ( Win32_MODE ) {
3019 $nfound = select(
3020 $self->{ROUT} = $self->{RIN},
3021 $self->{WOUT} = $self->{WIN},
3022 $self->{EOUT} = $self->{EIN},
3023 $timeout
3024 ) ;
3025 }
3026 else {
3027 my @in = map $self->{$_}, qw( RIN WIN EIN ) ;
3028 ## Win32's select() on Win32 seems to die if passed vectors of
3029 ## all 0's. Need to report this when I get back online.
3030 for ( @in ) {
3031 $_ = undef unless index( ( unpack "b*", $_ ), 1 ) >= 0 ;
3032 }
3033
3034 $nfound = select(
3035 $self->{ROUT} = $in[0],
3036 $self->{WOUT} = $in[1],
3037 $self->{EOUT} = $in[2],
3038 $timeout
3039 ) ;
3040
3041 for ( $self->{ROUT}, $self->{WOUT}, $self->{EOUT} ) {
3042 $_ = "" unless defined $_ ;
3043 }
3044 }
3045 last if ! $nfound && $self->{non_blocking} ;
3046
3047 croak "$! in select" if $nfound < 0 and $! != POSIX::EINTR;
3048 ## TODO: Analyze the EINTR failure mode and see if this patch
3049 ## is adequate and optimal.
3050 ## TODO: Add an EINTR test to the test suite.
3051
3052 if ( _debugging_details ) {
3053 my $map = join(
3054 '',
3055 map {
3056 my $out ;
3057 $out = 'r' if vec( $self->{ROUT}, $_, 1 ) ;
3058 $out = $out ? 'b' : 'w' if vec( $self->{WOUT}, $_, 1 ) ;
3059 $out = $out ? uc( $out ) : 'x' if vec( $self->{EOUT}, $_, 1 ) ;
3060 $out = '-' unless $out ;
3061 $out ;
3062 } (0..128)
3063 ) ;
3064 $map =~ s/((?:[a-zA-Z-]|\([^\)]*\)){12,}?)-*$/$1/ ;
3065 _debug "selected ", $map ;
3066 }
3067
3068 ## Need to copy since _clobber alters @{$self->{PIPES}}.
3069 ## TODO: Rethink _clobber(). Rethink $file->{PAUSED}, too.
3070 my @pipes = @{$self->{PIPES}} ;
3071 $io_occurred = $_->poll( $self ) ? 1 : $io_occurred for @pipes;
3072 # FILE:
3073 # for my $pipe ( @pipes ) {
3074 # ## Pipes can be shared among kids. If another kid closes the
3075 # ## pipe, then it's {FD} will be undef. Also, on Win32, pipes can
3076 # ## be optimized to be files, in which case the FD is left undef
3077 # ## so we don't try to select() on it.
3078 # if ( $pipe->{TYPE} =~ /^>/
3079 # && defined $pipe->{FD}
3080 # && vec( $self->{ROUT}, $pipe->{FD}, 1 )
3081 # ) {
3082 # _debug_desc_fd( "filtering data from", $pipe ) if _debugging_details ;
3083 #confess "phooey" unless isa( $pipe, "IPC::Run::IO" ) ;
3084 # $io_occurred = 1 if $pipe->_do_filters( $self ) ;
3085 #
3086 # next FILE unless defined $pipe->{FD} ;
3087 # }
3088 #
3089 # ## On Win32, pipes to the child can be optimized to be files
3090 # ## and FD left undefined so we won't select on it.
3091 # if ( $pipe->{TYPE} =~ /^</
3092 # && defined $pipe->{FD}
3093 # && vec( $self->{WOUT}, $pipe->{FD}, 1 )
3094 # ) {
3095 # _debug_desc_fd( "filtering data to", $pipe ) if _debugging_details ;
3096 # $io_occurred = 1 if $pipe->_do_filters( $self ) ;
3097 #
3098 # next FILE unless defined $pipe->{FD} ;
3099 # }
3100 #
3101 # if ( defined $pipe->{FD} && vec( $self->{EOUT}, $pipe->{FD}, 1 ) ) {
3102 # ## BSD seems to sometimes raise the exceptional condition flag
3103 # ## when a pipe is closed before we read it's last data. This
3104 # ## causes spurious warnings and generally renders the exception
3105 # ## mechanism useless for our purposes. The exception
3106 # ## flag semantics are too variable (they're device driver
3107 # ## specific) for me to easily map to any automatic action like
3108 # ## warning or croaking (try running v0.42 if you don't beleive me
3109 # ## :-).
3110 # warn "Exception on descriptor $pipe->{FD}" ;
3111 # }
3112 # }
3113 }
3114
3115 return ;
3116 }
3117
3118
3119 sub _cleanup {
3120 my IPC::Run $self = shift ;
3121 _debug "cleaning up" if _debugging_details ;
3122
3123 for ( values %{$self->{PTYS}} ) {
3124 next unless ref $_ ;
3125 eval {
3126 _debug "closing slave fd ", fileno $_->slave if _debugging_data;
3127 close $_->slave ;
3128 } ;
3129 carp $@ . " while closing ptys" if $@ ;
3130 eval {
3131 _debug "closing master fd ", fileno $_ if _debugging_data;
3132 close $_ ;
3133 } ;
3134 carp $@ . " closing ptys" if $@ ;
3135 }
3136
3137 _debug "cleaning up pipes" if _debugging_details ;
3138 ## _clobber modifies PIPES
3139 $self->_clobber( $self->{PIPES}->[0] ) while @{$self->{PIPES}} ;
3140
3141 for my $kid ( @{$self->{KIDS}} ) {
3142 _debug "cleaning up kid ", $kid->{NUM} if _debugging_details ;
3143 if ( ! length $kid->{PID} ) {
3144 _debug 'never ran child ', $kid->{NUM}, ", can't reap"
3145 if _debugging;
3146 for my $op ( @{$kid->{OPS}} ) {
3147 _close( $op->{TFD} )
3148 if defined $op->{TFD} && ! defined $op->{TEMP_FILE_HANDLE};
3149 }
3150 }
3151 elsif ( ! defined $kid->{RESULT} ) {
3152 _debug 'reaping child ', $kid->{NUM}, ' (pid ', $kid->{PID}, ')'
3153 if _debugging;
3154 my $pid = waitpid $kid->{PID}, 0 ;
3155 $kid->{RESULT} = $? ;
3156 _debug 'reaped ', $pid, ', $?=', $kid->{RESULT}
3157 if _debugging;
3158 }
3159
3160 # if ( defined $kid->{DEBUG_FD} ) {
3161 # die;
3162 # @{$kid->{OPS}} = grep
3163 # ! defined $_->{KFD} || $_->{KFD} != $kid->{DEBUG_FD},
3164 # @{$kid->{OPS}} ;
3165 # $kid->{DEBUG_FD} = undef ;
3166 # }
3167
3168 _debug "cleaning up filters" if _debugging_details ;
3169 for my $op ( @{$kid->{OPS}} ) {
3170 @{$op->{FILTERS}} = grep {
3171 my $filter = $_ ;
3172 ! grep $filter == $_, @{$self->{TEMP_FILTERS}} ;
3173 } @{$op->{FILTERS}} ;
3174 }
3175
3176 for my $op ( @{$kid->{OPS}} ) {
3177 $op->_cleanup( $self ) if UNIVERSAL::isa( $op, "IPC::Run::IO" );
3178 }
3179 }
3180 $self->{STATE} = _finished ;
3181 @{$self->{TEMP_FILTERS}} = () ;
3182 _debug "done cleaning up" if _debugging_details ;
3183
3184 POSIX::close $self->{DEBUG_FD} if defined $self->{DEBUG_FD} ;
3185 $self->{DEBUG_FD} = undef ;
3186 }
3187
3188
3189 =item pump
3190
3191 pump $h ;
3192 $h->pump ;
3193
3194 Pump accepts a single parameter harness. It blocks until it delivers some
3195 input or recieves some output. It returns TRUE if there is still input or
3196 output to be done, FALSE otherwise.
3197
3198 pump() will automatically call start() if need be, so you may call harness()
3199 then proceed to pump() if that helps you structure your application.
3200
3201 If pump() is called after all harnessed activities have completed, a "process
3202 ended prematurely" exception to be thrown. This allows for simple scripting
3203 of external applications without having to add lots of error handling code at
3204 each step of the script:
3205
3206 $h = harness \@smbclient, \$in, \$out, $err ;
3207
3208 $in = "cd /foo\n" ;
3209 $h->pump until $out =~ /^smb.*> \Z/m ;
3210 die "error cding to /foo:\n$out" if $out =~ "ERR" ;
3211 $out = '' ;
3212
3213 $in = "mget *\n" ;
3214 $h->pump until $out =~ /^smb.*> \Z/m ;
3215 die "error retrieving files:\n$out" if $out =~ "ERR" ;
3216
3217 $h->finish ;
3218
3219 warn $err if $err ;
3220
3221 =cut
3222
3223
3224 sub pump {
3225 die "pump() takes only a a single harness as a parameter"
3226 unless @_ == 1 && isa( $_[0], __PACKAGE__ ) ;
3227
3228 my IPC::Run $self = shift ;
3229
3230 local $cur_self = $self ;
3231
3232 _debug "** pumping"
3233 if _debugging;
3234
3235 # my $r = eval {
3236 $self->start if $self->{STATE} < _started ;
3237 croak "process ended prematurely" unless $self->pumpable ;
3238
3239 $self->{auto_close_ins} = 0 ;
3240 $self->{break_on_io} = 1 ;
3241 $self->_select_loop ;
3242 return $self->pumpable ;
3243 # } ;
3244 # if ( $@ ) {
3245 # my $x = $@ ;
3246 # _debug $x if _debugging && $x ;
3247 # eval { $self->_cleanup } ;
3248 # warn $@ if $@ ;
3249 # die $x ;
3250 # }
3251 # return $r ;
3252 }
3253
3254
3255 =item pump_nb
3256
3257 pump_nb $h ;
3258 $h->pump_nb ;
3259
3260 "pump() non-blocking", pumps if anything's ready to be pumped, returns
3261 immediately otherwise. This is useful if you're doing some long-running
3262 task in the foreground, but don't want to starve any child processes.
3263
3264 =cut
3265
3266 sub pump_nb {
3267 my IPC::Run $self = shift ;
3268
3269 $self->{non_blocking} = 1 ;
3270 my $r = eval { $self->pump } ;
3271 $self->{non_blocking} = 0 ;
3272 die $@ if $@ ;
3273 return $r ;
3274 }
3275
3276 =item pumpable
3277
3278 Returns TRUE if calling pump() won't throw an immediate "process ended
3279 prematurely" exception. This means that there are open I/O channels or
3280 active processes. May yield the parent processes' time slice for 0.01
3281 second if all pipes are to the child and all are paused. In this case
3282 we can't tell if the child is dead, so we yield the processor and
3283 then attempt to reap the child in a nonblocking way.
3284
3285 =cut
3286
3287 ## Undocumented feature (don't depend on it outside this module):
3288 ## returns -1 if we have I/O channels open, or >0 if no I/O channels
3289 ## open, but we have kids running. This allows the select loop
3290 ## to poll for child exit.
3291 sub pumpable {
3292 my IPC::Run $self = shift ;
3293
3294 ## There's a catch-22 we can get in to if there is only one pipe left
3295 ## open to the child and it's paused (ie the SCALAR it's tied to
3296 ## is ''). It's paused, so we're not select()ing on it, so we don't
3297 ## check it to see if the child attached to it is alive and it stays
3298 ## in @{$self->{PIPES}} forever. So, if all pipes are paused, see if
3299 ## we can reap the child.
3300 return -1 if grep !$_->{PAUSED}, @{$self->{PIPES}};
3301
3302 ## See if the child is dead.
3303 $self->reap_nb;
3304 return 0 unless $self->_running_kids;
3305
3306 ## If we reap_nb and it's not dead yet, yield to it to see if it
3307 ## exits.
3308 ##
3309 ## A better solution would be to unpause all the pipes, but I tried that
3310 ## and it never errored on linux. Sigh.
3311 select undef, undef, undef, 0.0001;
3312
3313 ## try again
3314 $self->reap_nb ;
3315 return 0 unless $self->_running_kids;
3316
3317 return -1; ## There are pipes waiting
3318 }
3319
3320
3321 sub _running_kids {
3322 my IPC::Run $self = shift ;
3323 return grep
3324 defined $_->{PID} && ! defined $_->{RESULT},
3325 @{$self->{KIDS}} ;
3326 }
3327
3328
3329 =item reap_nb
3330
3331 Attempts to reap child processes, but does not block.
3332
3333 Does not currently take any parameters, one day it will allow specific
3334 children to be reaped.
3335
3336 Only call this from a signal handler if your C<perl> is recent enough
3337 to have safe signal handling (5.6.1 did not, IIRC, but it was beign discussed
3338 on perl5-porters). Calling this (or doing any significant work) in a signal
3339 handler on older C<perl>s is asking for seg faults.
3340
3341 =cut
3342
3343 my $still_runnings ;
3344
3345 sub reap_nb {
3346 my IPC::Run $self = shift ;
3347
3348 local $cur_self = $self ;
3349
3350 ## No more pipes, look to see if all the kids yet live, reaping those
3351 ## that haven't. I'd use $SIG{CHLD}/$SIG{CLD}, but that's broken
3352 ## on older (SYSV) platforms and perhaps less portable than waitpid().
3353 ## This could be slow with a lot of kids, but that's rare and, well,
3354 ## a lot of kids is slow in the first place.
3355 ## Oh, and this keeps us from reaping other children the process
3356 ## may have spawned.
3357 for my $kid ( @{$self->{KIDS}} ) {
3358 if ( Win32_MODE ) {
3359 next if ! defined $kid->{PROCESS} || defined $kid->{RESULT} ;
3360 unless ( $kid->{PROCESS}->Wait( 0 ) ) {
3361 _debug "kid $kid->{NUM} ($kid->{PID}) still running"
3362 if _debugging_details;
3363 next ;
3364 }
3365
3366 _debug "kid $kid->{NUM} ($kid->{PID}) exited"
3367 if _debugging;
3368
3369 $kid->{PROCESS}->GetExitCode( $kid->{RESULT} )
3370 or croak "$! while GetExitCode()ing for Win32 process" ;
3371
3372 unless ( defined $kid->{RESULT} ) {
3373 $kid->{RESULT} = "0 but true" ;
3374 $? = $kid->{RESULT} = 0x0F ;
3375 }
3376 else {
3377 $? = $kid->{RESULT} << 8 ;
3378 }
3379 }
3380 else {
3381 next if ! defined $kid->{PID} || defined $kid->{RESULT} ;
3382 my $pid = waitpid $kid->{PID}, POSIX::WNOHANG() ;
3383 unless ( $pid ) {
3384 _debug "$kid->{NUM} ($kid->{PID}) still running"
3385 if _debugging_details;
3386 next ;
3387 }
3388
3389 if ( $pid < 0 ) {
3390 _debug "No such process: $kid->{PID}\n" if _debugging ;
3391 $kid->{RESULT} = "unknown result, unknown PID" ;
3392 }
3393 else {
3394 _debug "kid $kid->{NUM} ($kid->{PID}) exited"
3395 if _debugging;
3396
3397 confess "waitpid returned the wrong PID: $pid instead of $kid->{PID}"
3398 unless $pid = $kid->{PID} ;
3399 _debug "$kid->{PID} returned $?\n" if _debugging ;
3400 $kid->{RESULT} = $? ;
3401 }
3402 }
3403 }
3404 }
3405
3406
3407 =item finish
3408
3409 This must be called after the last start() or pump() call for a harness,
3410 or your system will accumulate defunct processes and you may "leak"
3411 file descriptors.
3412
3413 finish() returns TRUE if all children returned 0 (and were not signaled and did
3414 not coredump, ie ! $?), and FALSE otherwise (this is like run(), and the
3415 opposite of system()).
3416
3417 Once a harness has been finished, it may be run() or start()ed again,
3418 including by pump()s auto-start.
3419
3420 If this throws an exception rather than a normal exit, the harness may
3421 be left in an unstable state, it's best to kill the harness to get rid
3422 of all the child processes, etc.
3423
3424 Specifically, if a timeout expires in finish(), finish() will not
3425 kill all the children. Call C<<$h->kill_kill>> in this case if you care.
3426 This differs from the behavior of L</run>.
3427
3428 =cut
3429
3430
3431 sub finish {
3432 my IPC::Run $self = shift ;
3433 my $options = @_ && ref $_[-1] eq 'HASH' ? pop : {} ;
3434
3435 local $cur_self = $self ;
3436
3437 _debug "** finishing" if _debugging;
3438
3439 $self->{non_blocking} = 0 ;
3440 $self->{auto_close_ins} = 1 ;
3441 $self->{break_on_io} = 0 ;
3442 # We don't alter $self->{clear_ins}, start() and run() control it.
3443
3444 while ( $self->pumpable ) {
3445 $self->_select_loop( $options ) ;
3446 }
3447 $self->_cleanup ;
3448
3449 return ! $self->full_result ;
3450 }
3451
3452
3453 =item result
3454
3455 $h->result ;
3456
3457 Returns the first non-zero result code (ie $? >> 8). See L</full_result> to
3458 get the $? value for a child process.
3459
3460 To get the result of a particular child, do:
3461
3462 $h->result( 0 ) ; # first child's $? >> 8
3463 $h->result( 1 ) ; # second child
3464
3465 or
3466
3467 ($h->results)[0]
3468 ($h->results)[1]
3469
3470 Returns undef if no child processes were spawned and no child number was
3471 specified. Throws an exception if an out-of-range child number is passed.
3472
3473 =cut
3474
3475 sub _assert_finished {
3476 my IPC::Run $self = $_[0] ;
3477
3478 croak "Harness not run" unless $self->{STATE} >= _finished ;
3479 croak "Harness not finished running" unless $self->{STATE} == _finished ;
3480 }
3481
3482
3483 sub result {
3484 &_assert_finished ;
3485 my IPC::Run $self = shift ;
3486
3487 if ( @_ ) {
3488 my ( $which ) = @_ ;
3489 croak(
3490 "Only ",
3491 scalar( @{$self->{KIDS}} ),
3492 " child processes, no process $which"
3493 )
3494 unless $which >= 0 && $which <= $#{$self->{KIDS}} ;
3495 return $self->{KIDS}->[$which]->{RESULT} >> 8 ;
3496 }
3497 else {
3498 return undef unless @{$self->{KIDS}} ;
3499 for ( @{$self->{KIDS}} ) {
3500 return $_->{RESULT} >> 8 if $_->{RESULT} >> 8 ;
3501 }
3502 }
3503 }
3504
3505
3506 =item results
3507
3508 Returns a list of child exit values. See L</full_results> if you want to
3509 know if a signal killed the child.
3510
3511 Throws an exception if the harness is not in a finished state.
3512
3513 =cut
3514
3515 sub results {
3516 &_assert_finished ;
3517 my IPC::Run $self = shift ;
3518
3519 # we add 0 here to stop warnings associated with "unknown result, unknown PID"
3520 return map { (0+$_->{RESULT}) >> 8 } @{$self->{KIDS}} ;
3521 }
3522
3523
3524 =item full_result
3525
3526 $h->full_result ;
3527
3528 Returns the first non-zero $?. See L</result> to get the first $? >> 8
3529 value for a child process.
3530
3531 To get the result of a particular child, do:
3532
3533 $h->full_result( 0 ) ; # first child's $? >> 8
3534 $h->full_result( 1 ) ; # second child
3535
3536 or
3537
3538 ($h->full_results)[0]
3539 ($h->full_results)[1]
3540
3541 Returns undef if no child processes were spawned and no child number was
3542 specified. Throws an exception if an out-of-range child number is passed.
3543
3544 =cut
3545
3546 sub full_result {
3547 goto &result if @_ > 1 ;
3548 &_assert_finished ;
3549
3550 my IPC::Run $self = shift ;
3551
3552 return undef unless @{$self->{KIDS}} ;
3553 for ( @{$self->{KIDS}} ) {
3554 return $_->{RESULT} if $_->{RESULT} ;
3555 }
3556 }
3557
3558
3559 =item full_results
3560
3561 Returns a list of child exit values as returned by C<wait>. See L</results>
3562 if you don't care about coredumps or signals.
3563
3564 Throws an exception if the harness is not in a finished state.
3565
3566 =cut
3567
3568 sub full_results {
3569 &_assert_finished ;
3570 my IPC::Run $self = shift ;
3571
3572 croak "Harness not run" unless $self->{STATE} >= _finished ;
3573 croak "Harness not finished running" unless $self->{STATE} == _finished ;
3574
3575 return map $_->{RESULT}, @{$self->{KIDS}} ;
3576 }
3577
3578
3579 ##
3580 ## Filter Scaffolding
3581 ##
3582 use vars (
3583 '$filter_op', ## The op running a filter chain right now
3584 '$filter_num', ## Which filter is being run right now.
3585 ) ;
3586
3587 ##
3588 ## A few filters and filter constructors
3589 ##
3590
3591 =back
3592
3593 =head1 FILTERS
3594
3595 These filters are used to modify input our output between a child
3596 process and a scalar or subroutine endpoint.
3597
3598 =over
3599
3600 =item binary
3601
3602 run \@cmd, ">", binary, \$out ;
3603 run \@cmd, ">", binary, \$out ; ## Any TRUE value to enable
3604 run \@cmd, ">", binary 0, \$out ; ## Any FALSE value to disable
3605
3606 This is a constructor for a "binmode" "filter" that tells IPC::Run to keep
3607 the carriage returns that would ordinarily be edited out for you (binmode
3608 is usually off). This is not a real filter, but an option masquerading as
3609 a filter.
3610
3611 It's not named "binmode" because you're likely to want to call Perl's binmode
3612 in programs that are piping binary data around.
3613
3614 =cut
3615
3616 sub binary(;$) {
3617 my $enable = @_ ? shift : 1 ;
3618 return bless sub { $enable }, "IPC::Run::binmode_pseudo_filter" ;
3619 }
3620
3621 =item new_chunker
3622
3623 This breaks a stream of data in to chunks, based on an optional
3624 scalar or regular expression parameter. The default is the Perl
3625 input record separator in $/, which is a newline be default.
3626
3627 run \@cmd, '>', new_chunker, \&lines_handler ;
3628 run \@cmd, '>', new_chunker( "\r\n" ), \&lines_handler ;
3629
3630 Because this uses $/ by default, you should always pass in a parameter
3631 if you are worried about other code (modules, etc) modifying $/.
3632
3633 If this filter is last in a filter chain that dumps in to a scalar,
3634 the scalar must be set to '' before a new chunk will be written to it.
3635
3636 As an example of how a filter like this can be written, here's a
3637 chunker that splits on newlines:
3638
3639 sub line_splitter {
3640 my ( $in_ref, $out_ref ) = @_ ;
3641
3642 return 0 if length $$out_ref ;
3643
3644 return input_avail && do {
3645 while (1) {
3646 if ( $$in_ref =~ s/\A(.*?\n)// ) {
3647 $$out_ref .= $1 ;
3648 return 1 ;
3649 }
3650 my $hmm = get_more_input ;
3651 unless ( defined $hmm ) {
3652 $$out_ref = $$in_ref ;
3653 $$in_ref = '' ;
3654 return length $$out_ref ? 1 : 0 ;
3655 }
3656 return 0 if $hmm eq 0 ;
3657 }
3658 }
3659 } ;
3660
3661 =cut
3662
3663 sub new_chunker(;$) {
3664 my ( $re ) = @_ ;
3665 $re = $/ if _empty $re ;
3666 $re = quotemeta( $re ) unless ref $re eq 'Regexp' ;
3667 $re = qr/\A(.*?$re)/s ;
3668
3669 return sub {
3670 my ( $in_ref, $out_ref ) = @_ ;
3671
3672 return 0 if length $$out_ref ;
3673
3674 return input_avail && do {
3675 while (1) {
3676 if ( $$in_ref =~ s/$re// ) {
3677 $$out_ref .= $1 ;
3678 return 1 ;
3679 }
3680 my $hmm = get_more_input ;
3681 unless ( defined $hmm ) {
3682 $$out_ref = $$in_ref ;
3683 $$in_ref = '' ;
3684 return length $$out_ref ? 1 : 0 ;
3685 }
3686 return 0 if $hmm eq 0 ;
3687 }
3688 }
3689 } ;
3690 }
3691
3692
3693 =item new_appender
3694
3695 This appends a fixed string to each chunk of data read from the source
3696 scalar or sub. This might be useful if you're writing commands to a
3697 child process that always must end in a fixed string, like "\n":
3698
3699 run( \@cmd,
3700 '<', new_appender( "\n" ), \&commands,
3701 ) ;
3702
3703 Here's a typical filter sub that might be created by new_appender():
3704
3705 sub newline_appender {
3706 my ( $in_ref, $out_ref ) = @_ ;
3707
3708 return input_avail && do {
3709 $$out_ref = join( '', $$out_ref, $$in_ref, "\n" ) ;
3710 $$in_ref = '' ;
3711 1 ;
3712 }
3713 } ;
3714
3715 =cut
3716
3717 sub new_appender($) {
3718 my ( $suffix ) = @_ ;
3719 croak "\$suffix undefined" unless defined $suffix ;
3720
3721 return sub {
3722 my ( $in_ref, $out_ref ) = @_ ;
3723
3724 return input_avail && do {
3725 $$out_ref = join( '', $$out_ref, $$in_ref, $suffix ) ;
3726 $$in_ref = '' ;
3727 1 ;
3728 }
3729 } ;
3730 }
3731
3732
3733 sub new_string_source {
3734 my $ref ;
3735 if ( @_ > 1 ) {
3736 $ref = [ @_ ],
3737 }
3738 else {
3739 $ref = shift ;
3740 }
3741
3742 return ref $ref eq 'SCALAR'
3743 ? sub {
3744 my ( $in_ref, $out_ref ) = @_ ;
3745
3746 return defined $$ref
3747 ? do {
3748 $$out_ref .= $$ref ;
3749 my $r = length $$ref ? 1 : 0 ;
3750 $$ref = undef ;
3751 $r ;
3752 }
3753 : undef
3754 }
3755 : sub {
3756 my ( $in_ref, $out_ref ) = @_ ;
3757
3758 return @$ref
3759 ? do {
3760 my $s = shift @$ref ;
3761 $$out_ref .= $s ;
3762 length $s ? 1 : 0 ;
3763 }
3764 : undef ;
3765 }
3766 }
3767
3768
3769 sub new_string_sink {
3770 my ( $string_ref ) = @_ ;
3771
3772 return sub {
3773 my ( $in_ref, $out_ref ) = @_ ;
3774
3775 return input_avail && do {
3776 $$string_ref .= $$in_ref ;
3777 $$in_ref = '' ;
3778 1 ;
3779 }
3780 } ;
3781 }
3782
3783
3784 #=item timeout
3785 #
3786 #This function defines a time interval, starting from when start() is
3787 #called, or when timeout() is called. If all processes have not finished
3788 #by the end of the timeout period, then a "process timed out" exception
3789 #is thrown.
3790 #
3791 #The time interval may be passed in seconds, or as an end time in
3792 #"HH:MM:SS" format (any non-digit other than '.' may be used as
3793 #spacing and puctuation). This is probably best shown by example:
3794 #
3795 # $h->timeout( $val ) ;
3796 #
3797 # $val Effect
3798 # ======================== =====================================
3799 # undef Timeout timer disabled
3800 # '' Almost immediate timeout
3801 # 0 Almost immediate timeout
3802 # 0.000001 timeout > 0.0000001 seconds
3803 # 30 timeout > 30 seconds
3804 # 30.0000001 timeout > 30 seconds
3805 # 10:30 timeout > 10 minutes, 30 seconds
3806 #
3807 #Timeouts are currently evaluated with a 1 second resolution, though
3808 #this may change in the future. This means that setting
3809 #timeout($h,1) will cause a pokey child to be aborted sometime after
3810 #one second has elapsed and typically before two seconds have elapsed.
3811 #
3812 #This sub does not check whether or not the timeout has expired already.
3813 #
3814 #Returns the number of seconds set as the timeout (this does not change
3815 #as time passes, unless you call timeout( val ) again).
3816 #
3817 #The timeout does not include the time needed to fork() or spawn()
3818 #the child processes, though some setup time for the child processes can
3819 #included. It also does not include the length of time it takes for
3820 #the children to exit after they've closed all their pipes to the
3821 #parent process.
3822 #
3823 #=cut
3824 #
3825 #sub timeout {
3826 # my IPC::Run $self = shift ;
3827 #
3828 # if ( @_ ) {
3829 # ( $self->{TIMEOUT} ) = @_ ;
3830 # $self->{TIMEOUT_END} = undef ;
3831 # if ( defined $self->{TIMEOUT} ) {
3832 # if ( $self->{TIMEOUT} =~ /[^\d.]/ ) {
3833 # my @f = split( /[^\d\.]+/i, $self->{TIMEOUT} ) ;
3834 # unshift @f, 0 while @f < 3 ;
3835 # $self->{TIMEOUT} = (($f[0]*60)+$f[1])*60+$f[2] ;
3836 # }
3837 # elsif ( $self->{TIMEOUT} =~ /^(\d*)(?:\.(\d*))/ ) {
3838 # $self->{TIMEOUT} = $1 + 1 ;
3839 # }
3840 # $self->_calc_timeout_end if $self->{STATE} >= _started ;
3841 # }
3842 # }
3843 # return $self->{TIMEOUT} ;
3844 #}
3845 #
3846 #
3847 #sub _calc_timeout_end {
3848 # my IPC::Run $self = shift ;
3849 #
3850 # $self->{TIMEOUT_END} = defined $self->{TIMEOUT}
3851 # ? time + $self->{TIMEOUT}
3852 # : undef ;
3853 #
3854 # ## We add a second because we might be at the very end of the current
3855 # ## second, and we want to guarantee that we don't have a timeout even
3856 # ## one second less then the timeout period.
3857 # ++$self->{TIMEOUT_END} if $self->{TIMEOUT} ;
3858 #}
3859
3860 =item io
3861
3862 Takes a filename or filehandle, a redirection operator, optional filters,
3863 and a source or destination (depends on the redirection operator). Returns
3864 an IPC::Run::IO object suitable for harness()ing (including via start()
3865 or run()).
3866
3867 This is shorthand for
3868
3869
3870 require IPC::Run::IO ;
3871
3872 ... IPC::Run::IO->new(...) ...
3873
3874 =cut
3875
3876 sub io {
3877 require IPC::Run::IO ;
3878 IPC::Run::IO->new( @_ ) ;
3879 }
3880
3881 =item timer
3882
3883 $h = start( \@cmd, \$in, \$out, $t = timer( 5 ) ) ;
3884
3885 pump $h until $out =~ /expected stuff/ || $t->is_expired ;
3886
3887 Instantiates a non-fatal timer. pump() returns once each time a timer
3888 expires. Has no direct effect on run(), but you can pass a subroutine
3889 to fire when the timer expires.
3890
3891 See L</timeout> for building timers that throw exceptions on
3892 expiration.
3893
3894 See L<IPC::Run::Timer/timer> for details.
3895
3896 =cut
3897
3898 # Doing the prototype suppresses 'only used once' on older perls.
3899 sub timer ;
3900 *timer = \&IPC::Run::Timer::timer ;
3901
3902
3903 =item timeout
3904
3905 $h = start( \@cmd, \$in, \$out, $t = timeout( 5 ) ) ;
3906
3907 pump $h until $out =~ /expected stuff/ ;
3908
3909 Instantiates a timer that throws an exception when it expires.
3910 If you don't provide an exception, a default exception that matches
3911 /^IPC::Run: .*timed out/ is thrown by default. You can pass in your own
3912 exception scalar or reference:
3913
3914 $h = start(
3915 \@cmd, \$in, \$out,
3916 $t = timeout( 5, exception => 'slowpoke' ),
3917 ) ;
3918
3919 or set the name used in debugging message and in the default exception
3920 string:
3921
3922 $h = start(
3923 \@cmd, \$in, \$out,
3924 timeout( 50, name => 'process timer' ),
3925 $stall_timer = timeout( 5, name => 'stall timer' ),
3926 ) ;
3927
3928 pump $h until $out =~ /started/ ;
3929
3930 $in = 'command 1' ;
3931 $stall_timer->start ;
3932 pump $h until $out =~ /command 1 finished/ ;
3933
3934 $in = 'command 2' ;
3935 $stall_timer->start ;
3936 pump $h until $out =~ /command 2 finished/ ;
3937
3938 $in = 'very slow command 3' ;
3939 $stall_timer->start( 10 ) ;
3940 pump $h until $out =~ /command 3 finished/ ;
3941
3942 $stall_timer->start( 5 ) ;
3943 $in = 'command 4' ;
3944 pump $h until $out =~ /command 4 finished/ ;
3945
3946 $stall_timer->reset; # Prevent restarting or expirng
3947 finish $h ;
3948
3949 See L</timer> for building non-fatal timers.
3950
3951 See L<IPC::Run::Timer/timer> for details.
3952
3953 =cut
3954
3955 # Doing the prototype suppresses 'only used once' on older perls.
3956 sub timeout ;
3957 *timeout = \&IPC::Run::Timer::timeout ;
3958
3959
3960 =back
3961
3962 =head1 FILTER IMPLEMENTATION FUNCTIONS
3963
3964 These functions are for use from within filters.
3965
3966 =over
3967
3968 =item input_avail
3969
3970 Returns TRUE if input is available. If none is available, then
3971 &get_more_input is called and its result is returned.
3972
3973 This is usually used in preference to &get_more_input so that the
3974 calling filter removes all data from the $in_ref before more data
3975 gets read in to $in_ref.
3976
3977 C<input_avail> is usually used as part of a return expression:
3978
3979 return input_avail && do {
3980 ## process the input just gotten
3981 1 ;
3982 } ;
3983
3984 This technique allows input_avail to return the undef or 0 that a
3985 filter normally returns when there's no input to process. If a filter
3986 stores intermediate values, however, it will need to react to an
3987 undef:
3988
3989 my $got = input_avail ;
3990 if ( ! defined $got ) {
3991 ## No more input ever, flush internal buffers to $out_ref
3992 }
3993 return $got unless $got ;
3994 ## Got some input, move as much as need be
3995 return 1 if $added_to_out_ref ;
3996
3997 =cut
3998
3999 sub input_avail() {
4000 confess "Undefined FBUF ref for $filter_num+1"
4001 unless defined $filter_op->{FBUFS}->[$filter_num+1] ;
4002 length ${$filter_op->{FBUFS}->[$filter_num+1]} || get_more_input ;
4003 }
4004
4005
4006 =item get_more_input
4007
4008 This is used to fetch more input in to the input variable. It returns
4009 undef if there will never be any more input, 0 if there is none now,
4010 but there might be in the future, and TRUE if more input was gotten.
4011
4012 C<get_more_input> is usually used as part of a return expression,
4013 see L</input_avail> for more information.
4014
4015 =cut
4016
4017 ##
4018 ## Filter implementation interface
4019 ##
4020 sub get_more_input() {
4021 ++$filter_num ;
4022 my $r = eval {
4023 confess "get_more_input() called and no more filters in chain"
4024 unless defined $filter_op->{FILTERS}->[$filter_num] ;
4025 $filter_op->{FILTERS}->[$filter_num]->(
4026 $filter_op->{FBUFS}->[$filter_num+1],
4027 $filter_op->{FBUFS}->[$filter_num],
4028 ) ; # if defined ${$filter_op->{FBUFS}->[$filter_num+1]} ;
4029 } ;
4030 --$filter_num ;
4031 die $@ if $@ ;
4032 return $r ;
4033 }
4034
4035
4036 ## This is not needed by most users. Should really move to IPC::Run::TestUtils
4037 #=item filter_tests
4038 #
4039 # my @tests = filter_tests( "foo", "in", "out", \&filter ) ;
4040 # $_->() for ( @tests ) ;
4041 #
4042 #This creates a list of test subs that can be used to test most filters
4043 #for basic functionality. The first parameter is the name of the
4044 #filter to be tested, the second is sample input, the third is the
4045 #test(s) to apply to the output(s), and the rest of the parameters are
4046 #the filters to be linked and tested.
4047 #
4048 #If the filter chain is to be fed multiple inputs in sequence, the second
4049 #parameter should be a reference to an array of thos inputs:
4050 #
4051 # my @tests = filter_tests( "foo", [qw(1 2 3)], "123", \&filter ) ;
4052 #
4053 #If the filter chain should produce a sequence of outputs, then the
4054 #thrid parameter should be a reference to an array of those outputs:
4055 #
4056 # my @tests = filter_tests(
4057 # "foo",
4058 # "1\n\2\n",
4059 # [ qr/^1$/, qr/^2$/ ],
4060 # new_chunker
4061 # ) ;
4062 #
4063 #See t/run.t and t/filter.t for an example of this in practice.
4064 #
4065 #=cut
4066
4067 ##
4068 ## Filter testing routines
4069 ##
4070 sub filter_tests($;@) {
4071 my ( $name, $in, $exp, @filters ) = @_ ;
4072
4073 my @in = ref $in eq 'ARRAY' ? @$in : ( $in ) ;
4074 my @exp = ref $exp eq 'ARRAY' ? @$exp : ( $exp ) ;
4075
4076 require Test ;
4077 *ok = \&Test::ok ;
4078
4079 my IPC::Run::IO $op ;
4080 my $output ;
4081 my @input ;
4082 my $in_count = 0 ;
4083
4084 my @out ;
4085
4086 my $h ;
4087
4088 return (
4089 sub {
4090 $h = harness() ;
4091 $op = IPC::Run::IO->_new_internal( '<', 0, 0, 0, undef,
4092 new_string_sink( \$output ),
4093 @filters,
4094 new_string_source( \@input ),
4095 ) ;
4096 $op->_init_filters ;
4097 @input = () ;
4098 $output = '' ;
4099 ok(
4100 ! defined $op->_do_filters( $h ),
4101 1,
4102 "$name didn't pass undef (EOF) through"
4103 ) ;
4104 },
4105
4106 ## See if correctly does nothing on 0, (please try again)
4107 sub {
4108 $op->_init_filters ;
4109 $output = '' ;
4110 @input = ( '' ) ;
4111 ok(
4112 $op->_do_filters( $h ),
4113 0,
4114 "$name didn't return 0 (please try again) when given a 0"
4115 ) ;
4116 },
4117
4118 sub {
4119 @input = ( '' ) ;
4120 ok(
4121 $op->_do_filters( $h ),
4122 0,
4123 "$name didn't return 0 (please try again) when given a second 0"
4124 ) ;
4125 },
4126
4127 sub {
4128 for (1..100) {
4129 last unless defined $op->_do_filters( $h ) ;
4130 }
4131 ok(
4132 ! defined $op->_do_filters( $h ),
4133 1,
4134 "$name didn't return undef (EOF) after two 0s and an undef"
4135 ) ;
4136 },
4137
4138 ## See if it can take @in and make @out
4139 sub {
4140 $op->_init_filters ;
4141 $output = '' ;
4142 @input = @in ;
4143 while ( defined $op->_do_filters( $h ) && @input ) {
4144 if ( length $output ) {
4145 push @out, $output ;
4146 $output = '' ;
4147 }
4148 }
4149 if ( length $output ) {
4150 push @out, $output ;
4151 $output = '' ;
4152 }
4153 ok(
4154 scalar @input,
4155 0,
4156 "$name didn't consume it's input"
4157 ) ;
4158 },
4159
4160 sub {
4161 for (1..100) {
4162 last unless defined $op->_do_filters( $h ) ;
4163 if ( length $output ) {
4164 push @out, $output ;
4165 $output = '' ;
4166 }
4167 }
4168 ok(
4169 ! defined $op->_do_filters( $h ),
4170 1,
4171 "$name didn't return undef (EOF), tried 100 times"
4172 ) ;
4173 },
4174
4175 sub {
4176 ok(
4177 join( ', ', map "'$_'", @out ),
4178 join( ', ', map "'$_'", @exp ),
4179 $name
4180 )
4181 },
4182
4183 sub {
4184 ## Force the harness to be cleaned up.
4185 $h = undef ;
4186 ok( 1 ) ;
4187 }
4188 ) ;
4189 }
4190
4191
4192 =back
4193
4194 =head1 TODO
4195
4196 These will be addressed as needed and as time allows.
4197
4198 Stall timeout.
4199
4200 Expose a list of child process objects. When I do this,
4201 each child process is likely to be blessed into IPC::Run::Proc.
4202
4203 $kid->abort(), $kid->kill(), $kid->signal( $num_or_name ).
4204
4205 Write tests for /(full_)?results?/ subs.
4206
4207 Currently, pump() and run() only work on systems where select() works on the
4208 filehandles returned by pipe(). This does *not* include ActiveState on Win32,
4209 although it does work on cygwin under Win32 (thought the tests whine a bit).
4210 I'd like to rectify that, suggestions and patches welcome.
4211
4212 Likewise start() only fully works on fork()/exec() machines (well, just
4213 fork() if you only ever pass perl subs as subprocesses). There's
4214 some scaffolding for calling Open3::spawn_with_handles(), but that's
4215 untested, and not that useful with limited select().
4216
4217 Support for C<\@sub_cmd> as an argument to a command which
4218 gets replaced with /dev/fd or the name of a temporary file containing foo's
4219 output. This is like <(sub_cmd ...) found in bash and csh (IIRC).
4220
4221 Allow multiple harnesses to be combined as independant sets of processes
4222 in to one 'meta-harness'.
4223
4224 Allow a harness to be passed in place of an \@cmd. This would allow
4225 multiple harnesses to be aggregated.
4226
4227 Ability to add external file descriptors w/ filter chains and endpoints.
4228
4229 Ability to add timeouts and timing generators (i.e. repeating timeouts).
4230
4231 High resolution timeouts.
4232
4233 =head1 Win32 LIMITATIONS
4234
4235 =over
4236
4237 =item Fails on Win9X
4238
4239 If you want Win9X support, you'll have to debug it or fund me because I
4240 don't use that system any more. The Win32 subsysem has been extended to
4241 use temporary files in simple run() invocations and these may actually
4242 work on Win9X too, but I don't have time to work on it.
4243
4244 =item May deadlock on Win2K (but not WinNT4 or WinXPPro)
4245
4246 Spawning more than one subprocess on Win2K causes a deadlock I haven't
4247 figured out yet, but simple uses of run() often work. Passes all tests
4248 on WinXPPro and WinNT.
4249
4250 =item no support yet for <pty< and >pty>
4251
4252 These are likely to be implemented as "<" and ">" with binmode on, not
4253 sure.
4254
4255 =item no support for file descriptors higher than 2 (stderr)
4256
4257 Win32 only allows passing explicit fds 0, 1, and 2. If you really, really need to pass file handles, us Win32API:: GetOsFHandle() or ::FdGetOsFHandle() to
4258 get the integer handle and pass it to the child process using the command
4259 line, environment, stdin, intermediary file, or other IPC mechnism. Then
4260 use that handle in the child (Win32API.pm provides ways to reconstitute
4261 Perl file handles from Win32 file handles).
4262
4263 =item no support for subroutine subprocesses (CODE refs)
4264
4265 Can't fork(), so the subroutines would have no context, and closures certainly
4266 have no meaning
4267
4268 Perhaps with Win32 fork() emulation, this can be supported in a limited
4269 fashion, but there are other very serious problems with that: all parent
4270 fds get dup()ed in to the thread emulating the forked process, and that
4271 keeps the parent from being able to close all of the appropriate fds.
4272
4273 =item no support for init => sub {} routines.
4274
4275 Win32 processes are created from scratch, there is no way to do an init
4276 routine that will affect the running child. Some limited support might
4277 be implemented one day, do chdir() and %ENV changes can be made.
4278
4279 =item signals
4280
4281 Win32 does not fully support signals. signal() is likely to cause errors
4282 unless sending a signal that Perl emulates, and C<kill_kill()> is immediately
4283 fatal (there is no grace period).
4284
4285 =item helper processes
4286
4287 IPC::Run uses helper processes, one per redirected file, to adapt between the
4288 anonymous pipe connected to the child and the TCP socket connected to the
4289 parent. This is a waste of resources and will change in the future to either
4290 use threads (instead of helper processes) or a WaitForMultipleObjects call
4291 (instead of select). Please contact me if you can help with the
4292 WaitForMultipleObjects() approach; I haven't figured out how to get at it
4293 without C code.
4294
4295 =item shutdown pause
4296
4297 There seems to be a pause of up to 1 second between when a child program exits
4298 and the corresponding sockets indicate that they are closed in the parent.
4299 Not sure why.
4300
4301 =item binmode
4302
4303 binmode is not supported yet. The underpinnings are implemented, just ask
4304 if you need it.
4305
4306 =item IPC::Run::IO
4307
4308 IPC::Run::IO objects can be used on Unix to read or write arbitrary files. On
4309 Win32, they will need to use the same helper processes to adapt from
4310 non-select()able filehandles to select()able ones (or perhaps
4311 WaitForMultipleObjects() will work with them, not sure).
4312
4313 =item startup race conditions
4314
4315 There seems to be an occasional race condition between child process startup
4316 and pipe closings. It seems like if the child is not fully created by the time
4317 CreateProcess returns and we close the TCP socket being handed to it, the
4318 parent socket can also get closed. This is seen with the Win32 pumper
4319 applications, not the "real" child process being spawned.
4320
4321 I assume this is because the kernel hasn't gotten around to incrementing the
4322 reference count on the child's end (since the child was slow in starting), so
4323 the parent's closing of the child end causes the socket to be closed, thus
4324 closing the parent socket.
4325
4326 Being a race condition, it's hard to reproduce, but I encountered it while
4327 testing this code on a drive share to a samba box. In this case, it takes
4328 t/run.t a long time to spawn it's chile processes (the parent hangs in the
4329 first select for several seconds until the child emits any debugging output).
4330
4331 I have not seen it on local drives, and can't reproduce it at will,
4332 unfortunately. The symptom is a "bad file descriptor in select()" error, and,
4333 by turning on debugging, it's possible to see that select() is being called on
4334 a no longer open file descriptor that was returned from the _socket() routine
4335 in Win32Helper. There's a new confess() that checks for this ("PARENT_HANDLE
4336 no longer open"), but I haven't been able to reproduce it (typically).
4337
4338 =back
4339
4340 =head1 LIMITATIONS
4341
4342 On Unix, requires a system that supports C<waitpid( $pid, WNOHANG )> so
4343 it can tell if a child process is still running.
4344
4345 PTYs don't seem to be non-blocking on some versions of Solaris. Here's a
4346 test script contributed by Borislav Deianov <borislav@ensim.com> to see
4347 if you have the problem. If it dies, you have the problem.
4348
4349 #!/usr/bin/perl
4350
4351 use IPC::Run qw(run);
4352 use Fcntl;
4353 use IO::Pty;
4354
4355 sub makecmd {
4356 return ['perl', '-e',
4357 '<STDIN>, print "\n" x '.$_[0].'; while(<STDIN>){last if /end/}'];
4358 }
4359
4360 #pipe R, W;
4361 #fcntl(W, F_SETFL, O_NONBLOCK);
4362 #while (syswrite(W, "\n", 1)) { $pipebuf++ };
4363 #print "pipe buffer size is $pipebuf\n";
4364 my $pipebuf=4096;
4365 my $in = "\n" x ($pipebuf * 2) . "end\n";
4366 my $out;
4367
4368 $SIG{ALRM} = sub { die "Never completed!\n" } ;
4369
4370 print "reading from scalar via pipe...";
4371 alarm( 2 ) ;
4372 run(makecmd($pipebuf * 2), '<', \$in, '>', \$out);
4373 alarm( 0 );
4374 print "done\n";
4375
4376 print "reading from code via pipe... ";
4377 alarm( 2 ) ;
4378 run(makecmd($pipebuf * 3), '<', sub { $t = $in; undef $in; $t}, '>', \$out);
4379 alarm( 0 ) ;
4380 print "done\n";
4381
4382 $pty = IO::Pty->new();
4383 $pty->blocking(0);
4384 $slave = $pty->slave();
4385 while ($pty->syswrite("\n", 1)) { $ptybuf++ };
4386 print "pty buffer size is $ptybuf\n";
4387 $in = "\n" x ($ptybuf * 3) . "end\n";
4388
4389 print "reading via pty... ";
4390 alarm( 2 ) ;
4391 run(makecmd($ptybuf * 3), '<pty<', \$in, '>', \$out);
4392 alarm(0);
4393 print "done\n";
4394
4395 No support for ';', '&&', '||', '{ ... }', etc: use perl's, since run()
4396 returns TRUE when the command exits with a 0 result code.
4397
4398 Does not provide shell-like string interpolation.
4399
4400 No support for C<cd>, C<setenv>, or C<export>: do these in an init() sub
4401
4402 run(
4403 \cmd,
4404 ...
4405 init => sub {
4406 chdir $dir or die $! ;
4407 $ENV{FOO}='BAR'
4408 }
4409 ) ;
4410
4411 Timeout calculation does not allow absolute times, or specification of
4412 days, months, etc.
4413
4414 B<WARNING:> Function coprocesses (C<run \&foo, ...>) suffer from two
4415 limitations. The first is that it is difficult to close all filehandles the
4416 child inherits from the parent, since there is no way to scan all open
4417 FILEHANDLEs in Perl and it both painful and a bit dangerous to close all open
4418 file descriptors with C<POSIX::close()>. Painful because we can't tell which
4419 fds are open at the POSIX level, either, so we'd have to scan all possible fds
4420 and close any that we don't want open (normally C<exec()> closes any
4421 non-inheritable but we don't C<exec()> for &sub processes.
4422
4423 The second problem is that Perl's DESTROY subs and other on-exit cleanup gets
4424 run in the child process. If objects are instantiated in the parent before the
4425 child is forked, the the DESTROY will get run once in the parent and once in
4426 the child. When coprocess subs exit, POSIX::exit is called to work around this,
4427 but it means that objects that are still referred to at that time are not
4428 cleaned up. So setting package vars or closure vars to point to objects that
4429 rely on DESTROY to affect things outside the process (files, etc), will
4430 lead to bugs.
4431
4432 I goofed on the syntax: "<pipe" vs. "<pty<" and ">filename" are both
4433 oddities.
4434
4435 =head1 TODO
4436
4437 =over
4438
4439 =item Allow one harness to "adopt" another:
4440
4441 $new_h = harness \@cmd2 ;
4442 $h->adopt( $new_h ) ;
4443
4444 =item Close all filehandles not explicitly marked to stay open.
4445
4446 The problem with this one is that there's no good way to scan all open
4447 FILEHANDLEs in Perl, yet you don't want child processes inheriting handles
4448 willy-nilly.
4449
4450 =back
4451
4452 =head1 INSPIRATION
4453
4454 Well, select() and waitpid() badly needed wrapping, and open3() isn't
4455 open-minded enough for me.
4456
4457 The shell-like API inspired by a message Russ Allbery sent to perl5-porters,
4458 which included:
4459
4460 I've thought for some time that it would be
4461 nice to have a module that could handle full Bourne shell pipe syntax
4462 internally, with fork and exec, without ever invoking a shell. Something
4463 that you could give things like:
4464
4465 pipeopen (PIPE, [ qw/cat file/ ], '|', [ 'analyze', @args ], '>&3');
4466
4467 Message ylln51p2b6.fsf@windlord.stanford.edu, on 2000/02/04.
4468
4469 =head1 AUTHOR
4470
4471 Barrie Slaymaker <barries@slaysys.com>, with numerous suggestions by p5p.
4472
4473 =cut
4474
4475 1 ;
+118
-0
t/adopt.t less more
0 #!/usr/bin/perl -w
1
2 =head1 NAME
3
4 adopt.t - Test suite for IPC::Run::adopt
5
6 =cut
7
8 BEGIN {
9 if( $ENV{PERL_CORE} ) {
10 chdir '../lib/IPC/Run' if -d '../lib/IPC/Run';
11 unshift @INC, 'lib', '../..';
12 $^X = '../../../t/' . $^X;
13 }
14 }
15
16
17 use strict ;
18
19 use Test ;
20
21 use IPC::Run qw( start pump finish ) ;
22 use UNIVERSAL qw( isa ) ;
23
24 ##
25 ## $^X is the path to the perl binary. This is used run all the subprocesses.
26 ##
27 my @echoer = ( $^X, '-pe', 'BEGIN { $| = 1 }' ) ;
28
29 my $h ;
30 my $in ;
31 my $out ;
32 my $fd_map ;
33
34 my $h1 ;
35 my $in1 ;
36 my $out1 ;
37 my $fd_map1 ;
38
39 sub map_fds() { &IPC::Run::_map_fds }
40
41 my @tests = (
42 ##
43 ## harness, pump, run
44 ##
45 sub {
46 $in = 'SHOULD BE UNCHANGED' ;
47 $out = 'REPLACE ME' ;
48 $? = 99 ;
49 $fd_map = map_fds ;
50 $h = start( \@echoer, \$in, \$out ) ;
51 ok( isa( $h, 'IPC::Run' ) ) ;
52 },
53 sub { ok( $?, 99 ) },
54
55 sub { ok( $in, 'SHOULD BE UNCHANGED' ) },
56 sub { ok( $out, '' ) },
57 sub { ok( $h->pumpable ) },
58
59 sub {
60 $in = '' ;
61 $? = 0 ;
62 pump_nb $h for ( 1..100 ) ;
63 ok( 1 ) ;
64 },
65 sub { ok( $in, '' ) },
66 sub { ok( $out, '' ) },
67 sub { ok( $h->pumpable ) },
68
69 sub {
70 $in1 = 'SHOULD BE UNCHANGED' ;
71 $out1 = 'REPLACE ME' ;
72 $? = 99 ;
73 $fd_map1 = map_fds ;
74 $h1 = start( \@echoer, \$in1, \$out1 ) ;
75 ok( isa( $h1, 'IPC::Run' ) ) ;
76 },
77 sub { ok( $?, 99 ) },
78 sub { ok( $in1, 'SHOULD BE UNCHANGED' ) },
79 sub { ok( $out1, '' ) },
80 sub { ok( $h1->pumpable ) },
81
82
83 sub {
84 $in = "hello\n" ;
85 $? = 0 ;
86 pump $h until $out =~ /hello/ ;
87 ok( 1 ) ;
88 },
89 sub { ok( ! $? ) },
90 sub { ok( $in, '' ) },
91 sub { ok( $out, "hello\n" ) },
92 sub { ok( $h->pumpable ) },
93
94 sub {
95 $in = "world\n" ;
96 $? = 0 ;
97 pump $h until $out =~ /world/ ;
98 ok( 1 ) ;
99 },
100 sub { ok( ! $? ) },
101 sub { ok( $in, '' ) },
102 sub { ok( $out, "hello\nworld\n" ) },
103 sub { ok( $h->pumpable ) },
104
105 sub { warn "hi" ;ok( $h->finish ) },
106 sub { ok( ! $? ) },
107 sub { ok( map_fds, $fd_map ) },
108 sub { ok( $out, "hello\nworld\n" ) },
109 sub { ok( ! $h->pumpable ) },
110 ) ;
111
112 plan tests => scalar @tests ;
113
114 skip "adopt not done yet", 1 for ( @tests ) ;
115 exit 0 ;
116
117 $_->() for ( @tests ) ;
+100
-0
t/binmode.t less more
0 #!/usr/bin/perl -w
1
2 =head1 NAME
3
4 binary.t - Test suite for IPC::Run binary functionality
5
6 =cut
7
8 BEGIN {
9 if( $ENV{PERL_CORE} ) {
10 chdir '../lib/IPC/Run' if -d '../lib/IPC/Run';
11 unshift @INC, 'lib', '../..';
12 $^X = '../../../t/' . $^X;
13 }
14 }
15
16 ## Handy to have when our output is intermingled with debugging output sent
17 ## to the debugging fd.
18 $| = 1 ;
19 select STDERR ; $| = 1 ; select STDOUT ;
20
21 use strict ;
22
23 use Test ;
24
25 use IPC::Run qw( harness run binary ) ;
26
27 sub Win32_MODE() ;
28 *Win32_MODE = \&IPC::Run::Win32_MODE ;
29
30 my $crlf_text = "Hello World\r\n" ;
31
32 my $text = $crlf_text ;
33 $text =~ s/\r//g if Win32_MODE ;
34
35 my $nl_text = $crlf_text ;
36 $nl_text =~ s/\r//g ;
37
38 my @perl = ( $^X ) ;
39
40 my $emitter_script = q{ binmode STDOUT ; print "Hello World\r\n" } ;
41 my @emitter = ( @perl, '-e', $emitter_script ) ;
42
43 my $reporter_script =
44 q{ binmode STDIN ; $_ = join "", <>; s/([\000-\037])/sprintf "\\\\0x%02x", ord $1/ge; print } ;
45 my @reporter = ( @perl, '-e', $reporter_script ) ;
46
47 my $in ;
48 my $out ;
49 my $err ;
50
51 sub f($) {
52 my $s = shift ;
53 $s =~ s/([\000-\027])/sprintf "\\0x%02x", ord $1/ge ;
54 $s
55 }
56
57 my @tests = (
58 ## Parsing tests
59 sub { ok eval { harness [], '>', binary, \$out } ? 1 : $@, 1 } ,
60 sub { ok eval { harness [], '>', binary, "foo" } ? 1 : $@, 1 },
61 sub { ok eval { harness [], '<', binary, \$in } ? 1 : $@, 1 },
62 sub { ok eval { harness [], '<', binary, "foo" } ? 1 : $@, 1 },
63
64 ## Testing from-kid now so we can use it to test stdin later
65 sub { ok run \@emitter, ">", \$out },
66 sub { ok f $out, f $text, "no binary" },
67
68 sub { ok run \@emitter, ">", binary, \$out },
69 sub { ok f $out, f $crlf_text, "out binary" },
70
71 sub { ok run \@emitter, ">", binary( 0 ), \$out },
72 sub { ok f $out, f $text, "out binary 0" },
73
74 sub { ok run \@emitter, ">", binary( 1 ), \$out },
75 sub { ok f $out, f $crlf_text, "out binary 1" },
76
77 ## Test to-kid
78 sub { ok run \@reporter, "<", \$nl_text, ">", \$out },
79 sub { ok $out, "Hello World" . ( Win32_MODE ? "\\0x0d" : "" ) . "\\0x0a", "reporter < \\n" },
80
81 sub { ok run \@reporter, "<", binary, \$nl_text, ">", \$out },
82 sub { ok $out, "Hello World\\0x0a", "reporter < binary \\n" },
83
84 sub { ok run \@reporter, "<", binary, \$crlf_text, ">", \$out },
85 sub { ok $out, "Hello World\\0x0d\\0x0a", "reporter < binary \\r\\n" },
86
87 sub { ok run \@reporter, "<", binary( 0 ), \$nl_text, ">", \$out },
88 sub { ok $out, "Hello World" . ( Win32_MODE ? "\\0x0d" : "" ) . "\\0x0a", "reporter < binary(0) \\n" },
89
90 sub { ok run \@reporter, "<", binary( 1 ), \$nl_text, ">", \$out },
91 sub { ok $out, "Hello World\\0x0a", "reporter < binary(1) \\n" },
92
93 sub { ok run \@reporter, "<", binary( 1 ), \$crlf_text, ">", \$out },
94 sub { ok $out, "Hello World\\0x0d\\0x0a", "reporter < binary(1) \\r\\n" },
95 ) ;
96
97 plan tests => scalar @tests ;
98
99 $_->() for ( @tests ) ;
+67
-0
t/bogus.t less more
0 #!/usr/bin/perl -w
1
2 =head1 NAME
3
4 bogus.t - test bogus file cases.
5
6 =cut
7
8 BEGIN {
9 if( $ENV{PERL_CORE} ) {
10 chdir '../lib/IPC/Run' if -d '../lib/IPC/Run';
11 unshift @INC, 'lib', '../..';
12 $^X = '../../../t/' . $^X;
13 }
14 }
15
16
17 use strict ;
18
19 use Test ;
20
21 use IPC::Run qw( start ) ;
22 use UNIVERSAL qw( isa ) ;
23
24 my $r ;
25
26 sub Win32_MODE() ;
27 *Win32_MODE = \&IPC::Run::Win32_MODE ;
28
29 ## Win32 does not support a lot of things that Unix does. These
30 ## skip_unless subs help that.
31 ##
32 ## TODO: There are also a few things that Win32 supports (passing Win32 OS
33 ## handles) that we should test for, conversely.
34 sub skip_unless_exec(&) {
35 if ( Win32_MODE ) {
36 return sub {
37 skip "Can't really exec() $^O", 0 ;
38 } ;
39 }
40 shift ;
41 }
42
43 my @tests = (
44 sub {
45 ## Older Test.pm's don't grok qr// in $expected.
46 my $expected = 'file not found' ;
47 eval { start ["./bogus_really_bogus"] } ;
48 my $got = $@ =~ $expected ? $expected : $@ || "" ;
49 ok $got, $expected, "starting ./bogus_really_bogus" ;
50 },
51
52 skip_unless_exec {
53 ## Older Test.pm's don't grok qr// in $expected.
54 my $expected = 'exec failed' ;
55 my $h = eval {
56 start [$^X, "-e", 1], _simulate_exec_failure => 1 ;
57 } ;
58 my $got = $@ =~ $expected ? $expected : $@ || "" ;
59 ok $got, $expected, "starting $^X with simulated_exec_failure => 1" ;
60 },
61
62 ) ;
63
64 plan tests => scalar @tests ;
65
66 $_->() for ( @tests ) ;
+118
-0
t/filter.t less more
0 #!/usr/bin/perl -w
1
2 =head1 NAME
3
4 filter.t - Test suite for IPC::Run filter scaffolding
5
6 =cut
7
8 BEGIN {
9 if( $ENV{PERL_CORE} ) {
10 chdir '../lib/IPC/Run' if -d '../lib/IPC/Run';
11 unshift @INC, 'lib', '../..';
12 $^X = '../../../t/' . $^X;
13 }
14 }
15
16 use strict ;
17
18 use Test ;
19
20 use IPC::Run qw( :filters :filter_imp filter_tests ) ;
21
22 sub uc_filter {
23 my ( $in_ref, $out_ref ) = @_ ;
24
25 return input_avail && do {
26 $$out_ref .= uc( $$in_ref ) ;
27 $$in_ref = '' ;
28 1 ;
29 }
30 }
31
32
33 my $string ;
34
35 sub string_source {
36 my ( $in_ref, $out_ref ) = @_ ;
37 return undef unless defined $string ;
38 $$out_ref .= $string ;
39 $string = undef ;
40 return 1 ;
41 }
42
43
44 my $accum ;
45
46 sub accum {
47 my ( $in_ref, $out_ref ) = @_ ;
48 return input_avail && do {
49 $accum .= $$in_ref ;
50 $$in_ref = '' ;
51 1 ;
52 } ;
53 }
54
55
56 my $op ;
57
58 ## "import" the things we're testing.
59 *_init_filters = \&IPC::Run::_init_filters ;
60 *_do_filters = \&IPC::Run::_do_filters ;
61
62
63 my @tests = (
64
65 filter_tests( "filter_tests", "hello world", "hello world" ),
66 filter_tests( "filter_tests []", [qq(hello world)], [qq(hello world)] ),
67 filter_tests( "filter_tests [] 2", [qw(hello world)], [qw(hello world)] ),
68
69 filter_tests( "uc_filter", "hello world", "HELLO WORLD", \&uc_filter ),
70
71 filter_tests(
72 "chunking_filter by lines 1",
73 "hello 1\nhello 2\nhello 3",
74 ["hello 1\n", "hello 2\n", "hello 3"],
75 new_chunker
76 ),
77
78 filter_tests(
79 "chunking_filter by lines 2",
80 "hello 1\nhello 2\nhello 3",
81 ["hello 1\n", "hello 2\n", "hello 3"],
82 new_chunker
83 ),
84
85 filter_tests(
86 "chunking_filter by lines 2",
87 [split( /(\s|\n)/, "hello 1\nhello 2\nhello 3" )],
88 ["hello 1\n", "hello 2\n", "hello 3"],
89 new_chunker
90 ),
91
92 filter_tests(
93 "chunking_filter by an odd separator",
94 "hello world",
95 "hello world",
96 new_chunker( 'odd separator' )
97 ),
98
99 filter_tests(
100 "chunking_filter 2",
101 "hello world",
102 ['hello world' =~ m/(.)/g],
103 new_chunker( qr/./ )
104 ),
105
106 filter_tests(
107 "appending_filter",
108 [qw( 1 2 3 )],
109 [qw( 1a 2a 3a )],
110 new_appender("a")
111 ),
112 ) ;
113
114 plan tests => scalar @tests ;
115
116 $_->() for ( @tests ) ;
117
+147
-0
t/harness.t less more
0 #!/usr/bin/perl -w
1
2 =head1 NAME
3
4 harness.t - Test suite for IPC::Run::harness
5
6 =cut
7
8 BEGIN {
9 if( $ENV{PERL_CORE} ) {
10 chdir '../lib/IPC/Run' if -d '../lib/IPC/Run';
11 unshift @INC, 'lib', '../..';
12 $^X = '../../../t/' . $^X;
13 }
14 }
15
16 use strict ;
17
18 use Test ;
19
20 use IPC::Run qw( harness ) ;
21
22 my $f ;
23
24 sub expand_test {
25 my ( $args, $expected ) = @_ ;
26
27 my $h ;
28 my @out ;
29 my $i = 0 ;
30 return (
31 sub {
32 $h = IPC::Run::harness( @$args ) ;
33 @out = @{$h->{KIDS}->[0]->{OPS}} ;
34 ok(
35 scalar( @out ),
36 scalar( @$expected ),
37 join( ' ', @$args )
38 )
39 },
40 map {
41 my $j = $i++ ;
42 my $h = $_ ;
43 map {
44 my ( $key, $value ) = ( $_, $h->{$_} ) ;
45 sub {
46 my $got = $out[$j]->{$key} ;
47 $got = @$got if ref $got eq 'ARRAY' ;
48 $got = '<undef>' unless defined $got ;
49 ok( $got, $value, join( ' ', @$args ) . ": $j, $key" )
50 } ;
51 } sort keys %$h ;
52 } @$expected
53 ) ;
54 }
55
56
57
58 my @tests = (
59
60 expand_test(
61 [ ['a'], qw( <b < c 0<d 0< e 1<f 1< g) ],
62 [
63 { TYPE => '<', SOURCE => 'b', KFD => 0, },
64 { TYPE => '<', SOURCE => 'c', KFD => 0, },
65 { TYPE => '<', SOURCE => 'd', KFD => 0, },
66 { TYPE => '<', SOURCE => 'e', KFD => 0, },
67 { TYPE => '<', SOURCE => 'f', KFD => 1, },
68 { TYPE => '<', SOURCE => 'g', KFD => 1, },
69 ]
70 ),
71
72 expand_test(
73 [ ['a'], qw( >b > c 2>d 2> e >>f >> g 2>>h 2>> i) ],
74 [
75 { TYPE => '>', DEST => 'b', KFD => 1, TRUNC => 1, },
76 { TYPE => '>', DEST => 'c', KFD => 1, TRUNC => 1, },
77 { TYPE => '>', DEST => 'd', KFD => 2, TRUNC => 1, },
78 { TYPE => '>', DEST => 'e', KFD => 2, TRUNC => 1, },
79 { TYPE => '>', DEST => 'f', KFD => 1, TRUNC => '', },
80 { TYPE => '>', DEST => 'g', KFD => 1, TRUNC => '', },
81 { TYPE => '>', DEST => 'h', KFD => 2, TRUNC => '', },
82 { TYPE => '>', DEST => 'i', KFD => 2, TRUNC => '', },
83 ]
84 ),
85
86 expand_test(
87 [ ['a'], qw( >&b >& c &>d &> e ) ],
88 [
89 { TYPE => '>', DEST => 'b', KFD => 1, TRUNC => 1, },
90 { TYPE => 'dup', KFD1 => 1, KFD2 => 2 },
91 { TYPE => '>', DEST => 'c', KFD => 1, TRUNC => 1, },
92 { TYPE => 'dup', KFD1 => 1, KFD2 => 2 },
93 { TYPE => '>', DEST => 'd', KFD => 1, TRUNC => 1, },
94 { TYPE => 'dup', KFD1 => 1, KFD2 => 2 },
95 { TYPE => '>', DEST => 'e', KFD => 1, TRUNC => 1, },
96 { TYPE => 'dup', KFD1 => 1, KFD2 => 2 },
97 ]
98 ),
99
100 expand_test(
101 [ ['a'],
102 '>&', sub{}, sub{}, \$f,
103 '>', sub{}, sub{}, \$f,
104 '<', sub{}, sub{}, \$f,
105 ],
106 [
107 { TYPE => '>', DEST => \$f, KFD => 1, TRUNC => 1,
108 FILTERS => 2 },
109 { TYPE => 'dup', KFD1 => 1, KFD2 => 2 },
110 { TYPE => '>', DEST => \$f, KFD => 1, TRUNC => 1,
111 FILTERS => 2 },
112 { TYPE => '<', SOURCE => \$f, KFD => 0,
113 FILTERS => 3 },
114 ]
115 ),
116
117 expand_test(
118 [ ['a'], '<', \$f, '>', \$f ],
119 [
120 { TYPE => '<', SOURCE => \$f, KFD => 0, },
121 { TYPE => '>', DEST => \$f, KFD => 1, },
122 ]
123 ),
124
125 expand_test(
126 [ ['a'], '<pipe', \$f, '>pipe', \$f ],
127 [
128 { TYPE => '<pipe', SOURCE => \$f, KFD => 0, },
129 { TYPE => '>pipe', DEST => \$f, KFD => 1, },
130 ]
131 ),
132
133 expand_test(
134 [ ['a'], '<pipe', \$f, '>', \$f ],
135 [
136 { TYPE => '<pipe', SOURCE => \$f, KFD => 0, },
137 { TYPE => '>', DEST => \$f, KFD => 1, },
138 ]
139 ),
140
141 ) ;
142
143 plan tests => scalar @tests ;
144
145 $_->() for ( @tests ) ;
146
+131
-0
t/io.t less more
0 #!/usr/bin/perl -w
1
2 =head1 NAME
3
4 io.t - Test suite excercising IPC::Run::IO with IPC::Run::run.
5
6 =cut
7
8 BEGIN {
9 if( $ENV{PERL_CORE} ) {
10 chdir '../lib/IPC/Run' if -d '../lib/IPC/Run';
11 unshift @INC, 'lib', '../..';
12 $^X = '../../../t/' . $^X;
13 }
14 }
15
16 use strict ;
17
18 use Test ;
19
20 use IPC::Run qw( :filters run io ) ;
21 use IPC::Run::Debug qw( _map_fds );
22 use UNIVERSAL qw( isa ) ;
23
24 sub skip_unless_select (&) {
25 if ( IPC::Run::Win32_MODE() ) {
26 return sub {
27 skip "$^O does not allow select() on non-sockets", 0 ;
28 } ;
29 }
30 shift ;
31 }
32
33 my $text = "Hello World\n" ;
34
35 my $emitter_script = qq{print '$text' ; print STDERR uc( '$text' )} ;
36 ##
37 ## $^X is the path to the perl binary. This is used run all the subprocesses.
38 ##
39 my @perl = ( $^X ) ;
40 my @emitter = ( @perl, '-e', $emitter_script ) ;
41
42 my $recv ;
43 my $send ;
44
45 my $in_file = 'io.t.in' ;
46 my $out_file = 'io.t.out' ;
47 my $err_file = 'io.t.err' ;
48
49 my $io ;
50 my $r ;
51
52 my $fd_map ;
53
54 ## TODO: Test filters, etc.
55
56 sub slurp($) {
57 my ( $f ) = @_ ;
58 open( S, "<$f" ) or return "$! '$f'" ;
59 my $r = join( '', <S> ) ;
60 close S or warn "$! closing '$f'";
61 return $r ;
62 }
63
64
65 sub spit($$) {
66 my ( $f, $s ) = @_ ;
67 open( S, ">$f" ) or die "$! '$f'" ;
68 print S $s or die "$! '$f'" ;
69 close S or die "$! '$f'" ;
70 }
71
72 sub wipe($) {
73 my ( $f ) = @_ ;
74 unlink $f or warn "$! unlinking '$f'" if -f $f ;
75 }
76
77
78
79 my @tests = (
80 ##
81 ## Parsing
82 ##
83 sub {
84 $io = io( 'foo', '<', \$send ) ;
85 ok isa $io, 'IPC::Run::IO' ;
86 },
87
88 sub { ok( io( 'foo', '<', \$send )->mode, 'w' ) },
89 sub { ok( io( 'foo', '<<', \$send )->mode, 'wa' ) },
90 sub { ok( io( 'foo', '>', \$recv )->mode, 'r' ) },
91 sub { ok( io( 'foo', '>>', \$recv )->mode, 'ra' ) },
92
93 ##
94 ## Input from a file
95 ##
96 skip_unless_select {
97 spit $in_file, $text ;
98 $recv = 'REPLACE ME' ;
99 $fd_map = _map_fds ;
100 $r = run io( $in_file, '>', \$recv ) ;
101 wipe $in_file ;
102 ok( $r ) ;
103 },
104 skip_unless_select { ok( ! $? ) },
105 skip_unless_select { ok( _map_fds, $fd_map ) },
106
107 skip_unless_select { ok( $recv, $text ) },
108
109 ##
110 ## Output to a file
111 ##
112 skip_unless_select {
113 wipe $out_file ;
114 $send = $text ;
115 $fd_map = _map_fds ;
116 $r = run io( $out_file, '<', \$send ) ;
117 $recv = slurp $out_file ;
118 wipe $out_file ;
119 ok( $r ) ;
120 },
121 skip_unless_select { ok( ! $? ) },
122 skip_unless_select { ok( _map_fds, $fd_map ) },
123
124 skip_unless_select { ok( $send, $text ) },
125 skip_unless_select { ok( $recv, $text ) },
126 ) ;
127
128 plan tests => scalar @tests ;
129
130 $_->() for ( @tests ) ;
+57
-0
t/kill_kill.t less more
0 #!/usr/bin/perl -w
1
2 =head1 NAME
3
4 kill_kill.t - Test suite IPC::Run->kill_kill
5
6 =cut
7
8 BEGIN {
9 if( $ENV{PERL_CORE} ) {
10 chdir '../lib/IPC/Run' if -d '../lib/IPC/Run';
11 unshift @INC, 'lib', '../..';
12 $^X = '../../../t/' . $^X;
13 }
14 }
15
16
17 use strict ;
18
19 use Test ;
20
21 use IPC::Run qw( start ) ;
22
23 sub skip_unless_ignore_term(&) {
24 if ( IPC::Run::Win32_MODE() ) {
25 return sub {
26 skip "$^O does not support ignoring the TERM signal", 0 ;
27 } ;
28 }
29 shift ;
30 }
31
32 my @quiter = ( $^X, '-e', 'sleep while 1' ) ;
33 my @zombie00 = ( $^X, '-e', '$SIG{TERM}=sub{};$|=1;print "running\n";sleep while 1');
34
35 my @tests = (
36 sub {
37 my $h = start \@quiter ;
38 my $needed_kill = $h->kill_kill ; # grace => 2 ) ;
39 ok ! $needed_kill ;
40 },
41
42 skip_unless_ignore_term {
43 my $out ;
44 my $h = start \@zombie00, \undef, \$out ;
45 pump $h until $out =~ /running/ ;
46 my $needed_kill = $h->kill_kill( grace => 1 ) ;
47 ok $needed_kill ;
48 },
49
50 ## not testing coredumps; some systems don't provide them. #'
51
52 ) ;
53
54 plan tests => scalar @tests ;
55
56 $_->() for ( @tests ) ;
+108
-0
t/parallel.t less more
0 #!/usr/bin/perl -w
1
2 =head1 NAME
3
4 parallel.t - Test suite for running multiple processes in parallel.
5
6 =cut
7
8 BEGIN {
9 if( $ENV{PERL_CORE} ) {
10 chdir '../lib/IPC/Run' if -d '../lib/IPC/Run';
11 unshift @INC, 'lib', '../..';
12 $^X = '../../../t/' . $^X;
13 }
14 }
15
16 ## Handy to have when our output is intermingled with debugging output sent
17 ## to the debugging fd.
18 $| = 1 ;
19 select STDERR ; $| = 1 ; select STDOUT ;
20
21 use strict ;
22
23 use Test ;
24
25 use IPC::Run qw( start pump finish ) ;
26 use UNIVERSAL qw( isa ) ;
27
28 sub Win32_MODE() ;
29 *Win32_MODE = \&IPC::Run::Win32_MODE ;
30
31 ## Win32 does not support a lot of things that Unix does. These
32 ## skip_unless subs help that.
33 ##
34 ## TODO: There are also a few things that Win32 supports (passing Win32 OS
35 ## handles) that we should test for, conversely.
36 sub skip_unless_subs(&) {
37 if ( Win32_MODE ) {
38 return sub {
39 skip "Can't spawn subroutines on $^O", 0 ;
40 } ;
41 }
42 shift ;
43 }
44
45 my $text1 = "Hello world 1\n" ;
46 my $text2 = "Hello world 2\n" ;
47
48 my @perl = ( $^X ) ;
49
50 my @catter = ( @perl, '-pe1' ) ;
51
52 sub slurp($) {
53 my ( $f ) = @_ ;
54 open( S, "<$f" ) or return "$! $f" ;
55 my $r = join( '', <S> ) ;
56 close S ;
57 return $r ;
58 }
59
60
61 sub spit($$) {
62 my ( $f, $s ) = @_ ;
63 open( S, ">$f" ) or die "$! $f" ;
64 print S $s or die "$! $f" ;
65 close S or die "$! $f" ;
66 }
67
68 my ( $h1, $h2 ) ;
69 my ( $out1, $out2 ) ;
70
71 my @tests = (
72
73 sub {
74 $h1 = start \@catter, "<", \$text1, ">", \$out1 ;
75 ok $h1 ;
76 },
77
78 sub {
79 $h2 = start \@catter, "<", \$text2, ">", \$out2 ;
80 ok $h2 ;
81 },
82
83 sub {
84 pump $h1 ;
85 ok 1 ;
86 },
87
88 sub {
89 pump $h2 ;
90 ok 1 ;
91 },
92
93 sub {
94 finish $h1 ;
95 ok 1 ;
96 },
97
98 sub {
99 finish $h2 ;
100 ok 1 ;
101 },
102
103 ) ;
104
105 plan tests => scalar @tests ;
106
107 $_->() for ( @tests ) ;
+273
-0
t/pty.t less more
0 #!/usr/bin/perl -w
1
2 =head1 NAME
3
4 pty.t - Test suite for IPC::Run's pty (psuedo-terminal) support
5
6 =head1 DESCRIPTION
7
8 This test suite starts off with a test that seems to cause a deadlock
9 on freebsd: \@cmd, '<pty<', ... '>', ..., '2>'...
10
11 This seems to cause the child process entry in the process table to
12 hang around after the child exits. Both output pipes are closed, but
13 the PID is still valid so IPC::Run::finish() thinks it's still alive and
14 the whole shebang deadlocks waiting for the child to exit.
15
16 This is a very rare corner condition, so I'm not patching in a fix yet.
17 One fix might be to hack IPC::Run to close the master pty when all outputs
18 from the child are closed. That's a hack, not sure what to do about it.
19
20 This problem needs to be reproduced in a standalone script and investigated
21 further, but I have not the time.
22
23 =cut
24
25 BEGIN {
26 if( $ENV{PERL_CORE} ) {
27 chdir '../lib/IPC/Run' if -d '../lib/IPC/Run';
28 unshift @INC, 'lib', '../..';
29 $^X = '../../../t/' . $^X;
30 }
31 }
32
33
34 use strict ;
35
36 use Test ;
37
38 use IPC::Run::Debug qw( _map_fds );
39 use IPC::Run qw( start pump finish ) ;
40 use UNIVERSAL qw( isa ) ;
41
42 select STDERR ; $| = 1 ; select STDOUT ;
43
44 sub pty_warn {
45 warn "\nWARNING: $_[0].\nWARNING: '<pty<', '>pty>' $_[1] not work.\n\n";
46 }
47
48 if ( $^O !~ /Win32/ ) {
49 # my $min = 0.9 ;
50 for ( eval { require IO::Pty ; IO::Pty->VERSION } ) {
51 s/_//g if defined ;
52 if ( ! defined ) {
53 pty_warn "IO::Pty not found", "will" ;
54 }
55 elsif ( $_ == 0.02 ) {
56 pty_warn "IO::Pty v$_ has spurious warnings, try 0.9 or later", "may"
57 }
58 elsif ( $_ < 1.00 ) {
59 pty_warn "IO::Pty 1.00 is strongly recommended", "may" ;
60 }
61 }
62 }
63
64
65 my $echoer_script = <<TOHERE ;
66 \$| = 1 ;
67 \$s = select STDERR ; \$| = 1 ; select \$s ;
68 while (<>) {
69 print STDERR uc \$_ ;
70 print ;
71 last if /quit/ ;
72 }
73 TOHERE
74
75 ##
76 ## $^X is the path to the perl binary. This is used run all the subprocesses.
77 ##
78 my @echoer = ( $^X, '-e', $echoer_script ) ;
79
80 my $in ;
81 my $out ;
82 my $err;
83
84 my $h ;
85 my $r ;
86
87 my $fd_map ;
88
89 my $text = "hello world\n" ;
90
91 ## TODO: test lots of mixtures of pty's and pipes & files. Use run().
92
93 ## Older Perls can't ok( a, qr// ), so I manually do that here.
94 my $exp ;
95
96 my $platform_skip = $^O =~ /(?:aix|freebsd|openbsd)/ ? "$^O deadlocks on this test" : "" ;
97
98 my @tests = (
99 ##
100 ## stdin only
101 ##
102 sub {
103 return skip $platform_skip, 1 if $platform_skip;
104 $out = 'REPLACE ME' ;
105 $? = 99 ;
106 $fd_map = _map_fds ;
107 $h = start \@echoer, '<pty<', \$in, '>', \$out, '2>', \$err ;
108
109 $in = "hello\n" ;
110 $? = 0 ;
111 pump $h until $out =~ /hello/ && $err =~ /HELLO/ ;
112 ok( $out, "hello\n" ) ;
113 },
114 sub {
115 return skip $platform_skip, 1 if $platform_skip;
116 $exp = qr/^HELLO\n(?!\n)$/ ;
117 $err =~ $exp ? ok( 1 ) : ok( $err, $exp ) ;
118 },
119 sub {
120 return skip $platform_skip, 1 if $platform_skip;
121 ok( $in, '' )
122 },
123
124 sub {
125 return skip $platform_skip, 1 if $platform_skip;
126 $in = "world\n" ;
127 $? = 0 ;
128 pump $h until $out =~ /world/ && $err =~ /WORLD/ ;
129 ok( $out, "hello\nworld\n" ) ;
130 },
131 sub {
132 return skip $platform_skip, 1 if $platform_skip;
133 $exp = qr/^HELLO\nWORLD\n(?!\n)$/ ;
134 $err =~ $exp ? ok( 1 ) : ok( $err, $exp ) ;
135 },
136 sub {
137 return skip $platform_skip, 1 if $platform_skip;
138 ok( $in, '' )
139 },
140
141 sub {
142 return skip $platform_skip, 1 if $platform_skip;
143 $in = "quit\n" ;
144 ok( $h->finish ) ;
145 },
146 sub {
147 return skip $platform_skip, 1 if $platform_skip;
148 ok( ! $? )
149 },
150 sub {
151 return skip $platform_skip, 1 if $platform_skip;
152 ok( _map_fds, $fd_map )
153 },
154
155 ##
156 ## stdout, stderr
157 ##
158 sub {
159 $out = 'REPLACE ME' ;
160 $? = 99 ;
161 $fd_map = _map_fds ;
162 $h = start \@echoer, \$in, '>pty>', \$out ;
163 $in = "hello\n" ;
164 $? = 0 ;
165 pump $h until $out =~ /hello/ ;
166 ## We assume that the slave's write()s are atomic
167 $exp = qr/^(?:hello\r?\n){2}(?!\n)$/i ;
168 $out =~ $exp ? ok( 1 ) : ok( $out, $exp ) ;
169 },
170 sub { ok( $in, '' ) },
171
172 sub {
173 $in = "world\n" ;
174 $? = 0 ;
175 pump $h until $out =~ /world/ ;
176 $exp = qr/^(?:hello\r?\n){2}(?:world\r?\n){2}(?!\n)$/i ;
177 $out =~ $exp ? ok( 1 ) : ok( $out, $exp ) ;
178 },
179 sub { ok( $in, '' ) },
180
181 sub {
182 $in = "quit\n" ;
183 ok( $h->finish ) ;
184 },
185 sub { ok( ! $? ) },
186 sub { ok( _map_fds, $fd_map ) },
187
188 ##
189 ## stdout only
190 ##
191 sub {
192 $out = 'REPLACE ME' ;
193 $? = 99 ;
194 $fd_map = _map_fds ;
195 $h = start \@echoer, \$in, '>pty>', \$out, '2>', \$err ;
196 $in = "hello\n" ;
197 $? = 0 ;
198 pump $h until $out =~ /hello/ && $err =~ /HELLO/ ;
199 $exp = qr/^hello\r?\n(?!\n)$/ ;
200 $out =~ $exp ? ok( 1 ) : ok( $out, $exp ) ;
201 },
202 sub {
203 $exp = qr/^HELLO\n(?!\n)$/ ;
204 $err =~ $exp ? ok( 1 ) : ok( $err, $exp ) ;
205 },
206 sub { ok( $in, '' ) },
207
208 sub {
209 $in = "world\n" ;
210 $? = 0 ;
211 pump $h until $out =~ /world/ && $err =~ /WORLD/ ;
212 $exp = qr/^hello\r?\nworld\r?\n(?!\n)$/ ;
213 $out =~ $exp ? ok( 1 ) : ok( $out, $exp ) ;
214 },
215 sub {
216 $exp = qr/^HELLO\nWORLD\n(?!\n)$/ ,
217 $err =~ $exp ? ok( 1 ) : ok( $err, $exp ) ;
218 },
219 sub { ok( $in, '' ) },
220
221 sub {
222 $in = "quit\n" ;
223 ok( $h->finish ) ;
224 },
225 sub { ok( ! $? ) },
226 sub { ok( _map_fds, $fd_map ) },
227
228 ##
229 ## stdin, stdout, stderr
230 ##
231 sub {
232 $out = 'REPLACE ME' ;
233 $? = 99 ;
234 $fd_map = _map_fds ;
235 $h = start \@echoer, '<pty<', \$in, '>pty>', \$out ;
236 $in = "hello\n" ;
237 $? = 0 ;
238 pump $h until $out =~ /hello.*hello.*hello/is ;
239 ## We assume that the slave's write()s are atomic
240 $exp = qr/^(?:hello\r?\n){3}(?!\n)$/i ;
241 $out =~ $exp ? ok( 1 ) : ok( $out, $exp ) ;
242 },
243 sub { ok( $in, '' ) },
244
245 sub {
246 $in = "world\n" ;
247 $? = 0 ;
248 pump $h until $out =~ /world.*world.*world/is ;
249 $exp = qr/^(?:hello\r?\n){3}(?:world\r?\n){3}(?!\n)$/i ;
250 $out =~ $exp ? ok( 1 ) : ok( $out, $exp ) ;
251 },
252 sub { ok( $in, '' ) },
253
254 sub {
255 $in = "quit\n" ;
256 ok( $h->finish ) ;
257 },
258 sub { ok( ! $? ) },
259 sub { ok( _map_fds, $fd_map ) },
260 ) ;
261
262 plan tests => scalar @tests ;
263
264 unless ( eval { require IO::Pty ; } ) {
265 skip( "skip: IO::Pty not found", 0 ) for @tests ;
266 exit ;
267 }
268
269 print "# Using IO::Tty $IO::Tty::VERSION\n";
270 print "# Using IO::Pty $IO::Pty::VERSION\n";
271
272 $_->() for ( @tests ) ;
+117
-0
t/pump.t less more
0 #!/usr/bin/perl -w
1
2 =head1 NAME
3
4 pump.t - Test suite for IPC::Run::run, etc.
5
6 =cut
7
8 BEGIN {
9 if( $ENV{PERL_CORE} ) {
10 chdir '../lib/IPC/Run' if -d '../lib/IPC/Run';
11 unshift @INC, 'lib', '../..';
12 $^X = '../../../t/' . $^X;
13 }
14 }
15
16 use strict ;
17
18 use Test ;
19
20 use IPC::Run::Debug qw( _map_fds );
21 use IPC::Run qw( start pump finish timeout ) ;
22 use UNIVERSAL qw( isa ) ;
23
24 ##
25 ## $^X is the path to the perl binary. This is used run all the subprocesses.
26 ##
27 my @echoer = ( $^X, '-pe', 'BEGIN { $| = 1 }' ) ;
28
29 my $in ;
30 my $out ;
31
32 my $h ;
33
34 my $fd_map ;
35
36 my @tests = (
37 ##
38 ## harness, pump, run
39 ##
40 sub {
41 $in = 'SHOULD BE UNCHANGED' ;
42 $out = 'REPLACE ME' ;
43 $? = 99 ;
44 $fd_map = _map_fds ;
45 $h = start( \@echoer, \$in, \$out, timeout 5 ) ;
46 ok( isa( $h, 'IPC::Run' ) ) ;
47 },
48 sub { ok( $?, 99 ) },
49
50 sub { ok( $in, 'SHOULD BE UNCHANGED' ) },
51 sub { ok( $out, '' ) },
52 sub { ok( $h->pumpable ) },
53
54 sub {
55 $in = '' ;
56 $? = 0 ;
57 pump_nb $h for ( 1..100 ) ;
58 ok( 1 ) ;
59 },
60 sub { ok( $in, '' ) },
61 sub { ok( $out, '' ) },
62 sub { ok( $h->pumpable ) },
63
64 sub {
65 $in = "hello\n" ;
66 $? = 0 ;
67 pump $h until $out =~ /hello/ ;
68 ok( 1 ) ;
69 },
70 sub { ok( ! $? ) },
71 sub { ok( $in, '' ) },
72 sub { ok( $out, "hello\n" ) },
73 sub { ok( $h->pumpable ) },
74
75 sub {
76 $in = "world\n" ;
77 $? = 0 ;
78 pump $h until $out =~ /world/ ;
79 ok( 1 ) ;
80 },
81 sub { ok( ! $? ) },
82 sub { ok( $in, '' ) },
83 sub { ok( $out, "hello\nworld\n" ) },
84 sub { ok( $h->pumpable ) },
85
86 ## Test \G pos() restoral
87 sub {
88 $in = "hello\n" ;
89 $out = "" ;
90 $? = 0 ;
91 pump $h until $out =~ /hello\n/g ;
92 ok( 1 ) ;
93 },
94
95 sub {
96 ok pos( $out ), 6, "pos\$out" ;
97 },
98
99 sub {
100 $in = "world\n" ;
101 $? = 0 ;
102 pump $h until $out =~ /\Gworld/gc ;
103 ok( 1 ) ;
104 },
105
106
107 sub { ok( $h->finish ) },
108 sub { ok( ! $? ) },
109 sub { ok( _map_fds, $fd_map ) },
110 sub { ok( $out, "hello\nworld\n" ) },
111 sub { ok( ! $h->pumpable ) },
112 ) ;
113
114 plan tests => scalar @tests ;
115
116 $_->() for ( @tests ) ;
+1073
-0
t/run.t less more
0 #!/usr/bin/perl -w
1
2 =head1 NAME
3
4 run.t - Test suite for IPC::Run::run, etc.
5
6 =cut
7
8 BEGIN {
9 if( $ENV{PERL_CORE} ) {
10 chdir '../lib/IPC/Run' if -d '../lib/IPC/Run';
11 unshift @INC, 'lib', '../..';
12 $^X = '../../../t/' . $^X;
13 }
14 }
15
16
17 ## Handy to have when our output is intermingled with debugging output sent
18 ## to the debugging fd.
19 $| = 1 ;
20 select STDERR ; $| = 1 ; select STDOUT ;
21
22 use strict ;
23
24 use Test ;
25
26 use IPC::Run::Debug qw( _map_fds );
27 use IPC::Run qw( :filters :filter_imp start filter_tests Win32_MODE ) ;
28
29 sub run { IPC::Run::run( ref $_[0] ? ( noinherit => 1 ) : (), @_ ) }
30
31 use UNIVERSAL qw( isa ) ;
32
33 ## Test at least some of the win32 PATHEXT logic
34 my $perl = $^X;
35 $perl =~ s/\.\w+\z// if Win32_MODE;
36
37 ## Win32 does not support a lot of things that Unix does. These
38 ## skip_unless subs help that.
39 ##
40 ## TODO: There are also a few things that Win32 supports (passing Win32 OS
41 ## handles) that we should test for, conversely.
42 sub skip_unless_subs(&) {
43 if ( Win32_MODE ) {
44 return sub {
45 skip "Can't spawn subroutines on $^O", 0 ;
46 } ;
47 }
48 shift ;
49 }
50
51 sub skip_unless_shell(&) {
52 if ( Win32_MODE ) {
53 return sub {
54 skip "$^O's shell returns 0 even if last command doesn't", 0 ;
55 } ;
56 }
57 shift ;
58 }
59
60 sub skip_unless_high_fds(&) {
61 if ( Win32_MODE ) {
62 return sub {
63 skip "$^O does not allow redirection of file descriptors > 2", 0 ;
64 } ;
65 }
66 shift ;
67 }
68
69
70 sub _unlink {
71 my ( $f ) = @_;
72 my $tries;
73 while () {
74 return if unlink $f;
75 if ( $^O =~ /Win32/ && ++$tries <= 10 ) {
76 print STDOUT "# Waiting for Win32 to allow $f to be unlinked ($!)\n";
77 select undef, undef, undef, 0.1;
78 next;
79 }
80 die "$! unlinking $f at ", join( ", line ", (caller)[1,2] ), "\n";
81 }
82 }
83
84
85 my $text = "Hello World\n" ;
86
87 my @perl = ( $perl ) ;
88
89 my $emitter_script =
90 qq{print '$text' ; print STDERR uc( '$text' ) unless \@ARGV } ;
91 my @emitter = ( @perl, '-e', $emitter_script ) ;
92
93 my $in ;
94 my $out ;
95 my $err ;
96
97 my $in_file = 'run.t.in' ;
98 my $out_file = 'run.t.out' ;
99 my $err_file = 'run.t.err' ;
100
101 my $h ;
102
103 # initialized during the first test
104 my $fd_map;
105
106 sub slurp($) {
107 my ( $f ) = @_ ;
108 open( S, "<$f" ) or return "$! $f" ;
109 my $r = join( '', <S> ) ;
110 close S or warn "$!: $f";
111 select 0.1 if $^O =~ /Win32/;
112 return $r ;
113 }
114
115
116 sub spit($$) {
117 my ( $f, $s ) = @_ ;
118 open( S, ">$f" ) or die "$! $f" ;
119 print S $s or die "$! $f" ;
120 close S or die "$! $f" ;
121 }
122
123 ##
124 ## A grossly inefficient filter to test filter
125 ## chains. It's inefficient because we want to make sure that the
126 ## filter chain flushing logic works. The inefficiency is that it
127 ## doesn't process as much input as it could each call, so lots of calls
128 ## are required.
129 ##
130 sub alt_casing_filter {
131 my ( $in_ref, $out_ref ) = @_ ;
132 return input_avail && do {
133 $$out_ref .= lc( substr( $$in_ref, 0, 1, '' ) ) ;
134 1 ;
135 } && (
136 ! input_avail || do {
137 $$out_ref .= uc( substr( $$in_ref, 0, 1, '' ) ) ;
138 1 ;
139 }
140 ) ;
141 }
142
143
144 sub case_inverting_filter {
145 my ( $in_ref, $out_ref ) = @_ ;
146 return input_avail && do {
147 $$in_ref =~ tr/a-zA-Z/A-Za-z/ ;
148 $$out_ref .= $$in_ref ;
149 $$in_ref = '' ;
150 1 ;
151 } ;
152 }
153
154
155 sub eok {
156 my ( $got, $exp ) = ( shift, shift );
157 $got =~ s/([\000-\037])/sprintf "\\0x%02x", ord $1/ge if defined $exp;
158 $exp =~ s/([\000-\037])/sprintf "\\0x%02x", ord $1/ge if defined $exp;
159 @_ = ( $got, $exp, @_ );
160 goto &ok;
161 }
162
163
164 my $r ;
165
166
167 my @tests = (
168
169 sub { ok( _map_fds, $fd_map ) ; $fd_map = _map_fds },
170
171 ##
172 ## Internal testing
173 ##
174 filter_tests(
175 "alt_casing_filter",
176 "Hello World",
177 ["hElLo wOrLd" =~ m/(..?)/g],
178 \&alt_casing_filter
179 ),
180
181 sub { ok( _map_fds, $fd_map ) ; $fd_map = _map_fds },
182
183 filter_tests(
184 "case_inverting_filter",
185 "Hello World",
186 "hELLO wORLD",
187 \&case_inverting_filter
188 ),
189
190 sub { ok( _map_fds, $fd_map ) ; $fd_map = _map_fds },
191
192 ##
193 ## Calling the local system shell
194 ##
195 sub { ok run qq{$perl -e exit} },
196 sub { ok $?, 0 },
197
198 sub { ok( _map_fds, $fd_map ) ; $fd_map = _map_fds },
199
200 skip_unless_shell { ok ! run qq{$perl -e 'exit(42)'} },
201 skip_unless_shell { ok $? },
202 skip_unless_shell { ok $? >> 8, 42 },
203
204 sub { ok( _map_fds, $fd_map ) ; $fd_map = _map_fds },
205
206 ##
207 ## Simple commands, not executed via shell
208 ##
209 sub { ok( run $perl, qw{-e exit} ) },
210 sub { ok( $?, 0 ) },
211
212 sub { ok( _map_fds, $fd_map ) ; $fd_map = _map_fds },
213
214 sub { ok( ! run $perl, qw{-e exit(42)} ) },
215 sub { ok( $? ) },
216 sub { ok $? >> 8, 42 },
217
218 sub { ok( _map_fds, $fd_map ) ; $fd_map = _map_fds },
219
220 ##
221 ## A function
222 ##
223 skip_unless_subs { ok run sub{} },
224 skip_unless_subs { ok $?, 0 },
225 skip_unless_subs { ok !run sub{ exit 42 } },
226 skip_unless_subs { ok $? },
227 skip_unless_subs { ok $? >> 8, 42 },
228
229 sub { ok( _map_fds, $fd_map ) ; $fd_map = _map_fds },
230
231 ##
232 ## A function, and an init function
233 ##
234 skip_unless_subs {
235 my $e = 0 ;
236 ok(
237 ! run(
238 sub{ exit($e) },
239 init => sub { $e = 42 }
240 )
241 ) ;
242 },
243 skip_unless_subs { ok( $? ) },
244
245 sub { ok( _map_fds, $fd_map ) ; $fd_map = _map_fds },
246
247 ##
248 ## scalar ref I & O redirection using op tokens
249 ##
250 sub {
251 $out = 'REPLACE ME' ;
252 $fd_map = _map_fds ;
253 $r = run [ @emitter, "nostderr" ], '>', \$out ;
254 ok( $r ) ;
255 },
256 sub { ok( ! $? ) },
257 sub { ok( _map_fds, $fd_map ) },
258 sub { eok( $out, $text ) },
259
260 sub {
261 $out = 'REPLACE ME' ;
262 $fd_map = _map_fds ;
263 $r = run [ @emitter, "nostderr" ], '<', \undef, '>', \$out ;
264 ok( $r ) ;
265 },
266 sub { ok( ! $? ) },
267 sub { ok( _map_fds, $fd_map ) },
268 sub { eok( $out, $text ) },
269 sub {
270 $in = $emitter_script ;
271 $out = 'REPLACE ME' ;
272 $err = 'REPLACE ME' ;
273 $fd_map = _map_fds ;
274 $r = run \@perl, '<', \$in, '>', \$out, '2>', \$err, ;
275 ok( $r ) ;
276 },
277 sub { ok( ! $? ) },
278 sub { ok( _map_fds, $fd_map ) },
279
280 sub { eok( $in, $emitter_script ) },
281 sub { eok( $out, $text ) },
282 sub { eok( $err, uc( $text ) ) },
283 ##
284 ## scalar ref I & O redirection, succinct mode.
285 ##
286 sub {
287 $in = $emitter_script ;
288 $out = 'REPLACE ME' ;
289 $err = 'REPLACE ME' ;
290 $fd_map = _map_fds ;
291 $r = run \@perl, \$in, \$out, \$err ;
292 ok( $r ) ;
293 },
294 sub { ok( ! $? ) },
295 sub { ok( _map_fds, $fd_map ) },
296
297 sub { eok( $in, $emitter_script ) },
298 sub { eok( $out, $text ) },
299 sub { eok( $err, uc( $text ) ) },
300
301 ##
302 ## Long output, to test for blocking read.
303 ##
304 ## Assume pipe buffer length <= 10000, need to double that to assure enough
305 ## chars to fill a buffer so. This test adapted from a test submitted by
306 ## Borislav Deianov <borislav@ensim.com>.
307 sub {
308 $in = "-" x 20000 . "end\n" ;
309 $out = 'REPLACE ME' ;
310 $fd_map = _map_fds ;
311 $r = run [ $perl, qw{-e print"-"x20000;<STDIN>;} ], \$in, \$out ;
312 ok( $r ) ;
313 },
314 sub { ok( ! $? ) },
315 sub { ok( _map_fds, $fd_map ) },
316
317 sub { ok( length $out, 20000 ) },
318 sub { ok( $out !~ /[^-]/ ) },
319
320
321 ##
322 ## Long output run through twice
323 ##
324 ## Adapted from a stress test by Aaron Elkiss <aelkiss@wam.umd.edu>
325 ##
326 sub {
327 $h = start [$perl, qw( -pe BEGIN{$|=1}1 )], \$in, \$out;
328
329 $in = "\n";
330 $out = "";
331 pump $h until length $out;
332 ok $out eq "\n";
333 },
334
335 sub {
336 my $long_string = "x" x 20000 . "DOC2\n";
337 $in = $long_string;
338 $out = "";
339 my $ok_1 = eval {
340 pump $h until $out =~ /DOC2/;
341 1;
342 };
343 my $x = $@;
344 my $ok_2 = eval {
345 finish $h;
346 1;
347 };
348
349 $x = $@ if $ok_1 && ! $ok_2;
350
351 if ( $ok_1 && $ok_2 ) {
352 ok $long_string eq $out;
353 }
354 else {
355 $x =~ s/(x+)/sprintf "...%d \"x\" chars...", length $1/e;
356 ok $x, "";
357 }
358 },
359
360 ##
361 ## child function, scalar ref I & O redirection, succinct mode.
362 ##
363 skip_unless_subs {
364 $in = $text ;
365 $out = 'REPLACE ME' ;
366 $err = 'REPLACE ME' ;
367 $fd_map = _map_fds ;
368 $r = run(
369 sub { while (<>) { print ; print STDERR uc( $_ ) } },
370 \$in, \$out, \$err
371 ) ;
372 ok( $r ) ;
373 },
374 skip_unless_subs { ok ! $? },
375 skip_unless_subs { ok( _map_fds, $fd_map ) },
376
377 skip_unless_subs { eok( $in, $text ) },
378 skip_unless_subs { eok( $out, $text ) },
379 skip_unless_subs { eok( $err, uc( $text ) ) },
380
381 ##
382 ## here document as input
383 ##
384 sub {
385 $out = 'REPLACE ME' ;
386 $err = 'REPLACE ME' ;
387 $fd_map = _map_fds ;
388 $r = run \@perl, \<<TOHERE, \$out, \$err ;
389 $emitter_script
390 TOHERE
391 ok( $r ) ;
392 },
393 sub { ok( ! $? ) },
394 sub { ok( _map_fds, $fd_map ) },
395
396 sub { eok( $out, $text ) },
397 sub { eok( $err, uc( $text ) ) },
398
399 ##
400 ## undef as input
401 ##
402 sub {
403 $out = 'REPLACE ME' ;
404 $err = 'REPLACE ME' ;
405 $fd_map = _map_fds ;
406 $r = run \@perl, \undef, \$out, \$err ;
407 ok( $r ) ;
408 },
409 sub { ok( ! $? ) },
410 sub { ok( _map_fds, $fd_map ) },
411
412 sub { eok( $out, '' ) },
413 sub { eok( $err, '' ) },
414
415 ##
416 ## filehandle input redirection
417 ##
418 sub {
419 $out = 'REPLACE ME' ;
420 $err = 'REPLACE ME' ;
421 $fd_map = _map_fds ;
422 spit( $in_file, $emitter_script ) ;
423 open( F, "<$in_file" ) or die "$! $in_file" ;
424 $r = run \@perl, \*F, \$out, \$err ;
425 close F ;
426 unlink $in_file or warn "$! $in_file" ;
427 ok( $r ) ;
428 },
429 sub { ok( ! $? ) },
430 sub { ok( _map_fds, $fd_map ) },
431
432 sub { eok( $out, $text ) },
433 sub { eok( $err, uc( $text ) ) },
434
435 ##
436 ## input redirection via caller writing directly to a pipe
437 ##
438 sub {
439 $out = 'REPLACE ME' ;
440 $err = 'REPLACE ME' ;
441 $fd_map = _map_fds ;
442 $h = start \@perl, '<pipe', \*IN, '>', \$out, '2>', \$err ;
443 ## Assume this won't block...
444 print IN $emitter_script ;
445 close IN or warn $! ;
446 $r = $h->finish ;
447 ok( $r ) ;
448 },
449 sub { ok( ! $? ) },
450 sub { ok( _map_fds, $fd_map ) },
451
452 sub { eok( $out, $text ) },
453 sub { eok( $err, uc( $text ) ) },
454
455 ##
456 ## filehandle input redirection, passed via *F{IO}
457 ##
458 sub {
459 $out = 'REPLACE ME' ;
460 $err = 'REPLACE ME' ;
461 $fd_map = _map_fds ;
462 spit( $in_file, $emitter_script ) ;
463 open( F, "<$in_file" ) or die "$! $in_file" ;
464 $r = run \@perl, *F{IO}, \$out, \$err ;
465 close F ;
466 _unlink $in_file;
467 ok( $r ) ;
468 },
469 sub { ok( ! $? ) },
470 sub { ok( _map_fds, $fd_map ) },
471
472 sub { eok( $out, $text ) },
473 sub { eok( $err, uc( $text ) ) },
474
475 ##
476 ## filehandle output redirection
477 ##
478 sub {
479 $fd_map = _map_fds ;
480 open( OUT, ">$out_file" ) or die "$! $out_file" ;
481 open( ERR, ">$err_file" ) or die "$! $err_file" ;
482 print OUT "out: " ;
483 print ERR uc( "err: " ) ;
484 $r = run \@emitter, \undef, \*OUT, \*ERR ;
485 print OUT " more out data" ;
486 print ERR uc( " more err data" ) ;
487 close OUT ;
488 close ERR ;
489 $out = slurp( $out_file ) ;
490 $err = slurp( $err_file ) ;
491 _unlink $out_file;
492 _unlink $err_file;
493 ok( $r ) ;
494 },
495 sub { ok( ! $? ) },
496 sub { ok( _map_fds, $fd_map ) },
497
498 sub { eok( $out, "out: $text more out data" ) },
499 sub { eok( $err, uc( "err: $text more err data" ) ) },
500
501 ##
502 ## filehandle output redirection via a pipe that is returned to the caller
503 ##
504 sub {
505 $fd_map = _map_fds ;
506 my $r = run \@emitter, \undef, '>pipe', \*OUT, '2>pipe', \*ERR ;
507 $out = '' ;
508 $err = '' ;
509 read OUT, $out, 10000 or warn $!;
510 read ERR, $err, 10000 or warn $!;
511 close OUT or warn $! ;
512 close ERR or warn $! ;
513 ok( $r ) ;
514 },
515 sub { ok( ! $? ) },
516 sub { ok( _map_fds, $fd_map ) },
517
518 sub { eok( $out, $text ) },
519 sub { eok( $err, uc( $text ) ) },
520
521 ##
522 ## sub I & O redirection
523 ##
524 sub {
525 $in = $emitter_script ;
526 $out = undef ;
527 $err = undef ;
528 $fd_map = _map_fds ;
529 $r = run(
530 \@perl,
531 '<', sub { my $f = $in ; $in = undef ; return $f },
532 '>', sub { $out .= shift },
533 '2>', sub { $err .= shift },
534 ) ;
535 ok( $r ) ;
536 },
537 sub { ok( ! $? ) },
538 sub { ok( _map_fds, $fd_map ) },
539
540 sub { eok( $out, $text ) },
541 sub { eok( $err, uc( $text ) ) },
542
543 ##
544 ## input redirection from a file
545 ##
546 sub {
547 $out = undef ;
548 $err = undef ;
549 $fd_map = _map_fds ;
550 spit( $in_file, $emitter_script ) ;
551 $r = run(
552 \@perl,
553 "<$in_file",
554 '>', sub { $out .= shift },
555 '2>', sub { $err .= shift },
556 ) ;
557 _unlink $in_file;
558 ok( $r ) ;
559 },
560 sub { ok( ! $? ) },
561 sub { ok( _map_fds, $fd_map ) },
562
563 sub { eok( $out, $text ) },
564 sub { eok( $err, uc( $text ) ) },
565
566 ##
567 ## reading input from a non standard fd
568 ##
569 skip_unless_high_fds {
570 $out = undef ;
571 $err = undef ;
572 $fd_map = _map_fds ;
573 $r = run(
574 ## FreeBSD doesn't guarantee that fd 3 or 4 are available, so
575 ## don't assume, go for 5.
576 [ @perl, '-le', 'open( STDIN, "<&5" ) or die $! ; print <STDIN>' ],
577 "5<", \"Hello World",
578 '>', \$out,
579 '2>', \$err,
580 ) ;
581 ok( $r ) ;
582 },
583 skip_unless_high_fds { ok( ! $? ) },
584 skip_unless_high_fds { ok( _map_fds, $fd_map ) },
585
586 skip_unless_high_fds { eok( $out, $text ) },
587 skip_unless_high_fds { eok( $err, '' ) },
588
589 ##
590 ## duping input descriptors and an input descriptor > 0
591 ##
592 skip_unless_high_fds {
593 $in = $emitter_script ;
594 $out = 'REPLACE ME' ;
595 $err = 'REPLACE ME' ;
596 $fd_map = _map_fds ;
597 $r = run(
598 \@perl,
599 '>', \$out,
600 '2>', \$err,
601 '3<', \$in,
602 '0<&3',
603 ) ;
604 ok( $r ) ;
605 },
606 skip_unless_high_fds { ok( ! $? ) },
607 skip_unless_high_fds { ok( _map_fds, $fd_map ) },
608 skip_unless_high_fds { eok( $in, $emitter_script ) },
609 skip_unless_high_fds { eok( $out, $text ) },
610 skip_unless_high_fds { eok( $err, uc( $text ) ) },
611
612 ##
613 ## closing input descriptors
614 ##
615 sub {
616 $out = 'REPLACE ME' ;
617 $err = 'REPLACE ME' ;
618 $fd_map = _map_fds ;
619 spit( $in_file, $emitter_script ) ;
620 $r = run(
621 [ @perl, '-e', '$l = readline *STDIN or die $! ; print $l' ],
622 '>', \$out,
623 '2>', \$err,
624 '<', $in_file,
625 '0<&-',
626 ) ;
627 _unlink $in_file;
628 ok( ! $r ) ;
629 },
630 sub { ok( $? ) },
631 sub { ok( _map_fds, $fd_map ) },
632 sub { eok( $out, '' ) },
633 #sub { ok( $err =~ /file descriptor/i ? "Bad file descriptor error" : $err, "Bad file descriptor error" ) },
634 # XXX This should be use Errno; if $!{EBADF}. --rs
635 sub { ok( length $err ? "Bad file descriptor error" : $err, "Bad file descriptor error" ) },
636
637 ##
638 ## input redirection from a non-existent file
639 ##
640 sub {
641 $out = 'REPLACE ME' ;
642 $err = 'REPLACE ME' ;
643 $fd_map = _map_fds ;
644 my $bad_file = "$in_file.nonexistant" ;
645 _unlink $bad_file if -e $bad_file;
646 eval {
647 $r = run \@perl, ">$out_file", "<$bad_file" ;
648 } ;
649 if ( $@ =~ /\Q$bad_file\E/ ) {
650 ok 1 ;
651 }
652 else {
653 ok $@, "qr/\Q$bad_file\E/" ;
654 }
655 },
656 sub { ok( _map_fds, $fd_map ) },
657
658 ##
659 ## output redirection to a file w/ creation or truncation
660 ##
661 sub {
662 $fd_map = _map_fds ;
663 _unlink $out_file if -x $out_file;
664 _unlink $err_file if -x $err_file;
665 $r = run(
666 \@emitter,
667 ">$out_file",
668 "2>$err_file",
669 ) ;
670 $out = slurp( $out_file ) ;
671 $err = slurp( $err_file ) ;
672 ok( $r ) ;
673 },
674 sub { ok( ! $? ) },
675 sub { ok( _map_fds, $fd_map ) },
676
677 sub { eok( $out, $text ) },
678 sub { eok( $err, uc( $text ) ) },
679
680 ##
681 ## output file redirection, w/ truncation
682 ##
683 sub {
684 $fd_map = _map_fds ;
685 spit( $out_file, 'out: ' ) ;
686 spit( $err_file, 'ERR: ' ) ;
687 $r = run(
688 \@emitter,
689 ">$out_file",
690 "2>$err_file",
691 ) ;
692 $out = slurp( $out_file ) ; _unlink $out_file;
693 $err = slurp( $err_file ) ; _unlink $err_file;
694 ok( $r ) ;
695 },
696 sub { ok( ! $? ) },
697 sub { ok( _map_fds, $fd_map ) },
698
699 sub { eok( $out, $text ) },
700 sub { eok( $err, uc( $text ) ) },
701
702 ##
703 ## output file redirection w/ append
704 ##
705 sub {
706 spit( $out_file, 'out: ' ) ;
707 spit( $err_file, 'ERR: ' ) ;
708 $fd_map = _map_fds ;
709 $r = run(
710 \@emitter,
711 ">>$out_file",
712 "2>>$err_file",
713 ) ;
714 $out = slurp( $out_file ) ;
715 _unlink $out_file;
716 $err = slurp( $err_file ) ;
717 _unlink $err_file;
718 ok( $r ) ;
719 },
720 sub { ok( ! $? ) },
721 sub { ok( _map_fds, $fd_map ) },
722
723 sub { eok( $out, "out: $text" ) },
724 sub { eok( $err, uc( "err: $text" ) ) },
725 ##
726 ## dup()ing output descriptors
727 ##
728 sub {
729 $out = 'REPLACE ME' ;
730 $err = 'REPLACE ME' ;
731 $fd_map = _map_fds ;
732 $r = run \@emitter, '>', \$out, '2>', \$err, '2>&1' ;
733 ok( $r ) ;
734 },
735 sub { ok( ! $? ) },
736 sub { ok( _map_fds, $fd_map ) },
737 sub { $out =~ /(?:$text){2}/i ? ok 1 : ok $out, "qr/($text){2}/i" },
738 sub { eok( $err, '' ) },
739
740 ##
741 ## stderr & stdout redirection to the same file via >&word
742 ##
743 sub {
744 $fd_map = _map_fds ;
745 _unlink $out_file if -x $out_file;
746 $r = run \@emitter, ">&$out_file" ;
747 $out = slurp( $out_file ) ;
748 ok( $r ) ;
749 },
750 sub { ok( ! $? ) },
751 sub { ok( _map_fds, $fd_map ) },
752
753 sub { ok( $out =~ qr/(?:$text){2}/i ) },
754
755 ##
756 ## Non-zero exit value, command with args, no redirects.
757 ##
758 sub {
759 $fd_map = _map_fds ;
760 $r = run [ @perl, '-e', 'exit(42)' ] ;
761 ok( !$r ) ;
762 },
763 sub { ok( $?, 42 << 8 ) },
764 sub { ok( _map_fds, $fd_map ) },
765
766 ##
767 ## Zero exit value, command with args, no redirects.
768 ##
769 sub {
770 $fd_map = _map_fds ;
771 $r = run [ @perl, qw{ -e exit }] ;
772 ok( $r ) ;
773 },
774 sub { ok( ! $? ) },
775 sub { ok( _map_fds, $fd_map ) },
776
777 ##
778 ## dup()ing output descriptors that collide.
779 ##
780 ## This test assumes that our caller doesn't leave a lot of fds opened,
781 ## and assumes that $out_file will be opened on fd 3, 4 or 5.
782 ##
783 skip_unless_high_fds {
784 $out = 'REPLACE ME' ;
785 $err = 'REPLACE ME' ;
786 _unlink $out_file if -x $out_file;
787 $fd_map = _map_fds ;
788 $r = run(
789 \@emitter,
790 "<", \"",
791 "3>&1", "4>&1", "5>&1",
792 ">$out_file",
793 '2>', \$err,
794 ) ;
795 $out = slurp( $out_file ) ;
796 _unlink $out_file;
797 ok( $r ) ;
798 },
799 skip_unless_high_fds { ok( ! $? ) },
800 skip_unless_high_fds { ok( _map_fds, $fd_map ) },
801 skip_unless_high_fds { eok( $out, $text ) },
802 skip_unless_high_fds { eok( $err, uc( $text ) ) },
803
804 ##
805 ## Pipelining
806 ##
807 sub {
808 $out = 'REPLACE ME' ;
809 $err = 'REPLACE ME' ;
810 $fd_map = _map_fds ;
811 $r = run(
812 [ @perl, '-lane', 'print STDERR "1:$_" ; print uc($F[0])," ",$F[1]'],
813 \"Hello World",
814 '|',[ @perl, '-lane', 'print STDERR "2:$_" ; print $F[0]," ",lc($F[1])'],
815 \$out,
816 \$err,
817 ) ;
818 ok( $r ) ;
819 },
820 sub { ok( ! $? ) },
821 sub { ok( _map_fds, $fd_map ) },
822 sub { eok( $out, "HELLO world\n" ) },
823 sub { eok( $err, "1:Hello World\n2:HELLO World\n" ) },
824
825 ##
826 ## Parallel (unpiplined) processes
827 ##
828 sub {
829 $out = 'REPLACE ME' ;
830 $err = 'REPLACE ME' ;
831 $fd_map = _map_fds ;
832 $r = run(
833 [ @perl, '-lane', 'print STDERR "1:$_" ; print uc($F[0])," ",$F[1]' ],
834 \"Hello World",
835 '&', [ @perl, '-lane', 'print STDERR "2:$_" ; print $F[0]," ",lc( $F[1] )' ],
836 \"Hello World",
837 \$out,
838 \$err,
839 ) ;
840 ok( $r ) ;
841 },
842 sub { ok( ! $? ) },
843 sub { ok( _map_fds, $fd_map ) },
844 sub { ok( $out =~ qr/^(?:HELLO World\n|Hello world\n){2}$/s ) },
845 sub { ok( $err =~ qr/^(?:[12]:Hello World.*){2}$/s ) },
846
847 ##
848 ## A few error cases...
849 ##
850 sub {
851 eval { $r = run \@perl, '<', [], [] } ;
852 ok( $@ =~ qr/not allowed/ ) ;
853 },
854
855 sub {
856 eval { $r = run \@perl, '>', [], [] } ;
857 ok( $@ =~ qr/not allowed/ ) ;
858 },
859
860 (
861 map {
862 my $foo = $_ ;
863 sub {
864 eval { $r = run $foo, [] } ;
865 ok( $@ =~ qr/command/ ) ;
866 }
867 } qw( | & < > >& 1>&2 >file <file 2<&1 <&- 3<&- )
868 ),
869 sub {
870 $out = 'REPLACE ME' ;
871 $err = 'REPLACE ME' ;
872 $fd_map = _map_fds ;
873 eval {
874 $r = run( \@emitter, '>', \$out, '2>', \$err,
875 _simulate_fork_failure => 1
876 ) ;
877 } ;
878 ok( $@ ) ;
879 },
880 sub { ok( ! $? ) },
881 sub { ok( _map_fds, $fd_map ) },
882
883 sub { eok( $out, '' ) },
884 sub { eok( $err, '' ) },
885
886 sub {
887 $fd_map = _map_fds ;
888 eval {
889 $r = run \@perl, '<file', _simulate_open_failure => 1 ;
890 } ;
891 ok( $@ ) ;
892 },
893 sub { ok( ! $? ) },
894 sub { ok( _map_fds, $fd_map ) },
895
896 sub {
897 $fd_map = _map_fds ;
898 eval {
899 $r = run \@perl, '>file', _simulate_open_failure => 1 ;
900 } ;
901 ok( $@ ) ;
902 },
903 sub { ok( ! $? ) },
904 sub { ok( _map_fds, $fd_map ) },
905
906 ##
907 ## harness, pump, run
908 ##
909 sub {
910 $in = 'SHOULD BE UNCHANGED' ;
911 $out = 'REPLACE ME' ;
912 $err = 'REPLACE ME' ;
913 $? = 99 ;
914 $fd_map = _map_fds ;
915 $h = start(
916 [ @perl, '-pe', 'BEGIN { $| = 1 } print STDERR uc($_)' ],
917 \$in, \$out, \$err,
918 ) ;
919 ok( isa( $h, 'IPC::Run' ) ) ;
920 },
921 sub { ok( $?, 99 ) },
922
923 sub { eok( $in, 'SHOULD BE UNCHANGED' ) },
924 sub { eok( $out, '' ) },
925 sub { eok( $err, '' ) },
926 sub { ok( $h->pumpable ) },
927
928 sub {
929 $in = '' ;
930 $? = 0 ;
931 pump_nb $h for ( 1..100 ) ;
932 ok( 1 ) ;
933 },
934 sub { eok( $in, '' ) },
935 sub { eok( $out, '' ) },
936 sub { eok( $err, '' ) },
937 sub { ok( $h->pumpable ) },
938
939 sub {
940 $in = $text ;
941 $? = 0 ;
942 pump $h until $out =~ /Hello World/ ;
943 ok( 1 ) ;
944 },
945 sub { ok( ! $? ) },
946 sub { eok( $in, '' ) },
947 sub { eok( $out, $text ) },
948 sub { ok( $h->pumpable ) },
949
950 sub { ok( $h->finish ) },
951 sub { ok( ! $? ) },
952 sub { ok( _map_fds, $fd_map ) },
953 sub { eok( $out, $text ) },
954 sub { eok( $err, uc( $text ) ) },
955 sub { ok( ! $h->pumpable ) },
956
957 ##
958 ## start, run, run, run. See Tom run. A do-run-run, a-do-run-run.
959 ##
960 sub {
961 $in = 'SHOULD BE UNCHANGED' ;
962 $out = 'REPLACE ME' ;
963 $err = 'REPLACE ME' ;
964 $fd_map = _map_fds ;
965 $h = start(
966 [ @perl, '-pe', 'binmode STDOUT ; binmode STDERR ; BEGIN { $| = 1 } print STDERR uc($_)' ],
967 \$in, \$out, \$err,
968 ) ;
969 ok( isa( $h, 'IPC::Run' ) ) ;
970 },
971
972 sub { eok( $in, 'SHOULD BE UNCHANGED' ) },
973 sub { eok( $out, '' ) },
974 sub { eok( $err, '' ) },
975 sub { ok( $h->pumpable ) },
976
977 sub {
978 $in = $text ;
979 ok( $h->finish )
980 },
981 sub { ok( ! $? ) },
982 sub { ok( _map_fds, $fd_map ) },
983 sub { eok( $in, '' ) },
984 sub { eok( $out, $text ) },
985 sub { eok( $err, uc( $text ) ) },
986 sub { ok( ! $h->pumpable ) },
987
988 sub {
989 $in = $text ;
990 $out = 'REPLACE ME' ;
991 $err = 'REPLACE ME' ;
992 ok( $h->run )
993 },
994 sub { ok( ! $? ) },
995 sub { ok( _map_fds, $fd_map ) },
996 sub { eok( $in, $text ) },
997 sub { eok( $out, $text ) },
998 sub { eok( $err, uc( $text ) ) },
999 sub { ok( ! $h->pumpable ) },
1000
1001 sub {
1002 $in = $text ;
1003 $out = 'REPLACE ME' ;
1004 $err = 'REPLACE ME' ;
1005 ok( $h->run )
1006 },
1007 sub { ok( ! $? ) },
1008 sub { ok( _map_fds, $fd_map ) },
1009 sub { eok( $in, $text ) },
1010 sub { eok( $out, $text ) },
1011 sub { eok( $err, uc( $text ) ) },
1012 sub { ok( ! $h->pumpable ) },
1013
1014 ##
1015 ## Output filters
1016 ##
1017 sub {
1018 $out = 'REPLACE ME' ;
1019 $err = 'REPLACE ME' ;
1020 $fd_map = _map_fds ;
1021 $r = run(
1022 \@emitter,
1023 '>',
1024 \&alt_casing_filter,
1025 \&case_inverting_filter,
1026 \$out,
1027 '2>', \$err,
1028 ) ;
1029 ok( $r ) ;
1030 },
1031 sub { ok( ! $? ) },
1032 sub { ok( _map_fds, $fd_map ) },
1033
1034 sub { eok( $out, "HeLlO WoRlD\n" ) },
1035 sub { eok( $err, uc( $text ) ) },
1036
1037 ##
1038 ## Input filters
1039 ##
1040 sub {
1041 $out = 'REPLACE ME' ;
1042 $err = 'REPLACE ME' ;
1043 $fd_map = _map_fds ;
1044 $in = $text ;
1045 $r = run(
1046 [ @perl, '-pe', 'binmode STDOUT ; binmode STDERR ; print STDERR uc $_' ],
1047 '0<',
1048 \&case_inverting_filter,
1049 \&alt_casing_filter,
1050 \$in,
1051 '1>', \$out,
1052 '2>', \$err,
1053 ) ;
1054 ok( $r ) ;
1055 },
1056 sub { ok( ! $? ) },
1057 sub { ok( _map_fds, $fd_map ) },
1058
1059 sub { eok( $in, $text ) },
1060 sub { eok( $out, "HeLlO WoRlD\n" ) },
1061 sub { eok( $err, uc( $text ) ) },
1062 ) ;
1063
1064 plan tests => scalar @tests, todo => [ 69 ] ;
1065
1066 # Must do this this late as plan uses localtime, and localtime on darwin opens
1067 # a file descriptor. Quite probably other operating systems do file descriptor
1068 # things during the test setup.
1069
1070 $fd_map = _map_fds ;
1071
1072 $_->() for ( @tests ) ;
+88
-0
t/signal.t less more
0 #!/usr/bin/perl -w
1
2 =head1 NAME
3
4 signal.t - Test suite IPC::Run->signal
5
6 =cut
7
8 BEGIN {
9 if( $ENV{PERL_CORE} ) {
10 chdir '../lib/IPC/Run' if -d '../lib/IPC/Run';
11 unshift @INC, 'lib', '../..';
12 $^X = '../../../t/' . $^X;
13 }
14 }
15
16 use strict ;
17
18 use Test ;
19
20 use IPC::Run qw( :filters :filter_imp start run filter_tests ) ;
21 use UNIVERSAL qw( isa ) ;
22
23 sub Win32_MODE() ;
24 *Win32_MODE = \&IPC::Run::Win32_MODE ;
25
26 ## Win32 does not support a lot of things that Unix does. These
27 ## skip_unless subs help that.
28 ##
29 ## TODO: There are also a few things that Win32 supports (passing Win32 OS
30 ## handles) that we should test for, conversely.
31 sub skip_unless_signals(&) {
32 if ( Win32_MODE ) {
33 return sub {
34 skip "$^O does not support signals", 0 ;
35 } ;
36 }
37 shift ;
38 }
39
40 use IPC::Run qw( start ) ;
41
42 my @receiver = (
43 $^X,
44 '-e',
45 <<'END_RECEIVER',
46 my $which = " " ;
47 sub s{ $which = $_[0] } ;
48 $SIG{$_}=\&s for (qw(USR1 USR2));
49 $| = 1 ;
50 print "Ok\n";
51 for (1..10) { sleep 1 ; print $which, "\n" }
52 END_RECEIVER
53 ) ;
54
55 my $h ;
56 my $out ;
57
58 my @tests = (
59 skip_unless_signals {
60 $h = start \@receiver, \undef, \$out ;
61 pump $h until $out =~ /Ok/ ;
62 ok 1 ;
63 },
64 skip_unless_signals {
65 $out = "" ;
66 $h->signal( "USR2" ) ;
67 pump $h ;
68 $h->signal( "USR1" ) ;
69 pump $h ;
70 $h->signal( "USR2" ) ;
71 pump $h ;
72 $h->signal( "USR1" ) ;
73 pump $h ;
74 ok $out, "USR2\nUSR1\nUSR2\nUSR1\n" ;
75 },
76
77 skip_unless_signals {
78 $h->signal( "TERM" ) ;
79 finish $h ;
80 ok( 1 ) ;
81 },
82
83 ) ;
84
85 plan tests => scalar @tests ;
86
87 $_->() for ( @tests ) ;
+115
-0
t/timeout.t less more
0 #!/usr/bin/perl -w
1
2 =head1 NAME
3
4 timeout.t - Test suite for IPC::Run timeouts
5
6 =cut
7
8 BEGIN {
9 if( $ENV{PERL_CORE} ) {
10 chdir '../lib/IPC/Run' if -d '../lib/IPC/Run';
11 unshift @INC, 'lib', '../..';
12 $^X = '../../../t/' . $^X;
13 }
14 }
15
16
17 ## Separate from run.t so run.t is not too slow.
18
19 use strict ;
20
21 use Test ;
22
23 use IPC::Run qw( harness timeout ) ;
24 use UNIVERSAL qw( isa ) ;
25
26 my $h ;
27 my $t ;
28 my $in ;
29 my $out ;
30 my $started ;
31
32 my @tests = (
33
34 sub {
35 $h = harness( [ $^X ], \$in, \$out, $t = timeout( 1 ) ) ;
36 ok( isa( $h, 'IPC::Run' ) ) ;
37 },
38 sub { ok( !! $t->is_reset ) },
39 sub { ok( ! $t->is_running ) },
40 sub { ok( ! $t->is_expired ) },
41
42 sub {
43 $started = time ;
44 $h->start ;
45 ok( 1 ) ;
46 },
47 sub { ok( ! $t->is_reset ) },
48 sub { ok( !! $t->is_running ) },
49 sub { ok( ! $t->is_expired ) },
50
51 sub {
52 $in = '' ;
53 eval { $h->pump };
54 # Older perls' Test.pms don't know what to do with qr//s
55 $@ =~ /IPC::Run: timeout/ ? ok( 1 ) : ok( $@, qr/IPC::Run: timeout/ ) ;
56 },
57
58 sub {
59 my $elapsed = time - $started ;
60 $elapsed >= 1 ? ok( 1 ) : ok( $elapsed, ">= 1" ) ;
61 },
62
63 sub { ok( $t->interval, 1 ) },
64 sub { ok( ! $t->is_reset ) },
65 sub { ok( ! $t->is_running ) },
66 sub { ok( !! $t->is_expired ) },
67
68 ##
69 ## Starting from an expired state
70 ##
71 sub {
72 $started = time ;
73 $h->start ;
74 ok( 1 ) ;
75 },
76 sub { ok( ! $t->is_reset ) },
77 sub { ok( !! $t->is_running ) },
78 sub { ok( ! $t->is_expired ) },
79 sub {
80 $in = '' ;
81 eval { $h->pump };
82 $@ =~ /IPC::Run: timeout/ ? ok( 1 ) : ok( $@, qr/IPC::Run: timeout/ ) ;
83 },
84 sub { ok( ! $t->is_reset ) },
85 sub { ok( ! $t->is_running ) },
86 sub { ok( !! $t->is_expired ) },
87
88 sub {
89 my $elapsed = time - $started ;
90 $elapsed >= 1 ? ok( 1 ) : ok( $elapsed, ">= 1" ) ;
91 },
92
93 sub {
94 $h = harness( [ $^X ], \$in, \$out, timeout( 1 ) ) ;
95 $started = time ;
96 $h->start ;
97 $in = '' ;
98 eval { $h->pump };
99 $@ =~ /IPC::Run: timeout/ ? ok( 1 ) : ok( $@, qr/IPC::Run: timeout/ ) ;
100 },
101
102 sub {
103 my $elapsed = time - $started ;
104 $elapsed >= 1 ? ok( 1 ) : ok( $elapsed, ">= 1" ) ;
105 },
106
107 ) ;
108
109
110
111 plan tests => scalar @tests ;
112
113 $_->() for ( @tests ) ;
114
+148
-0
t/timer.t less more
0 #!/usr/bin/perl -w
1
2 =head1 NAME
3
4 timer.t - Test suite for IPC::Run::Timer
5
6 =cut
7
8 BEGIN {
9 if( $ENV{PERL_CORE} ) {
10 chdir '../lib/IPC/Run' if -d '../lib/IPC/Run';
11 unshift @INC, 'lib', '../..';
12 $^X = '../../../t/' . $^X;
13 }
14 }
15
16 use strict ;
17
18 use Test ;
19
20 use IPC::Run qw( run ) ;
21 use IPC::Run::Timer qw( :all ) ;
22 use UNIVERSAL qw( isa ) ;
23
24 my $t ;
25 my $started ;
26
27 my @tests = (
28
29 sub {
30 $t = timer(
31 # debug => 1,
32 1,
33 ) ;
34 ok( ref $t, 'IPC::Run::Timer' ) ;
35 },
36
37 sub { ok( $t->interval, 1 ) },
38
39 sub { $t->interval( 0 ) ; ok( $t->interval, 0 ) },
40 sub { $t->interval( 0.1 ) ; ok( $t->interval > 0 ) },
41 sub { $t->interval( 1 ) ; ok( $t->interval >= 1 ) },
42 sub { $t->interval( 30 ) ; ok( $t->interval >= 30 ) },
43 sub { $t->interval( 30.1 ) ; ok( $t->interval > 30 ) },
44 sub { $t->interval( 30.1 ) ; ok( $t->interval <= 31 ) },
45
46 sub { $t->interval( "1:0" ) ; ok( $t->interval, 60 ) },
47 sub { $t->interval( "1:0:0" ) ; ok( $t->interval, 3600 ) },
48 sub { $t->interval( "1:1:1" ) ; ok( $t->interval, 3661 ) },
49 sub { $t->interval( "1:1:1.1" ) ; ok( $t->interval > 3661 ) },
50 sub { $t->interval( "1:1:1.1" ) ; ok( $t->interval <= 3662 ) },
51 sub { $t->interval( "1:1:1:1" ) ; ok( $t->interval, 90061 ) },
52
53 sub {
54 $t->reset ;
55 $t->interval( 5 ) ;
56 $t->start( 1, 0 ) ;
57 ok( ! $t->is_expired ) ;
58 },
59 sub { ok( !! $t->is_running ) },
60 sub { ok( ! $t->is_reset ) },
61
62 sub { ok( !! $t->check( 0 ) ) },
63 sub { ok( ! $t->is_expired ) },
64 sub { ok( !! $t->is_running ) },
65 sub { ok( ! $t->is_reset ) },
66 sub { ok( !! $t->check( 1 ) ) },
67 sub { ok( ! $t->is_expired ) },
68 sub { ok( !! $t->is_running ) },
69 sub { ok( ! $t->is_reset ) },
70 sub { ok( ! $t->check( 2 ) ) },
71 sub { ok( !! $t->is_expired ) },
72 sub { ok( ! $t->is_running ) },
73 sub { ok( ! $t->is_reset ) },
74 sub { ok( ! $t->check( 3 ) ) },
75 sub { ok( !! $t->is_expired ) },
76 sub { ok( ! $t->is_running ) },
77 sub { ok( ! $t->is_reset ) },
78
79 ## Restarting from the expired state.
80 sub {
81 $t->start( undef, 0 ) ;
82 ok( ! $t->is_expired ) ;
83 },
84 sub { ok( !! $t->is_running ) },
85 sub { ok( ! $t->is_reset ) },
86
87 sub { ok( !! $t->check( 0 ) ) },
88 sub { ok( ! $t->is_expired ) },
89 sub { ok( !! $t->is_running ) },
90 sub { ok( ! $t->is_reset ) },
91 sub { ok( !! $t->check( 1 ) ) },
92 sub { ok( ! $t->is_expired ) },
93 sub { ok( !! $t->is_running ) },
94 sub { ok( ! $t->is_reset ) },
95 sub { ok( ! $t->check( 2 ) ) },
96 sub { ok( !! $t->is_expired ) },
97 sub { ok( ! $t->is_running ) },
98 sub { ok( ! $t->is_reset ) },
99 sub { ok( ! $t->check( 3 ) ) },
100 sub { ok( !! $t->is_expired ) },
101 sub { ok( ! $t->is_running ) },
102 sub { ok( ! $t->is_reset ) },
103
104 ## Restarting while running
105 sub {
106 $t->start( 1, 0 ) ;
107 $t->start( undef, 0 ) ;
108 ok( ! $t->is_expired ) ;
109 },
110 sub { ok( !! $t->is_running ) },
111 sub { ok( ! $t->is_reset ) },
112
113 sub { ok( !! $t->check( 0 ) ) },
114 sub { ok( ! $t->is_expired ) },
115 sub { ok( !! $t->is_running ) },
116 sub { ok( ! $t->is_reset ) },
117 sub { ok( !! $t->check( 1 ) ) },
118 sub { ok( ! $t->is_expired ) },
119 sub { ok( !! $t->is_running ) },
120 sub { ok( ! $t->is_reset ) },
121 sub { ok( ! $t->check( 2 ) ) },
122 sub { ok( !! $t->is_expired ) },
123 sub { ok( ! $t->is_running ) },
124 sub { ok( ! $t->is_reset ) },
125 sub { ok( ! $t->check( 3 ) ) },
126 sub { ok( !! $t->is_expired ) },
127 sub { ok( ! $t->is_running ) },
128 sub { ok( ! $t->is_reset ) },
129
130 sub {
131 my $got ;
132 eval {
133 $got = "timeout fired" ;
134 run [$^X, '-e', 'sleep 3'], timeout 1 ;
135 $got = "timeout didn't fire" ;
136 } ;
137 ok $got, "timeout fired", "timer firing in run()" ;
138 },
139
140 ) ;
141
142
143
144 plan tests => scalar @tests ;
145
146 $_->() for ( @tests ) ;
147
+90
-0
t/win32_compile.t less more
0 #!/usr/bin/perl -w
1
2 =head1 NAME
3
4 win32_compile.t - See if IPC::Run::Win32Helper compiles, even on Unix
5
6 =cut
7
8 BEGIN {
9 if( $ENV{PERL_CORE} ) {
10 chdir '../lib/IPC/Run' if -d '../lib/IPC/Run';
11 unshift @INC, 'lib', '../..';
12 $^X = '../../../t/' . $^X;
13 }
14 }
15
16 use strict ;
17
18 use Test ;
19
20 BEGIN {
21 unless ( eval "require 5.006" ) {
22 ## NOTE: I'm working around this here because I don't want this
23 ## test to fail on non-Win32 systems with older Perls. Makefile.PL
24 ## does the require 5.6.0 to protect folks on Windows.
25 plan tests => 1;
26 skip "perl5.00503's Socket.pm does not export IPPROTO_TCP", 1, 1;
27 exit 0;
28 }
29
30
31 $INC{$_} = 1 for qw( Win32/Process.pm Win32API/File.pm ) ;
32
33 package Win32API::File ;
34
35 use vars qw( @ISA @EXPORT ) ;
36
37 @ISA = qw( Exporter ) ;
38 @EXPORT = qw(
39 GetOsFHandle
40 OsFHandleOpen
41 OsFHandleOpenFd
42 FdGetOsFHandle
43 SetHandleInformation
44 SetFilePointer
45
46 HANDLE_FLAG_INHERIT
47 INVALID_HANDLE_VALUE
48
49 createFile
50 WriteFile
51 ReadFile
52 CloseHandle
53
54 FILE_ATTRIBUTE_TEMPORARY
55 FILE_FLAG_DELETE_ON_CLOSE
56 FILE_FLAG_WRITE_THROUGH
57
58 FILE_BEGIN
59 ) ;
60
61 eval "sub $_ { 1 }" for @EXPORT ;
62
63 use Exporter ;
64
65 package Win32::Process ;
66
67 use vars qw( @ISA @EXPORT ) ;
68
69 @ISA = qw( Exporter ) ;
70 @EXPORT = qw(
71 NORMAL_PRIORITY_CLASS
72 ) ;
73
74 eval "sub $_ {}" for @EXPORT ;
75
76 use Exporter ;
77 }
78
79 sub Socket::IPPROTO_TCP() { undef }
80
81 package main ;
82
83 use IPC::Run::Win32Helper ;
84 use IPC::Run::Win32IO ;
85
86 plan tests => 1 ;
87
88 ok 1 ;
89