Codebase list libipc-run-perl / 70cac1b
new upstream version Krzysztof Krzyzaniak 15 years ago
32 changed file(s) with 6309 addition(s) and 4642 deletion(s). Raw diff Collapse all Expand all
+267
-257
Changes less more
00 Revision history for Perl extension IPC::Run
11
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
2 0.82 Thu 18 Dec 2008
3 - Moving changes in 0.81_01 to a production release
4
5 0.81_01 Wed 15 Oct 2008
6 - This is the first in a series of refactoring test releases.
7 - Removed Makefile.PL message noisily asking users to do CPAN Testers
8 dirty work.
9 - Simplfied the Makefile.PL code a little.
10 - Upgraded all tests to Test::More
11 - Added a $VERSION for all modules
12 - Adding some missing POD sections
13 - Various other clean ups
14
15 0.80 (missing)
16 - IPC::Run::IO now retries on certain "temporarily unavailable" errors.
17 This should fix several reported issues with t/run.t, test 69.
18 Many thanks to < Eric (at) Scratch Computing (.com) > for the patch!
19 - Applied documentation patch from RT.
20 - Fixed documentation to work with '<' redirect
1121
1222 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)
23 - New maintainer: Richard Soderberg <rsod@cpan.org>
24 - Resolved several RT tickets
25 (4934, 8263, 8060, 8400, 8624, 5870, 4658, 8940, 1474, 4311)
26 - Skip certain tests on AIX and OpenBSD as they deadlock otherwise
27 - Applied AIX patch from ActiveState (#8263)
28 - Fixed t/run.t on OS X (#8940)
29 - Add check for EINTR to _read (#5870)
30 - FreeBSD uses fds up to 4 by default, fixed tests to start at 5 (#8060)
2131
2232 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.
33 - Removed all psuedohashes
34 - Require Win32::Process when on Win32 (<CORION a t cpan . org>)
35 - Retry the select() instead of croaking when EINTR occurs
36 (Ilya Martynov, ilya a t iponweb.net)
37 - This needs further testing and analysis, but works for
38 the submitter.
2939
3040 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/...
41 - Non-binmoded pipes are now s/\r//g on Win32
42 - Passes all tests on WinXPPro and WinNT
43 - Deadlocks somewhere shortly after process creation on Win2K
44 in some cases
45
46 0.76 (missing)
47 - Does not use pseudohashes for perls >= 5.9.0 (reported by several
48 users, patch by Nicholas Clark <nick@unfortu.net>)
49 - pumpable() is now exported (reported by fetko@slaysys.com)
50 - pumpable() now more thorough in checking for a dead child (reported
51 by fetko@slaysys.com)
52 - it checks for reapable processes when all pipes to the process
53 are paused
54 - pumpable() now yields the processor when all pipes to
55 - Distro layout improved: Run.pm and Run/... are now under
56 lib/IPC/...
4757
4858 0.75 Tue Jan 28 11:33:40 EST 2003
49 - Fix a bug that was causing _pipe() to seem to fail when feeding
59 - Fix a bug that was causing _pipe() to seem to fail when feeding
5060
5161 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.
62 - Skip a set of pty tests that deadlock on freebsd. Reported and
63 investigated by Rocco Caputo <troc@pobox.com>. perldoc t/pty.t
64 for details.
5565
5666 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>
67 - Improved Win32 PATH and PATHEXT search;
68 original patch by Ron Savage <ron@savage.net.au>
5969
6070 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).
71 - Doc patch from daniel@danielgardner.org
72 - Backport Win32Helper to 5.00503 (compilation of this is
73 tested on Unix or it would not have been spotted,
74 not even by Matt Sergeant matts@sergeant.org).
6575
6676 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
77 - Fix the pesky run/t check for specific error string (test 134 at
78 the moment, bad file descriptor test) that keeps tripping up
79 cpantesters
7080
7181 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.
82 - Massive performance improvements on Win32 See IPC::Run::Win32Helper's
83 optimize() documentation.
84 - moved data pump routine to IPC::Run::Win32Pump, now it loads much
85 faster.
86 - Where reasonably safe to do so, temporary files are used instead of
87 pipes+pumps.
88 - Setting $ENV{IPCRUNDEBUG}="notopt" can help find opportunities for
89 optimizing. See IPC::Run::Debug for details.
90 - Added 'noinherit => 1' option (parsed like 'debug => "basic") to
91 allow stdin, stdout, and stderr to not be inherited by the child.
92 - Factored debugging out in to IPC::Run::Debug so Win32Pump.pm need not load
93 IPC::Run to get it.
94 - Debugging code can be compile-time optimized away by setting
95 $ENV{IPCRUNDEBUG} = "none" (or 0) before IPC::Run::Debug is first loaded
96 causes all _debug... code to be optimized away before runtime.
97 - Moved some functionality from IPC::Run in to IPC::Run::IO to allow
98 IPC::Run::Win32IO to alter IPC::Run's behavior. More of this should
99 happen; IPC::Run has grown too bloaty.
100 - All the hokey hacky "manual imports" of IPC::Run's old _debug...()
101 functions has been replaced by "use IPC::Run::Debug".
102 - All the hokey hacky "manual imports" of IPC::Run's Win32_MODE()
103 constant has been replaced by importing it from IPC::Run.
104 - Cleaned up IPC::Run::Win32*'s debugging levels a bit to unclutter
105 "basic" and "data" debugging level output.
106 - exception handling in _open_pipes no longer silently eats exceptions.
97107
98108 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.
109 - remove _q from the examples in the POD - it was inconsistent (the
110 examples had bugs) and didn't help readability. Spotted by
111 B.Rowlingson@lancaster.ac.uk.
102112
103113 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.
114 - Really dumb down that bad file descriptor test last tweaked in 0.64;
115 the CLI does not script well under internationalization.
106116
107117 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.
118 - Mostly focused on Win32
119 - pass filehandles to pumpers by number on the command line to avoid
120 - use 2 arg binmode to force socket handles into/out of binmode
121 - improve t/binmode.t
122 - TODO: test ^Z and \000 pass-through.
113123
114124 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.
125 - Fix a test that fails on AIX because it uses a different message for
126 "Bad file descriptor". Reported by "Dave Gomboc" <dave@cs.ualberta.ca>
127 - If IO::Pty is loadable, require IO::Pty 1.00 or later.
118128
119129 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>.
130 - the select loop will now poll (with logarithmic fallback) when all
131 I/O is closed but we have children running. Problem report by
132 "William R. Pearson" <wrp@alpha0.bioch.virginia.edu>.
123133
124134 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>.
135 - Have all children close all file descriptors opened by the parent
136 harness, otherwise children of different harnesses can unwittingly
137 keep open fds the parent closes, thus preventing other children
138 from seeing them close. Reported by Blair Zajac <blair@orcaware.com>.
129139
130140 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>.
141 - Fix up signal.t to not fail due to printing not working quite right in
142 signal handlers. Spotted in the wild by Blair Zajac <blair@orcaware.com>.
133143
134144 0.6 Thu Dec 6 04:36:57 EST 2001
135 - Get binmode--(">", binary) and ("<", binary)--working on Win32.
145 - Get binmode--(">", binary) and ("<", binary)--working on Win32.
136146
137147 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.
148 - IPC::Run now throws exceptions from the post-fork, pre-exec child process
149 back to the parent process using an additional pipe. This pipe also
150 is used to pause the parent until the child performs the exec(), so
151 that (when a new version of IO::Pty implements it) pty creation can
152 be completed before the parent tries to write to it.
143153
144154 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.
155 - Fixups to Win32 code to get it compiling ok (added t/win32_compile.t
156 to ensure that Win32Helper.pm at least compiles Ok).
157 - Minor tweak to deal with "_" in $IO::Pty::VERSION, which is "0.92_04",
158 including quotes, in the current version.
149159
150160 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.
161 - Win32 SUPPORT!!!!!
162 - Added support for env. var. IPCRUNDEBUG=1 (or 2, 3, 4) to make it
163 easier for users to debug the test suite.
164 - Adapt to IO::Pty 0.91, which creates slave fds in new(), forcing us to
165 close them in the parent after the fork(). We don't check for IO::Pty's
166 version number, perhaps we should (waiting for a response from Roland
167 Giersig <RGiersig@cpan.org> about what he intends, since this could affect
168 all users of older IO::Ptys that upgrade).
169 - Add a sleep(1) to allow the slave pty to be initted, otherwise a premature
170 write() to the slave's input can be lost. This is a bogus hack, but
171 IO::Pty 0.9x should fix it when it's released.
172 - removed spurious use Errno qw( EAGAIN ), since this causes warnings with
173 perl5.00505. Reported by Christian Jaeger <christian.jaeger@sl.ethz.ch>
174 (pflanze).
175 - IPC::Run::start() now does a kill_kill() if called on an already started
176 harness. This is needed on Win32 to pass the test suite, but it's also a
177 nice thing.
178 - The debug file descriptor is built by dup()ing STDERR in the parent and
179 passing it to the kids. This keeps us from needing to worry about
180 debugging info in the select() loop and removes unnecessary complications.
181 Still needs a bit of work: it should be dup()ed in _open_pipes and it's
182 value should be stored in the harness, not a global.
183 - child processes are now a little more clearly identified in debug output.
184 - Some debugging messages are now clearer.
185 - debugging is now almost ready to be compile-time optimized away.
186 - "time since script start" is now shown when debugging. We should check to
187 see if Time::HiRes is loaded and make this more accurate.
188 - pipe opens are now down in Run::IO::open_pipe().
189 - map_fds won't complain about no open fds unnecessarily (which was rare,
190 but still).
191 - the debug fd is now determined per-harness, not globally. This requires a
192 bit of a hack (since I don't want to require $harness->_debug everywhere
193 _debug might be called), but it seems worthwhile.
184194
185195 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.
196 - confess() when undef passed to _exec()
197 - Cleaned up some POD and code comments.
198 - Added patch to make the write side of pipes & ptys that IPC::Run must
199 write to be non-blocking. Added a test for pipes, but Boris reports that
200 Solaris 8 something seems to still block in the pty case, though Linux
201 does not, so I did not add a test for that case. Probably should add one
202 and complain bitterly if it fails (rather than actually failing the tests)
203 and ptys are used. Patch from Borislav Deianov
204 <borislav@users.sourceforge.net>.
205 - Added a patch to invalidate the search path cache if the file is no longer
206 executable, also from Borislav Deianov <borislav@users.sourceforge.net>
207 - Started implementation of an adopt() external call that would let you
208 aggregate harnesses, and a t/adopt.t, but different children need to
209 properly close all FDs: they're inheriting each other's FDs and not
210 properly closing them.
211 - Close $debug_fd in &sub coprocesses.
212 - Document the problems with &sub coprocesses.
213 - Fixed fork error return detection to actually work, spotted by Dave
214 Mitchell <davem@fdgroup.co.uk>.
215 - Give errors if a path with a directory separator is passed in if the
216 indicated filename does not exist, is not a file, or is not executable.
217 They're unixish errors, but hey...
218 - Allowed harness \@cmd, '>', $foo, timeout 10 ; to parse (it was mistakenly
219 thinking I wanted to send output to the IPC::Run::Timer created by
220 timeout().
221 - pumpable() now returns true if there are any kids left alive, so that
222 timers may continue to run.
223 - A timeout of 1 second is forced if there are no I/O pipes left open, so
224 that the select loop won't hang in select() if there is no I/O to do.
225 Perhaps should only do that if there are timers.
226 - Added a signal() to send specified signals to processes. Chose this over
227 the more traditional Unix kill() to avoid people thinking that kill()
228 should kill off processes.
229 - Added kill_kill() which does kill off processes and clean up the harness.
230 Sends TERM then (if need be) waits and sends KILL.
231 - timeouts now work.
232 - Removed eval{}s from a few subs, we were being over protective.
233 - Preserve pos() across updates to scalars we append to, so m//g
234 matches will work.
235 - Cleaned up the examples/
236 - Added abuse/ for (mostly user contributed) scripts that I can use as
237 a manual regression test. Most/all are reflected in t/*.t, but not
238 verbatim, so it's good to have to originals around in case they
239 happen to trigger something t/*.t miss.
240 - Cleaned up SYNOPSIS a bit: it was too scary. Still is, but less so.
231241
232242 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.
243 - Commented out all code dealing with select()'s exception file descriptor
244 mask. Exceptions are vaguely defined and until somebody asks for them
245 I don't want to do anything automatic with them. Croaking on them
246 was certainly a bad idea: FreeBSD and some other platforms raise an
247 exception when a pipe is closed, even if there's data in the pipe.
248 IPC::Run closes a pipe filehandle if it sees sysread() return an
249 error or 0 bytes read.
240250
241251 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 ) ;
252 - Added flushing of STDOUT and STDERR before fork()/spawn() so that the
253 children won't inherit bufferloads of unflushed output. This seems
254 to be automatic in 5.6.0, but can cause loads of grief in 5.00503.
255 I wish there were a way to flush all open filehandles, like stdio's
256 fflush( NULL ) ;
247257
248258 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.
259 - Worked around psuedo-hash features not implemented in perl5.00503
260 - Deprecated passing hashes of options in favor of just passing
261 name-vlaue pairs.
262
263 0.41 (missing)
264 - Added result, results, full_result, full_results. I added so many
265 variations because I expect that result and full_result are the most
266 likely to get a lot of use, but I wanted to be able to return a list
267 as well, without misusing wantarray.
258268
259269 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.
270 - Added IPC::Run::IO and IPC::Run::Timer, bunches of tests. IPC::Run
271 can now do more than just run child processes.
272 - Scribbled more documentation. Needs a good edit.
273 - Fixed some minor bugs here and there.
264274
265275 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.
276 - Fixed bug in t/pty.t that prevented it from noticing IO::Pty
277 - Converted IPC::Run to use fields.
268278
269279 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.
280 - Added warning about missing IO::Pty in MakeMaker.PL. Thought about
281 making it a prerequisite, but it's not: IPC::Run can do pipes, etc,
282 if it's not found, and IO::Pty is more unix-specific than IPC::Run is.
283 What I'd really like is an 'ENABLERS' section to MakeMaker.PL that
284 tells CPAN.pm to try to install it but not to stress if it can't.
285 - t/pty.t skips all tests if require IO::Pty fails.
276286
277287 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.
288 - t/pty.t should now report what was received when checking it against
289 a regex. This is because 0.3's failing a few tests on ppc-linux
290 and the ok( $out =~ /.../ ) ; wasn't giving me enough info. I chose
291 the 1 arg form due to older perl dists' Test.pm not grokking
292 ok( $out, qr// ) ;. I should really do this to t/*.t, but I'm tired.
293 - Removed the misfired Run/Pty.pm from the dist.
284294
285295 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.
296 - Changed spelling of '<|<' and '>|>' to '<pipe' and '>pipe'. This
297 is to make it less confusing (I hope), since '>|' is a valid construct
298 in some shells with totally unrelated semantics, and I plan on adding
299 it to IPC::Run if a noclobber option ever makes it in.
300 - Added '<pty<' and '>pty>' operators.
291301
292302 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.
303 - Added some advice for dealing with obstinate children
304 - Converted many methods to plain subs for simplicity & performance
305 - Converted to using local $debug to control debugging status for
306 simplicity's sake. Don't know about performance effects, since
307 dynamic scope lookups can be slow.
298308
299309 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.
310 - Undid the creation of a pipe when passing a \*FOO or an IO::Handle
311 ref and added '<|<', \*IN and '>|>', \*OUT syntax instead. This was
312 because some very subtle bugs might have occured if \*FOO was left
313 in the wrong opened/closed state before calling run(), start() or
314 harness(). Now, \*FOO must be open before the start() call, and
315 '<|<' and '>|>' will close \*IN or \*OUT (or whatever) and open
316 a pipe on it. This is analagous to IPC/Open{2,3}.pm behaviors.
317 - Added eg/factorial_scalar and eg/runsh. Rewrote eg/factorial_pipe.
318 - Fixed bug that was preventing input scalar refs (ie input for the
319 child process) from ever being read from a second time. This
320 caused pump() to hang.
321 - Cleaned up calculation and use of timeout values so that when
322 select() times out, it isn't called again. It's now adding one
323 second to the timeout value because time() resolution is 1 second
324 and we want to guarantee a minimum timeout even when we sample the
325 start time at the end of a second
326 - minor name changes to some field names to make the code marginally
327 less obscure.
328 - Fixed the MakeMaker settings and the directory layout so "make install"
329 actually works.
320330
321331 0.1 Tue Apr 25 22:10:07 2000
322
332 - Initial release
+378
-0
LICENSE less more
0
1 Terms of Perl itself
2
3 a) the GNU General Public License as published by the Free
4 Software Foundation; either version 1, or (at your option) any
5 later version, or
6 b) the "Artistic License"
7
8 ----------------------------------------------------------------------------
9
10 The General Public License (GPL)
11 Version 2, June 1991
12
13 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 675 Mass Ave,
14 Cambridge, MA 02139, USA. Everyone is permitted to copy and distribute
15 verbatim copies of this license document, but changing it is not allowed.
16
17 Preamble
18
19 The licenses for most software are designed to take away your freedom to share
20 and change it. By contrast, the GNU General Public License is intended to
21 guarantee your freedom to share and change free software--to make sure the
22 software is free for all its users. This General Public License applies to most of
23 the Free Software Foundation's software and to any other program whose
24 authors commit to using it. (Some other Free Software Foundation software is
25 covered by the GNU Library General Public License instead.) You can apply it to
26 your programs, too.
27
28 When we speak of free software, we are referring to freedom, not price. Our
29 General Public Licenses are designed to make sure that you have the freedom
30 to distribute copies of free software (and charge for this service if you wish), that
31 you receive source code or can get it if you want it, that you can change the
32 software or use pieces of it in new free programs; and that you know you can do
33 these things.
34
35 To protect your rights, we need to make restrictions that forbid anyone to deny
36 you these rights or to ask you to surrender the rights. These restrictions
37 translate to certain responsibilities for you if you distribute copies of the
38 software, or if you modify it.
39
40 For example, if you distribute copies of such a program, whether gratis or for a
41 fee, you must give the recipients all the rights that you have. You must make
42 sure that they, too, receive or can get the source code. And you must show
43 them these terms so they know their rights.
44
45 We protect your rights with two steps: (1) copyright the software, and (2) offer
46 you this license which gives you legal permission to copy, distribute and/or
47 modify the software.
48
49 Also, for each author's protection and ours, we want to make certain that
50 everyone understands that there is no warranty for this free software. If the
51 software is modified by someone else and passed on, we want its recipients to
52 know that what they have is not the original, so that any problems introduced by
53 others will not reflect on the original authors' reputations.
54
55 Finally, any free program is threatened constantly by software patents. We wish
56 to avoid the danger that redistributors of a free program will individually obtain
57 patent licenses, in effect making the program proprietary. To prevent this, we
58 have made it clear that any patent must be licensed for everyone's free use or
59 not licensed at all.
60
61 The precise terms and conditions for copying, distribution and modification
62 follow.
63
64 GNU GENERAL PUBLIC LICENSE
65 TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND
66 MODIFICATION
67
68 0. This License applies to any program or other work which contains a notice
69 placed by the copyright holder saying it may be distributed under the terms of
70 this General Public License. The "Program", below, refers to any such program
71 or work, and a "work based on the Program" means either the Program or any
72 derivative work under copyright law: that is to say, a work containing the
73 Program or a portion of it, either verbatim or with modifications and/or translated
74 into another language. (Hereinafter, translation is included without limitation in
75 the term "modification".) Each licensee is addressed as "you".
76
77 Activities other than copying, distribution and modification are not covered by
78 this License; they are outside its scope. The act of running the Program is not
79 restricted, and the output from the Program is covered only if its contents
80 constitute a work based on the Program (independent of having been made by
81 running the Program). Whether that is true depends on what the Program does.
82
83 1. You may copy and distribute verbatim copies of the Program's source code as
84 you receive it, in any medium, provided that you conspicuously and appropriately
85 publish on each copy an appropriate copyright notice and disclaimer of warranty;
86 keep intact all the notices that refer to this License and to the absence of any
87 warranty; and give any other recipients of the Program a copy of this License
88 along with the Program.
89
90 You may charge a fee for the physical act of transferring a copy, and you may at
91 your option offer warranty protection in exchange for a fee.
92
93 2. You may modify your copy or copies of the Program or any portion of it, thus
94 forming a work based on the Program, and copy and distribute such
95 modifications or work under the terms of Section 1 above, provided that you also
96 meet all of these conditions:
97
98 a) You must cause the modified files to carry prominent notices stating that you
99 changed the files and the date of any change.
100
101 b) You must cause any work that you distribute or publish, that in whole or in
102 part contains or is derived from the Program or any part thereof, to be licensed
103 as a whole at no charge to all third parties under the terms of this License.
104
105 c) If the modified program normally reads commands interactively when run, you
106 must cause it, when started running for such interactive use in the most ordinary
107 way, to print or display an announcement including an appropriate copyright
108 notice and a notice that there is no warranty (or else, saying that you provide a
109 warranty) and that users may redistribute the program under these conditions,
110 and telling the user how to view a copy of this License. (Exception: if the
111 Program itself is interactive but does not normally print such an announcement,
112 your work based on the Program is not required to print an announcement.)
113
114 These requirements apply to the modified work as a whole. If identifiable
115 sections of that work are not derived from the Program, and can be reasonably
116 considered independent and separate works in themselves, then this License,
117 and its terms, do not apply to those sections when you distribute them as
118 separate works. But when you distribute the same sections as part of a whole
119 which is a work based on the Program, the distribution of the whole must be on
120 the terms of this License, whose permissions for other licensees extend to the
121 entire whole, and thus to each and every part regardless of who wrote it.
122
123 Thus, it is not the intent of this section to claim rights or contest your rights to
124 work written entirely by you; rather, the intent is to exercise the right to control
125 the distribution of derivative or collective works based on the Program.
126
127 In addition, mere aggregation of another work not based on the Program with the
128 Program (or with a work based on the Program) on a volume of a storage or
129 distribution medium does not bring the other work under the scope of this
130 License.
131
132 3. You may copy and distribute the Program (or a work based on it, under
133 Section 2) in object code or executable form under the terms of Sections 1 and 2
134 above provided that you also do one of the following:
135
136 a) Accompany it with the complete corresponding machine-readable source
137 code, which must be distributed under the terms of Sections 1 and 2 above on a
138 medium customarily used for software interchange; or,
139
140 b) Accompany it with a written offer, valid for at least three years, to give any
141 third party, for a charge no more than your cost of physically performing source
142 distribution, a complete machine-readable copy of the corresponding source
143 code, to be distributed under the terms of Sections 1 and 2 above on a medium
144 customarily used for software interchange; or,
145
146 c) Accompany it with the information you received as to the offer to distribute
147 corresponding source code. (This alternative is allowed only for noncommercial
148 distribution and only if you received the program in object code or executable
149 form with such an offer, in accord with Subsection b above.)
150
151 The source code for a work means the preferred form of the work for making
152 modifications to it. For an executable work, complete source code means all the
153 source code for all modules it contains, plus any associated interface definition
154 files, plus the scripts used to control compilation and installation of the
155 executable. However, as a special exception, the source code distributed need
156 not include anything that is normally distributed (in either source or binary form)
157 with the major components (compiler, kernel, and so on) of the operating system
158 on which the executable runs, unless that component itself accompanies the
159 executable.
160
161 If distribution of executable or object code is made by offering access to copy
162 from a designated place, then offering equivalent access to copy the source
163 code from the same place counts as distribution of the source code, even though
164 third parties are not compelled to copy the source along with the object code.
165
166 4. You may not copy, modify, sublicense, or distribute the Program except as
167 expressly provided under this License. Any attempt otherwise to copy, modify,
168 sublicense or distribute the Program is void, and will automatically terminate
169 your rights under this License. However, parties who have received copies, or
170 rights, from you under this License will not have their licenses terminated so long
171 as such parties remain in full compliance.
172
173 5. You are not required to accept this License, since you have not signed it.
174 However, nothing else grants you permission to modify or distribute the Program
175 or its derivative works. These actions are prohibited by law if you do not accept
176 this License. Therefore, by modifying or distributing the Program (or any work
177 based on the Program), you indicate your acceptance of this License to do so,
178 and all its terms and conditions for copying, distributing or modifying the
179 Program or works based on it.
180
181 6. Each time you redistribute the Program (or any work based on the Program),
182 the recipient automatically receives a license from the original licensor to copy,
183 distribute or modify the Program subject to these terms and conditions. You
184 may not impose any further restrictions on the recipients' exercise of the rights
185 granted herein. You are not responsible for enforcing compliance by third parties
186 to this License.
187
188 7. If, as a consequence of a court judgment or allegation of patent infringement
189 or for any other reason (not limited to patent issues), conditions are imposed on
190 you (whether by court order, agreement or otherwise) that contradict the
191 conditions of this License, they do not excuse you from the conditions of this
192 License. If you cannot distribute so as to satisfy simultaneously your obligations
193 under this License and any other pertinent obligations, then as a consequence
194 you may not distribute the Program at all. For example, if a patent license would
195 not permit royalty-free redistribution of the Program by all those who receive
196 copies directly or indirectly through you, then the only way you could satisfy
197 both it and this License would be to refrain entirely from distribution of the
198 Program.
199
200 If any portion of this section is held invalid or unenforceable under any particular
201 circumstance, the balance of the section is intended to apply and the section as
202 a whole is intended to apply in other circumstances.
203
204 It is not the purpose of this section to induce you to infringe any patents or other
205 property right claims or to contest validity of any such claims; this section has
206 the sole purpose of protecting the integrity of the free software distribution
207 system, which is implemented by public license practices. Many people have
208 made generous contributions to the wide range of software distributed through
209 that system in reliance on consistent application of that system; it is up to the
210 author/donor to decide if he or she is willing to distribute software through any
211 other system and a licensee cannot impose that choice.
212
213 This section is intended to make thoroughly clear what is believed to be a
214 consequence of the rest of this License.
215
216 8. If the distribution and/or use of the Program is restricted in certain countries
217 either by patents or by copyrighted interfaces, the original copyright holder who
218 places the Program under this License may add an explicit geographical
219 distribution limitation excluding those countries, so that distribution is permitted
220 only in or among countries not thus excluded. In such case, this License
221 incorporates the limitation as if written in the body of this License.
222
223 9. The Free Software Foundation may publish revised and/or new versions of the
224 General Public License from time to time. Such new versions will be similar in
225 spirit to the present version, but may differ in detail to address new problems or
226 concerns.
227
228 Each version is given a distinguishing version number. If the Program specifies a
229 version number of this License which applies to it and "any later version", you
230 have the option of following the terms and conditions either of that version or of
231 any later version published by the Free Software Foundation. If the Program does
232 not specify a version number of this License, you may choose any version ever
233 published by the Free Software Foundation.
234
235 10. If you wish to incorporate parts of the Program into other free programs
236 whose distribution conditions are different, write to the author to ask for
237 permission. For software which is copyrighted by the Free Software Foundation,
238 write to the Free Software Foundation; we sometimes make exceptions for this.
239 Our decision will be guided by the two goals of preserving the free status of all
240 derivatives of our free software and of promoting the sharing and reuse of
241 software generally.
242
243 NO WARRANTY
244
245 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS
246 NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
247 APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE
248 COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM
249 "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR
250 IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
251 MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
252 ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE
253 PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE,
254 YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR
255 CORRECTION.
256
257 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED
258 TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY
259 WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS
260 PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
261 GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES
262 ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM
263 (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
264 RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
265 PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY
266 OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS
267 BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
268
269 END OF TERMS AND CONDITIONS
270
271
272 ----------------------------------------------------------------------------
273
274 The Artistic License
275
276 Preamble
277
278 The intent of this document is to state the conditions under which a Package
279 may be copied, such that the Copyright Holder maintains some semblance of
280 artistic control over the development of the package, while giving the users of the
281 package the right to use and distribute the Package in a more-or-less customary
282 fashion, plus the right to make reasonable modifications.
283
284 Definitions:
285
286 - "Package" refers to the collection of files distributed by the Copyright
287 Holder, and derivatives of that collection of files created through textual
288 modification.
289 - "Standard Version" refers to such a Package if it has not been modified,
290 or has been modified in accordance with the wishes of the Copyright
291 Holder.
292 - "Copyright Holder" is whoever is named in the copyright or copyrights for
293 the package.
294 - "You" is you, if you're thinking about copying or distributing this Package.
295 - "Reasonable copying fee" is whatever you can justify on the basis of
296 media cost, duplication charges, time of people involved, and so on. (You
297 will not be required to justify it to the Copyright Holder, but only to the
298 computing community at large as a market that must bear the fee.)
299 - "Freely Available" means that no fee is charged for the item itself, though
300 there may be fees involved in handling the item. It also means that
301 recipients of the item may redistribute it under the same conditions they
302 received it.
303
304 1. You may make and give away verbatim copies of the source form of the
305 Standard Version of this Package without restriction, provided that you duplicate
306 all of the original copyright notices and associated disclaimers.
307
308 2. You may apply bug fixes, portability fixes and other modifications derived from
309 the Public Domain or from the Copyright Holder. A Package modified in such a
310 way shall still be considered the Standard Version.
311
312 3. You may otherwise modify your copy of this Package in any way, provided
313 that you insert a prominent notice in each changed file stating how and when
314 you changed that file, and provided that you do at least ONE of the following:
315
316 a) place your modifications in the Public Domain or otherwise
317 make them Freely Available, such as by posting said modifications
318 to Usenet or an equivalent medium, or placing the modifications on
319 a major archive site such as ftp.uu.net, or by allowing the
320 Copyright Holder to include your modifications in the Standard
321 Version of the Package.
322
323 b) use the modified Package only within your corporation or
324 organization.
325
326 c) rename any non-standard executables so the names do not
327 conflict with standard executables, which must also be provided,
328 and provide a separate manual page for each non-standard
329 executable that clearly documents how it differs from the Standard
330 Version.
331
332 d) make other distribution arrangements with the Copyright Holder.
333
334 4. You may distribute the programs of this Package in object code or executable
335 form, provided that you do at least ONE of the following:
336
337 a) distribute a Standard Version of the executables and library
338 files, together with instructions (in the manual page or equivalent)
339 on where to get the Standard Version.
340
341 b) accompany the distribution with the machine-readable source of
342 the Package with your modifications.
343
344 c) accompany any non-standard executables with their
345 corresponding Standard Version executables, giving the
346 non-standard executables non-standard names, and clearly
347 documenting the differences in manual pages (or equivalent),
348 together with instructions on where to get the Standard Version.
349
350 d) make other distribution arrangements with the Copyright Holder.
351
352 5. You may charge a reasonable copying fee for any distribution of this Package.
353 You may charge any fee you choose for support of this Package. You may not
354 charge a fee for this Package itself. However, you may distribute this Package in
355 aggregate with other (possibly commercial) programs as part of a larger
356 (possibly commercial) software distribution provided that you do not advertise
357 this Package as a product of your own.
358
359 6. The scripts and library files supplied as input to or produced as output from
360 the programs of this Package do not automatically fall under the copyright of this
361 Package, but belong to whomever generated them, and may be sold
362 commercially, and may be aggregated with this Package.
363
364 7. C or perl subroutines supplied by you and linked into this Package shall not
365 be considered part of this Package.
366
367 8. The name of the Copyright Holder may not be used to endorse or promote
368 products derived from this software without specific prior written permission.
369
370 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
371 IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
372 WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR
373 PURPOSE.
374
375 The End
376
377
+17
-16
MANIFEST less more
0 abuse/blocking_debug_with_sub_coprocess
1 abuse/blocking_writes
2 abuse/broken_pipe_on_bad_executable_name
3 abuse/timers
04 Changes
1 MANIFEST
2 MANIFEST.SKIP
3 Makefile.PL
5 eg/factorial
6 eg/factorial_pipe
7 eg/factorial_scalar
8 eg/run_daemon
9 eg/runsh
10 eg/runsu
11 eg/synopsis_scripting
412 lib/IPC/Run.pm
513 lib/IPC/Run/Debug.pm
614 lib/IPC/Run/IO.pm
816 lib/IPC/Run/Win32Helper.pm
917 lib/IPC/Run/Win32IO.pm
1018 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
19 LICENSE
20 Makefile.PL
21 MANIFEST This list of files
22 README
2223 t/adopt.t
2324 t/binmode.t
2425 t/bogus.t
2627 t/harness.t
2728 t/io.t
2829 t/kill_kill.t
30 t/lib/Test.pm
2931 t/parallel.t
3032 t/pty.t
3133 t/pump.t
3537 t/timer.t
3638 t/win32_compile.t
3739 TODO
38 SIGNATURE
39 META.yml
40 META.yml Module meta-data (added by MakeMaker)
+0
-13
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 ~$
+19
-9
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
0 --- #YAML:1.0
1 name: IPC-Run
2 version: 0.82
3 abstract: ~
4 author: []
5 license: unknown
6 distribution_type: module
7 configure_requires:
8 ExtUtils::MakeMaker: 0
69 requires:
7
8 distribution_type: module
9 generated_by: ExtUtils::MakeMaker version 6.17
10 IO::Pty: 1.00
11 Test::More: 0.47
12 no_index:
13 directory:
14 - t
15 - inc
16 generated_by: ExtUtils::MakeMaker version 6.48
17 meta-spec:
18 url: http://module-build.sourceforge.net/META-spec-v1.4.html
19 version: 1.4
+39
-60
Makefile.PL less more
00 use ExtUtils::MakeMaker;
11
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;
2 # Calculate the dependencies
3 my %PREREQ_PM;
4 if ( $^O ne 'MSWin32' ) {
5 foreach ( eval { require IO::Pty; IO::Pty->VERSION } ) {
6 s/_//g if defined $_;
7 unless ( defined $_ ) {
8 warn("WARNING: \"IO::Pty not found\".\nWARNING: '<pty<', '>pty>' will not work.\n\n");
9 last;
10 }
11 $PREREQ_PM{'IO::Pty'} = '1.00';
12 }
13 } else {
14 $PREREQ_PM{'Win32::Process'} = 0;
15 if ( ! eval "use Socket qw( IPPROTO_TCP TCP_NODELAY ); 1" ) {
16 warn <<"TOHERE";
2017 $@
2118 IPC::Run on Win32 requires a recent Sockets.pm in order to handle more
2219 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
20 casual uses of run(), but it is impossible to tell whether all uses of
2421 IPC::Run in your installed modules meet the requirements, so IPC::Run
2522 should not be installed on Win32 machines with older perls.
2623
2724 TOHERE
2825
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.
26 ## Die nicely in case some install manager cares about the canonical
27 ## error message for this. Not that I've ever seen one, but those
28 ## wacky CPANPLUSers might just do something cool in this case.
3229
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.
30 ## Older perls' Socket.pm don't export IPPROTO_TCP
31 require 5.006;
32 ## Most of the time it's not needed (since IPC::Run tries not to
33 ## use sockets), but the user is not likely to know what the hell
34 ## went wrong running sb. else's program.
3735
38 exit 1; ## If something really odd is happening...
39 }
36 ## If something really odd is happening...
37 exit 1;
38 }
4039 }
4140
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
6241 WriteMakefile(
63 NAME => 'IPC::Run',
64 VERSION_FROM => 'lib/IPC/Run.pm',
65 PREREQ_PM => {
66 @conditional_prereqs,
67 }
42 NAME => 'IPC::Run',
43 VERSION_FROM => 'lib/IPC/Run.pm',
44 PREREQ_PM => {
45 Test::More => '0.47',
46 %PREREQ_PM,
47 }
6848 );
6949
70
7150 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 ;
51 package MY;
52 my $self = shift;
53 my ($path) = @_;
54 return '' if /\.sw[a-z]$/;
55 return '' unless length $self->SUPER::libscan($path);
56 return $path;
7857 }
+1709
-0
README less more
0 NAME
1 IPC::Run - system() and background procs w/ piping, redirs, ptys (Unix,
2 Win32)
3
4 SYNOPSIS
5 ## First,a command to run:
6 my @cat = qw( cat );
7
8 ## Using run() instead of system():
9 use IPC::Run qw( run timeout );
10
11 run \@cmd, \$in, \$out, \$err, timeout( 10 ) or die "cat: $?"
12
13 # Can do I/O to sub refs and filenames, too:
14 run \@cmd, '<', "in.txt", \&out, \&err or die "cat: $?"
15 run \@cat, '<', "in.txt", '>>', "out.txt", '2>>', "err.txt";
16
17 # Redirecting using psuedo-terminals instad of pipes.
18 run \@cat, '<pty<', \$in, '>pty>', \$out_and_err;
19
20 ## Scripting subprocesses (like Expect):
21
22 use IPC::Run qw( start pump finish timeout );
23
24 # Incrementally read from / write to scalars.
25 # $in is drained as it is fed to cat's stdin,
26 # $out accumulates cat's stdout
27 # $err accumulates cat's stderr
28 # $h is for "harness".
29 my $h = start \@cat, \$in, \$out, \$err, timeout( 10 );
30
31 $in .= "some input\n";
32 pump $h until $out =~ /input\n/g;
33
34 $in .= "some more input\n";
35 pump $h until $out =~ /\G.*more input\n/;
36
37 $in .= "some final input\n";
38 finish $h or die "cat returned $?";
39
40 warn $err if $err;
41 print $out; ## All of cat's output
42
43 # Piping between children
44 run \@cat, '|', \@gzip;
45
46 # Multiple children simultaneously (run() blocks until all
47 # children exit, use start() for background execution):
48 run \@foo1, '&', \@foo2;
49
50 # Calling \&set_up_child in the child before it executes the
51 # command (only works on systems with true fork() & exec())
52 # exceptions thrown in set_up_child() will be propagated back
53 # to the parent and thrown from run().
54 run \@cat, \$in, \$out,
55 init => \&set_up_child;
56
57 # Read from / write to file handles you open and close
58 open IN, '<in.txt' or die $!;
59 open OUT, '>out.txt' or die $!;
60 print OUT "preamble\n";
61 run \@cat, \*IN, \*OUT or die "cat returned $?";
62 print OUT "postamble\n";
63 close IN;
64 close OUT;
65
66 # Create pipes for you to read / write (like IPC::Open2 & 3).
67 $h = start
68 \@cat,
69 '<pipe', \*IN,
70 '>pipe', \*OUT,
71 '2>pipe', \*ERR
72 or die "cat returned $?";
73 print IN "some input\n";
74 close IN;
75 print <OUT>, <ERR>;
76 finish $h;
77
78 # Mixing input and output modes
79 run \@cat, 'in.txt', \&catch_some_out, \*ERR_LOG );
80
81 # Other redirection constructs
82 run \@cat, '>&', \$out_and_err;
83 run \@cat, '2>&1';
84 run \@cat, '0<&3';
85 run \@cat, '<&-';
86 run \@cat, '3<', \$in3;
87 run \@cat, '4>', \$out4;
88 # etc.
89
90 # Passing options:
91 run \@cat, 'in.txt', debug => 1;
92
93 # Call this system's shell, returns TRUE on 0 exit code
94 # THIS IS THE OPPOSITE SENSE OF system()'s RETURN VALUE
95 run "cat a b c" or die "cat returned $?";
96
97 # Launch a sub process directly, no shell. Can't do redirection
98 # with this form, it's here to behave like system() with an
99 # inverted result.
100 $r = run "cat a b c";
101
102 # Read from a file in to a scalar
103 run io( "filename", 'r', \$recv );
104 run io( \*HANDLE, 'r', \$recv );
105
106 DESCRIPTION
107 IPC::Run allows you run and interact with child processes using files,
108 pipes, and pseudo-ttys. Both system()-style and scripted usages are
109 supported and may be mixed. Likewise, functional and OO API styles are
110 both supported and may be mixed.
111
112 Various redirection operators reminiscent of those seen on common Unix
113 and DOS command lines are provided.
114
115 Before digging in to the details a few LIMITATIONS are important enough
116 to be mentioned right up front:
117
118 Win32 Support
119 Win32 support is working but EXPERIMENTAL, but does pass all
120 relevant tests on NT 4.0. See "Win32 LIMITATIONS".
121
122 pty Support
123 If you need pty support, IPC::Run should work well enough most of
124 the time, but IO::Pty is being improved, and IPC::Run will be
125 improved to use IO::Pty's new features when it is release.
126
127 The basic problem is that the pty needs to initialize itself before
128 the parent writes to the master pty, or the data written gets lost.
129 So IPC::Run does a sleep(1) in the parent after forking to
130 (hopefully) give the child a chance to run. This is a kludge that
131 works well on non heavily loaded systems :(.
132
133 ptys are not supported yet under Win32, but will be emulated...
134
135 Debugging Tip
136 You may use the environment variable "IPCRUNDEBUG" to see what's
137 going on under the hood:
138
139 $ IPCRUNDEBUG=basic myscript # prints minimal debugging
140 $ IPCRUNDEBUG=data myscript # prints all data reads/writes
141 $ IPCRUNDEBUG=details myscript # prints lots of low-level details
142 $ IPCRUNDEBUG=gory myscript # (Win32 only) prints data moving through
143 # the helper processes.
144
145 We now return you to your regularly scheduled documentation.
146
147 Harnesses
148 Child processes and I/O handles are gathered in to a harness, then
149 started and run until the processing is finished or aborted.
150
151 run() vs. start(); pump(); finish();
152 There are two modes you can run harnesses in: run() functions as an
153 enhanced system(), and start()/pump()/finish() allow for background
154 processes and scripted interactions with them.
155
156 When using run(), all data to be sent to the harness is set up in
157 advance (though one can feed subprocesses input from subroutine refs to
158 get around this limitation). The harness is run and all output is
159 collected from it, then any child processes are waited for:
160
161 run \@cmd, \<<IN, \$out;
162 blah
163 IN
164
165 ## To precompile harnesses and run them later:
166 my $h = harness \@cmd, \<<IN, \$out;
167 blah
168 IN
169
170 run $h;
171
172 The background and scripting API is provided by start(), pump(), and
173 finish(): start() creates a harness if need be (by calling harness())
174 and launches any subprocesses, pump() allows you to poll them for
175 activity, and finish() then monitors the harnessed activities until they
176 complete.
177
178 ## Build the harness, open all pipes, and launch the subprocesses
179 my $h = start \@cat, \$in, \$out;
180 $in = "first input\n";
181
182 ## Now do I/O. start() does no I/O.
183 pump $h while length $in; ## Wait for all input to go
184
185 ## Now do some more I/O.
186 $in = "second input\n";
187 pump $h until $out =~ /second input/;
188
189 ## Clean up
190 finish $h or die "cat returned $?";
191
192 You can optionally compile the harness with harness() prior to
193 start()ing or run()ing, and you may omit start() between harness() and
194 pump(). You might want to do these things if you compile your harnesses
195 ahead of time.
196
197 Using regexps to match output
198 As shown in most of the scripting examples, the read-to-scalar facility
199 for gathering subcommand's output is often used with regular expressions
200 to detect stopping points. This is because subcommand output often
201 arrives in dribbles and drabs, often only a character or line at a time.
202 This output is input for the main program and piles up in variables like
203 the $out and $err in our examples.
204
205 Regular expressions can be used to wait for appropriate output in
206 several ways. The "cat" example in the previous section demonstrates how
207 to pump() until some string appears in the output. Here's an example
208 that uses "smb" to fetch files from a remote server:
209
210 $h = harness \@smbclient, \$in, \$out;
211
212 $in = "cd /src\n";
213 $h->pump until $out =~ /^smb.*> \Z/m;
214 die "error cding to /src:\n$out" if $out =~ "ERR";
215 $out = '';
216
217 $in = "mget *\n";
218 $h->pump until $out =~ /^smb.*> \Z/m;
219 die "error retrieving files:\n$out" if $out =~ "ERR";
220
221 $in = "quit\n";
222 $h->finish;
223
224 Notice that we carefully clear $out after the first command/response
225 cycle? That's because IPC::Run does not delete $out when we continue,
226 and we don't want to trip over the old output in the second
227 command/response cycle.
228
229 Say you want to accumulate all the output in $out and analyze it
230 afterwards. Perl offers incremental regular expression matching using
231 the "m//gc" and pattern matching idiom and the "\G" assertion. IPC::Run
232 is careful not to disturb the current "pos()" value for scalars it
233 appends data to, so we could modify the above so as not to destroy $out
234 by adding a couple of "/gc" modifiers. The "/g" keeps us from tripping
235 over the previous prompt and the "/c" keeps us from resetting the prior
236 match position if the expected prompt doesn't materialize immediately:
237
238 $h = harness \@smbclient, \$in, \$out;
239
240 $in = "cd /src\n";
241 $h->pump until $out =~ /^smb.*> \Z/mgc;
242 die "error cding to /src:\n$out" if $out =~ "ERR";
243
244 $in = "mget *\n";
245 $h->pump until $out =~ /^smb.*> \Z/mgc;
246 die "error retrieving files:\n$out" if $out =~ "ERR";
247
248 $in = "quit\n";
249 $h->finish;
250
251 analyze( $out );
252
253 When using this technique, you may want to preallocate $out to have
254 plenty of memory or you may find that the act of growing $out each time
255 new input arrives causes an "O(length($out)^2)" slowdown as $out grows.
256 Say we expect no more than 10,000 characters of input at the most. To
257 preallocate memory to $out, do something like:
258
259 my $out = "x" x 10_000;
260 $out = "";
261
262 "perl" will allocate at least 10,000 characters' worth of space, then
263 mark the $out as having 0 length without freeing all that yummy RAM.
264
265 Timeouts and Timers
266 More than likely, you don't want your subprocesses to run forever, and
267 sometimes it's nice to know that they're going a little slowly. Timeouts
268 throw exceptions after a some time has elapsed, timers merely cause
269 pump() to return after some time has elapsed. Neither is reset/restarted
270 automatically.
271
272 Timeout objects are created by calling timeout( $interval ) and passing
273 the result to run(), start() or harness(). The timeout period starts
274 ticking just after all the child processes have been fork()ed or
275 spawn()ed, and are polled for expiration in run(), pump() and finish().
276 If/when they expire, an exception is thrown. This is typically useful to
277 keep a subprocess from taking too long.
278
279 If a timeout occurs in run(), all child processes will be terminated and
280 all file/pipe/ptty descriptors opened by run() will be closed. File
281 descriptors opened by the parent process and passed in to run() are not
282 closed in this event.
283
284 If a timeout occurs in pump(), pump_nb(), or finish(), it's up to you to
285 decide whether to kill_kill() all the children or to implement some more
286 graceful fallback. No I/O will be closed in pump(), pump_nb() or
287 finish() by such an exception (though I/O is often closed down in those
288 routines during the natural course of events).
289
290 Often an exception is too harsh. timer( $interval ) creates timer
291 objects that merely prevent pump() from blocking forever. This can be
292 useful for detecting stalled I/O or printing a soothing message or "."
293 to pacify an anxious user.
294
295 Timeouts and timers can both be restarted at any time using the timer's
296 start() method (this is not the start() that launches subprocesses). To
297 restart a timer, you need to keep a reference to the timer:
298
299 ## Start with a nice long timeout to let smbclient connect. If
300 ## pump or finish take too long, an exception will be thrown.
301
302 my $h;
303 eval {
304 $h = harness \@smbclient, \$in, \$out, \$err, ( my $t = timeout 30 );
305 sleep 11; # No effect: timer not running yet
306
307 start $h;
308 $in = "cd /src\n";
309 pump $h until ! length $in;
310
311 $in = "ls\n";
312 ## Now use a short timeout, since this should be faster
313 $t->start( 5 );
314 pump $h until ! length $in;
315
316 $t->start( 10 ); ## Give smbclient a little while to shut down.
317 $h->finish;
318 };
319 if ( $@ ) {
320 my $x = $@; ## Preserve $@ in case another exception occurs
321 $h->kill_kill; ## kill it gently, then brutally if need be, or just
322 ## brutally on Win32.
323 die $x;
324 }
325
326 Timeouts and timers are *not* checked once the subprocesses are shut
327 down; they will not expire in the interval between the last valid
328 process and when IPC::Run scoops up the processes' result codes, for
329 instance.
330
331 Spawning synchronization, child exception propagation
332 start() pauses the parent until the child executes the command or CODE
333 reference and propagates any exceptions thrown (including exec()
334 failure) back to the parent. This has several pleasant effects: any
335 exceptions thrown in the child, including exec() failure, come flying
336 out of start() or run() as though they had ocurred in the parent.
337
338 This includes exceptions your code thrown from init subs. In this
339 example:
340
341 eval {
342 run \@cmd, init => sub { die "blast it! foiled again!" };
343 };
344 print $@;
345
346 the exception "blast it! foiled again" will be thrown from the child
347 process (preventing the exec()) and printed by the parent.
348
349 In situations like
350
351 run \@cmd1, "|", \@cmd2, "|", \@cmd3;
352
353 @cmd1 will be initted and exec()ed before @cmd2, and @cmd2 before @cmd3.
354 This can save time and prevent oddball errors emitted by later commands
355 when earlier commands fail to execute. Note that IPC::Run doesn't start
356 any commands unless it can find the executables referenced by all
357 commands. These executables must pass both the "-f" and "-x" tests
358 described in perlfunc.
359
360 Another nice effect is that init() subs can take their time doing things
361 and there will be no problems caused by a parent continuing to execute
362 before a child's init() routine is complete. Say the init() routine
363 needs to open a socket or a temp file that the parent wants to connect
364 to; without this synchronization, the parent will need to implement a
365 retry loop to wait for the child to run, since often, the parent gets a
366 lot of things done before the child's first timeslice is allocated.
367
368 This is also quite necessary for pseudo-tty initialization, which needs
369 to take place before the parent writes to the child via pty. Writes that
370 occur before the pty is set up can get lost.
371
372 A final, minor, nicety is that debugging output from the child will be
373 emitted before the parent continues on, making for much clearer
374 debugging output in complex situations.
375
376 The only drawback I can conceive of is that the parent can't continue to
377 operate while the child is being initted. If this ever becomes a problem
378 in the field, we can implement an option to avoid this behavior, but I
379 don't expect it to.
380
381 Win32: executing CODE references isn't supported on Win32, see "Win32
382 LIMITATIONS" for details.
383
384 Syntax
385 run(), start(), and harness() can all take a harness specification as
386 input. A harness specification is either a single string to be passed to
387 the systems' shell:
388
389 run "echo 'hi there'";
390
391 or a list of commands, io operations, and/or timers/timeouts to execute.
392 Consecutive commands must be separated by a pipe operator '|' or an '&'.
393 External commands are passed in as array references, and, on systems
394 supporting fork(), Perl code may be passed in as subs:
395
396 run \@cmd;
397 run \@cmd1, '|', \@cmd2;
398 run \@cmd1, '&', \@cmd2;
399 run \&sub1;
400 run \&sub1, '|', \&sub2;
401 run \&sub1, '&', \&sub2;
402
403 '|' pipes the stdout of \@cmd1 the stdin of \@cmd2, just like a shell
404 pipe. '&' does not. Child processes to the right of a '&' will have
405 their stdin closed unless it's redirected-to.
406
407 IPC::Run::IO objects may be passed in as well, whether or not child
408 processes are also specified:
409
410 run io( "infile", ">", \$in ), io( "outfile", "<", \$in );
411
412 as can IPC::Run::Timer objects:
413
414 run \@cmd, io( "outfile", "<", \$in ), timeout( 10 );
415
416 Commands may be followed by scalar, sub, or i/o handle references for
417 redirecting child process input & output:
418
419 run \@cmd, \undef, \$out;
420 run \@cmd, \$in, \$out;
421 run \@cmd1, \&in, '|', \@cmd2, \*OUT;
422 run \@cmd1, \*IN, '|', \@cmd2, \&out;
423
424 This is known as succinct redirection syntax, since run(), start() and
425 harness(), figure out which file descriptor to redirect and how. File
426 descriptor 0 is presumed to be an input for the child process, all
427 others are outputs. The assumed file descriptor always starts at 0,
428 unless the command is being piped to, in which case it starts at 1.
429
430 To be explicit about your redirects, or if you need to do more complex
431 things, there's also a redirection operator syntax:
432
433 run \@cmd, '<', \undef, '>', \$out;
434 run \@cmd, '<', \undef, '>&', \$out_and_err;
435 run(
436 \@cmd1,
437 '<', \$in,
438 '|', \@cmd2,
439 \$out
440 );
441
442 Operator syntax is required if you need to do something other than
443 simple redirection to/from scalars or subs, like duping or closing file
444 descriptors or redirecting to/from a named file. The operators are
445 covered in detail below.
446
447 After each \@cmd (or \&foo), parsing begins in succinct mode and toggles
448 to operator syntax mode when an operator (ie plain scalar, not a ref) is
449 seen. Once in operator syntax mode, parsing only reverts to succinct
450 mode when a '|' or '&' is seen.
451
452 In succinct mode, each parameter after the \@cmd specifies what to do
453 with the next highest file descriptor. These File descriptor start with
454 0 (stdin) unless stdin is being piped to ("'|', \@cmd"), in which case
455 they start with 1 (stdout). Currently, being on the left of a pipe
456 ("\@cmd, \$out, \$err, '|'") does *not* cause stdout to be skipped,
457 though this may change since it's not as DWIMerly as it could be. Only
458 stdin is assumed to be an input in succinct mode, all others are assumed
459 to be outputs.
460
461 If no piping or redirection is specified for a child, it will inherit
462 the parent's open file handles as dictated by your system's
463 close-on-exec behavior and the $^F flag, except that processes after a
464 '&' will not inherit the parent's stdin. Also note that $^F does not
465 affect file desciptors obtained via POSIX, since it only applies to
466 full-fledged Perl file handles. Such processes will have their stdin
467 closed unless it has been redirected-to.
468
469 If you want to close a child processes stdin, you may do any of:
470
471 run \@cmd, \undef;
472 run \@cmd, \"";
473 run \@cmd, '<&-';
474 run \@cmd, '0<&-';
475
476 Redirection is done by placing redirection specifications immediately
477 after a command or child subroutine:
478
479 run \@cmd1, \$in, '|', \@cmd2, \$out;
480 run \@cmd1, '<', \$in, '|', \@cmd2, '>', \$out;
481
482 If you omit the redirection operators, descriptors are counted starting
483 at 0. Descriptor 0 is assumed to be input, all others are outputs. A
484 leading '|' consumes descriptor 0, so this works as expected.
485
486 run \@cmd1, \$in, '|', \@cmd2, \$out;
487
488 The parameter following a redirection operator can be a scalar ref, a
489 subroutine ref, a file name, an open filehandle, or a closed filehandle.
490
491 If it's a scalar ref, the child reads input from or sends output to that
492 variable:
493
494 $in = "Hello World.\n";
495 run \@cat, \$in, \$out;
496 print $out;
497
498 Scalars used in incremental (start()/pump()/finish()) applications are
499 treated as queues: input is removed from input scalers, resulting in
500 them dwindling to '', and output is appended to output scalars. This is
501 not true of harnesses run() in batch mode.
502
503 It's usually wise to append new input to be sent to the child to the
504 input queue, and you'll often want to zap output queues to '' before
505 pumping.
506
507 $h = start \@cat, \$in;
508 $in = "line 1\n";
509 pump $h;
510 $in .= "line 2\n";
511 pump $h;
512 $in .= "line 3\n";
513 finish $h;
514
515 The final call to finish() must be there: it allows the child
516 process(es) to run to completion and waits for their exit values.
517
518 OBSTINATE CHILDREN
519 Interactive applications are usually optimized for human use. This can
520 help or hinder trying to interact with them through modules like
521 IPC::Run. Frequently, programs alter their behavior when they detect
522 that stdin, stdout, or stderr are not connected to a tty, assuming that
523 they are being run in batch mode. Whether this helps or hurts depends on
524 which optimizations change. And there's often no way of telling what a
525 program does in these areas other than trial and error and,
526 occasionally, reading the source. This includes different versions and
527 implementations of the same program.
528
529 All hope is not lost, however. Most programs behave in reasonably
530 tractable manners, once you figure out what it's trying to do.
531
532 Here are some of the issues you might need to be aware of.
533
534 * fflush()ing stdout and stderr
535
536 This lets the user see stdout and stderr immediately. Many programs
537 undo this optimization if stdout is not a tty, making them harder to
538 manage by things like IPC::Run.
539
540 Many programs decline to fflush stdout or stderr if they do not
541 detect a tty there. Some ftp commands do this, for instance.
542
543 If this happens to you, look for a way to force interactive
544 behavior, like a command line switch or command. If you can't, you
545 will need to use a pseudo terminal ('<pty<' and '>pty>').
546
547 * false prompts
548
549 Interactive programs generally do not guarantee that output from
550 user commands won't contain a prompt string. For example, your shell
551 prompt might be a '$', and a file named '$' might be the only file
552 in a directory listing.
553
554 This can make it hard to guarantee that your output parser won't be
555 fooled into early termination of results.
556
557 To help work around this, you can see if the program can alter it's
558 prompt, and use something you feel is never going to occur in actual
559 practice.
560
561 You should also look for your prompt to be the only thing on a line:
562
563 pump $h until $out =~ /^<SILLYPROMPT>\s?\z/m;
564
565 (use "(?!\n)\Z" in place of "\z" on older perls).
566
567 You can also take the approach that IPC::ChildSafe takes and emit a
568 command with known output after each 'real' command you issue, then
569 look for this known output. See new_appender() and new_chunker() for
570 filters that can help with this task.
571
572 If it's not convenient or possibly to alter a prompt or use a known
573 command/response pair, you might need to autodetect the prompt in
574 case the local version of the child program is different then the
575 one you tested with, or if the user has control over the look & feel
576 of the prompt.
577
578 * Refusing to accept input unless stdin is a tty.
579
580 Some programs, for security reasons, will only accept certain types
581 of input from a tty. su, notable, will not prompt for a password
582 unless it's connected to a tty.
583
584 If this is your situation, use a pseudo terminal ('<pty<' and
585 '>pty>').
586
587 * Not prompting unless connected to a tty.
588
589 Some programs don't prompt unless stdin or stdout is a tty. See if
590 you can turn prompting back on. If not, see if you can come up with
591 a command that you can issue after every real command and look for
592 it's output, as IPC::ChildSafe does. There are two filters included
593 with IPC::Run that can help with doing this: appender and chunker
594 (see new_appender() and new_chunker()).
595
596 * Different output format when not connected to a tty.
597
598 Some commands alter their formats to ease machine parsability when
599 they aren't connected to a pipe. This is actually good, but can be
600 surprising.
601
602 PSEUDO TERMINALS
603 On systems providing pseudo terminals under /dev, IPC::Run can use
604 IO::Pty (available on CPAN) to provide a terminal environment to
605 subprocesses. This is necessary when the subprocess really wants to
606 think it's connected to a real terminal.
607
608 CAVEATS
609 Psuedo-terminals are not pipes, though they are similar. Here are some
610 differences to watch out for.
611
612 Echoing
613 Sending to stdin will cause an echo on stdout, which occurs before
614 each line is passed to the child program. There is currently no way
615 to disable this, although the child process can and should disable
616 it for things like passwords.
617
618 Shutdown
619 IPC::Run cannot close a pty until all output has been collected.
620 This means that it is not possible to send an EOF to stdin by
621 half-closing the pty, as we can when using a pipe to stdin.
622
623 This means that you need to send the child process an exit command
624 or signal, or run() / finish() will time out. Be careful not to
625 expect a prompt after sending the exit command.
626
627 Command line editing
628 Some subprocesses, notable shells that depend on the user's prompt
629 settings, will reissue the prompt plus the command line input so far
630 once for each character.
631
632 '>pty>' means '&>pty>', not '1>pty>'
633 The pseudo terminal redirects both stdout and stderr unless you
634 specify a file descriptor. If you want to grab stderr separately, do
635 this:
636
637 start \@cmd, '<pty<', \$in, '>pty>', \$out, '2>', \$err;
638
639 stdin, stdout, and stderr not inherited
640 Child processes harnessed to a pseudo terminal have their stdin,
641 stdout, and stderr completely closed before any redirection
642 operators take effect. This casts of the bonds of the controlling
643 terminal. This is not done when using pipes.
644
645 Right now, this affects all children in a harness that has a pty in
646 use, even if that pty would not affect a particular child. That's a
647 bug and will be fixed. Until it is, it's best not to mix-and-match
648 children.
649
650 Redirection Operators
651 Operator SHNP Description
652 ======== ==== ===========
653 <, N< SHN Redirects input to a child's fd N (0 assumed)
654
655 >, N> SHN Redirects output from a child's fd N (1 assumed)
656 >>, N>> SHN Like '>', but appends to scalars or named files
657 >&, &> SHN Redirects stdout & stderr from a child process
658
659 <pty, N<pty S Like '<', but uses a pseudo-tty instead of a pipe
660 >pty, N>pty S Like '>', but uses a pseudo-tty instead of a pipe
661
662 N<&M Dups input fd N to input fd M
663 M>&N Dups output fd N to input fd M
664 N<&- Closes fd N
665
666 <pipe, N<pipe P Pipe opens H for caller to read, write, close.
667 >pipe, N>pipe P Pipe opens H for caller to read, write, close.
668
669 'N' and 'M' are placeholders for integer file descriptor numbers. The
670 terms 'input' and 'output' are from the child process's perspective.
671
672 The SHNP field indicates what parameters an operator can take:
673
674 S: \$scalar or \&function references. Filters may be used with
675 these operators (and only these).
676 H: \*HANDLE or IO::Handle for caller to open, and close
677 N: "file name".
678 P: \*HANDLE opened by IPC::Run as the parent end of a pipe, but read
679 and written to and closed by the caller (like IPC::Open3).
680
681 Redirecting input: [n]<, [n]<pipe
682 You can input the child reads on file descriptor number n to come
683 from a scalar variable, subroutine, file handle, or a named file. If
684 stdin is not redirected, the parent's stdin is inherited.
685
686 run \@cat, \undef ## Closes child's stdin immediately
687 or die "cat returned $?";
688
689 run \@cat, \$in;
690
691 run \@cat, \<<TOHERE;
692 blah
693 TOHERE
694
695 run \@cat, \&input; ## Calls &input, feeding data returned
696 ## to child's. Closes child's stdin
697 ## when undef is returned.
698
699 Redirecting from named files requires you to use the input
700 redirection operator:
701
702 run \@cat, '<.profile';
703 run \@cat, '<', '.profile';
704
705 open IN, "<foo";
706 run \@cat, \*IN;
707 run \@cat, *IN{IO};
708
709 The form used second example here is the safest, since filenames
710 like "0" and "&more\n" won't confuse &run:
711
712 You can't do either of
713
714 run \@a, *IN; ## INVALID
715 run \@a, '<', *IN; ## BUGGY: Reads file named like "*main::A"
716
717 because perl passes a scalar containing a string that looks like
718 "*main::A" to &run, and &run can't tell the difference between that
719 and a redirection operator or a file name. &run guarantees that any
720 scalar you pass after a redirection operator is a file name.
721
722 If your child process will take input from file descriptors other
723 than 0 (stdin), you can use a redirection operator with any of the
724 valid input forms (scalar ref, sub ref, etc.):
725
726 run \@cat, '3<', \$in3;
727
728 When redirecting input from a scalar ref, the scalar ref is used as
729 a queue. This allows you to use &harness and pump() to feed
730 incremental bits of input to a coprocess. See "Coprocesses" below
731 for more information.
732
733 The <pipe operator opens the write half of a pipe on the filehandle
734 glob reference it takes as an argument:
735
736 $h = start \@cat, '<pipe', \*IN;
737 print IN "hello world\n";
738 pump $h;
739 close IN;
740 finish $h;
741
742 Unlike the other '<' operators, IPC::Run does nothing further with
743 it: you are responsible for it. The previous example is functionally
744 equivalent to:
745
746 pipe( \*R, \*IN ) or die $!;
747 $h = start \@cat, '<', \*IN;
748 print IN "hello world\n";
749 pump $h;
750 close IN;
751 finish $h;
752
753 This is like the behavior of IPC::Open2 and IPC::Open3.
754
755 Win32: The handle returned is actually a socket handle, so you can
756 use select() on it.
757
758 Redirecting output: [n]>, [n]>>, [n]>&[m], [n]>pipe
759 You can redirect any output the child emits to a scalar variable,
760 subroutine, file handle, or file name. You can have &run truncate or
761 append to named files or scalars. If you are redirecting stdin as
762 well, or if the command is on the receiving end of a pipeline ('|'),
763 you can omit the redirection operator:
764
765 @ls = ( 'ls' );
766 run \@ls, \undef, \$out
767 or die "ls returned $?";
768
769 run \@ls, \undef, \&out; ## Calls &out each time some output
770 ## is received from the child's
771 ## when undef is returned.
772
773 run \@ls, \undef, '2>ls.err';
774 run \@ls, '2>', 'ls.err';
775
776 The two parameter form guarantees that the filename will not be
777 interpreted as a redirection operator:
778
779 run \@ls, '>', "&more";
780 run \@ls, '2>', ">foo\n";
781
782 You can pass file handles you've opened for writing:
783
784 open( *OUT, ">out.txt" );
785 open( *ERR, ">err.txt" );
786 run \@cat, \*OUT, \*ERR;
787
788 Passing a scalar reference and a code reference requires a little
789 more work, but allows you to capture all of the output in a scalar
790 or each piece of output by a callback:
791
792 These two do the same things:
793
794 run( [ 'ls' ], '2>', sub { $err_out .= $_[0] } );
795
796 does the same basic thing as:
797
798 run( [ 'ls' ], '2>', \$err_out );
799
800 The subroutine will be called each time some data is read from the
801 child.
802
803 The >pipe operator is different in concept than the other '>'
804 operators, although it's syntax is similar:
805
806 $h = start \@cat, $in, '>pipe', \*OUT, '2>pipe', \*ERR;
807 $in = "hello world\n";
808 finish $h;
809 print <OUT>;
810 print <ERR>;
811 close OUT;
812 close ERR;
813
814 causes two pipe to be created, with one end attached to cat's stdout
815 and stderr, respectively, and the other left open on OUT and ERR, so
816 that the script can manually read(), select(), etc. on them. This is
817 like the behavior of IPC::Open2 and IPC::Open3.
818
819 Win32: The handle returned is actually a socket handle, so you can
820 use select() on it.
821
822 Duplicating output descriptors: >&m, n>&m
823 This duplicates output descriptor number n (default is 1 if n is
824 omitted) from descriptor number m.
825
826 Duplicating input descriptors: <&m, n<&m
827 This duplicates input descriptor number n (default is 0 if n is
828 omitted) from descriptor number m
829
830 Closing descriptors: <&-, 3<&-
831 This closes descriptor number n (default is 0 if n is omitted). The
832 following commands are equivalent:
833
834 run \@cmd, \undef;
835 run \@cmd, '<&-';
836 run \@cmd, '<in.txt', '<&-';
837
838 Doing
839
840 run \@cmd, \$in, '<&-'; ## SIGPIPE recipe.
841
842 is dangerous: the parent will get a SIGPIPE if $in is not empty.
843
844 Redirecting both stdout and stderr: &>, >&, &>pipe, >pipe&
845 The following pairs of commands are equivalent:
846
847 run \@cmd, '>&', \$out; run \@cmd, '>', \$out, '2>&1';
848 run \@cmd, '>&', 'out.txt'; run \@cmd, '>', 'out.txt', '2>&1';
849
850 etc.
851
852 File descriptor numbers are not permitted to the left or the right
853 of these operators, and the '&' may occur on either end of the
854 operator.
855
856 The '&>pipe' and '>pipe&' variants behave like the '>pipe' operator,
857 except that both stdout and stderr write to the created pipe.
858
859 Redirection Filters
860 Both input redirections and output redirections that use scalars or
861 subs as endpoints may have an arbitrary number of filter subs placed
862 between them and the child process. This is useful if you want to
863 receive output in chunks, or if you want to massage each chunk of
864 data sent to the child. To use this feature, you must use operator
865 syntax:
866
867 run(
868 \@cmd
869 '<', \&in_filter_2, \&in_filter_1, $in,
870 '>', \&out_filter_1, \&in_filter_2, $out,
871 );
872
873 This capability is not provided for IO handles or named files.
874
875 Two filters are provided by IPC::Run: appender and chunker. Because
876 these may take an argument, you need to use the constructor
877 functions new_appender() and new_chunker() rather than using \&
878 syntax:
879
880 run(
881 \@cmd
882 '<', new_appender( "\n" ), $in,
883 '>', new_chunker, $out,
884 );
885
886 Just doing I/O
887 If you just want to do I/O to a handle or file you open yourself, you
888 may specify a filehandle or filename instead of a command in the harness
889 specification:
890
891 run io( "filename", '>', \$recv );
892
893 $h = start io( $io, '>', \$recv );
894
895 $h = harness \@cmd, '&', io( "file", '<', \$send );
896
897 Options
898 Options are passed in as name/value pairs:
899
900 run \@cat, \$in, debug => 1;
901
902 If you pass the debug option, you may want to pass it in first, so you
903 can see what parsing is going on:
904
905 run debug => 1, \@cat, \$in;
906
907 debug
908 Enables debugging output in parent and child. Debugging info is
909 emitted to the STDERR that was present when IPC::Run was first
910 "use()"ed (it's "dup()"ed out of the way so that it can be
911 redirected in children without having debugging output emitted on
912 it).
913
914 RETURN VALUES
915 harness() and start() return a reference to an IPC::Run harness. This is
916 blessed in to the IPC::Run package, so you may make later calls to
917 functions as members if you like:
918
919 $h = harness( ... );
920 $h->start;
921 $h->pump;
922 $h->finish;
923
924 $h = start( .... );
925 $h->pump;
926 ...
927
928 Of course, using method call syntax lets you deal with any IPC::Run
929 subclasses that might crop up, but don't hold your breath waiting for
930 any.
931
932 run() and finish() return TRUE when all subcommands exit with a 0 result
933 code. This is the opposite of perl's system() command.
934
935 All routines raise exceptions (via die()) when error conditions are
936 recognized. A non-zero command result is not treated as an error
937 condition, since some commands are tests whose results are reported in
938 their exit codes.
939
940 ROUTINES
941 run Run takes a harness or harness specification and runs it, pumping
942 all input to the child(ren), closing the input pipes when no more
943 input is available, collecting all output that arrives, until the
944 pipes delivering output are closed, then waiting for the children to
945 exit and reaping their result codes.
946
947 You may think of "run( ... )" as being like
948
949 start( ... )->finish();
950
951 , though there is one subtle difference: run() does not set
952 \$input_scalars to '' like finish() does. If an exception is thrown
953 from run(), all children will be killed off "gently", and then
954 "annihilated" if they do not go gently (in to that dark night.
955 sorry).
956
957 If any exceptions are thrown, this does a "kill_kill" before
958 propogating them.
959
960 signal
961 ## To send it a specific signal by name ("USR1"):
962 signal $h, "USR1";
963 $h->signal ( "USR1" );
964
965 If $signal is provided and defined, sends a signal to all child
966 processes. Try not to send numeric signals, use "KILL" instead of 9,
967 for instance. Numeric signals aren't portable.
968
969 Throws an exception if $signal is undef.
970
971 This will *not* clean up the harness, "finish" it if you kill it.
972
973 Normally TERM kills a process gracefully (this is what the command
974 line utility "kill" does by default), INT is sent by one of the keys
975 "^C", "Backspace" or "<Del>", and "QUIT" is used to kill a process
976 and make it coredump.
977
978 The "HUP" signal is often used to get a process to "restart",
979 rereading config files, and "USR1" and "USR2" for really
980 application-specific things.
981
982 Often, running "kill -l" (that's a lower case "L") on the command
983 line will list the signals present on your operating system.
984
985 WARNING: The signal subsystem is not at all portable. We *may* offer
986 to simulate "TERM" and "KILL" on some operating systems, submit code
987 to me if you want this.
988
989 WARNING 2: Up to and including perl v5.6.1, doing almost anything in
990 a signal handler could be dangerous. The most safe code avoids all
991 mallocs and system calls, usually by preallocating a flag before
992 entering the signal handler, altering the flag's value in the
993 handler, and responding to the changed value in the main system:
994
995 my $got_usr1 = 0;
996 sub usr1_handler { ++$got_signal }
997
998 $SIG{USR1} = \&usr1_handler;
999 while () { sleep 1; print "GOT IT" while $got_usr1--; }
1000
1001 Even this approach is perilous if ++ and -- aren't atomic on your
1002 system (I've never heard of this on any modern CPU large enough to
1003 run perl).
1004
1005 kill_kill
1006 ## To kill off a process:
1007 $h->kill_kill;
1008 kill_kill $h;
1009
1010 ## To specify the grace period other than 30 seconds:
1011 kill_kill $h, grace => 5;
1012
1013 ## To send QUIT instead of KILL if a process refuses to die:
1014 kill_kill $h, coup_d_grace => "QUIT";
1015
1016 Sends a "TERM", waits for all children to exit for up to 30 seconds,
1017 then sends a "KILL" to any that survived the "TERM".
1018
1019 Will wait for up to 30 more seconds for the OS to sucessfully "KILL"
1020 the processes.
1021
1022 The 30 seconds may be overriden by setting the "grace" option, this
1023 overrides both timers.
1024
1025 The harness is then cleaned up.
1026
1027 The doubled name indicates that this function may kill again and
1028 avoids colliding with the core Perl "kill" function.
1029
1030 Returns a 1 if the "TERM" was sufficient, or a 0 if "KILL" was
1031 required. Throws an exception if "KILL" did not permit the children
1032 to be reaped.
1033
1034 NOTE: The grace period is actually up to 1 second longer than that
1035 given. This is because the granularity of "time" is 1 second. Let me
1036 know if you need finer granularity, we can leverage Time::HiRes
1037 here.
1038
1039 Win32: Win32 does not know how to send real signals, so "TERM" is a
1040 full-force kill on Win32. Thus all talk of grace periods, etc. do
1041 not apply to Win32.
1042
1043 harness
1044 Takes a harness specification and returns a harness. This harness is
1045 blessed in to IPC::Run, allowing you to use method call syntax for
1046 run(), start(), et al if you like.
1047
1048 harness() is provided so that you can pre-build harnesses if you
1049 would like to, but it's not required..
1050
1051 You may proceed to run(), start() or pump() after calling harness()
1052 (pump() calls start() if need be). Alternatively, you may pass your
1053 harness specification to run() or start() and let them harness() for
1054 you. You can't pass harness specifications to pump(), though.
1055
1056 close_terminal
1057 This is used as (or in) an init sub to cast off the bonds of a
1058 controlling terminal. It must precede all other redirection ops that
1059 affect STDIN, STDOUT, or STDERR to be guaranteed effective.
1060
1061 start
1062 $h = start(
1063 \@cmd, \$in, \$out, ...,
1064 timeout( 30, name => "process timeout" ),
1065 $stall_timeout = timeout( 10, name => "stall timeout" ),
1066 );
1067
1068 $h = start \@cmd, '<', \$in, '|', \@cmd2, ...;
1069
1070 start() accepts a harness or harness specification and returns a
1071 harness after building all of the pipes and launching (via
1072 fork()/exec(), or, maybe someday, spawn()) all the child processes.
1073 It does not send or receive any data on the pipes, see pump() and
1074 finish() for that.
1075
1076 You may call harness() and then pass it's result to start() if you
1077 like, but you only need to if it helps you structure or tune your
1078 application. If you do call harness(), you may skip start() and
1079 proceed directly to pump.
1080
1081 start() also starts all timers in the harness. See IPC::Run::Timer
1082 for more information.
1083
1084 start() flushes STDOUT and STDERR to help you avoid duplicate
1085 output. It has no way of asking Perl to flush all your open
1086 filehandles, so you are going to need to flush any others you have
1087 open. Sorry.
1088
1089 Here's how if you don't want to alter the state of $| for your
1090 filehandle:
1091
1092 $ofh = select HANDLE; $of = $|; $| = 1; $| = $of; select $ofh;
1093
1094 If you don't mind leaving output unbuffered on HANDLE, you can do
1095 the slightly shorter
1096
1097 $ofh = select HANDLE; $| = 1; select $ofh;
1098
1099 Or, you can use IO::Handle's flush() method:
1100
1101 use IO::Handle;
1102 flush HANDLE;
1103
1104 Perl needs the equivalent of C's fflush( (FILE *)NULL ).
1105
1106 pump
1107 pump $h;
1108 $h->pump;
1109
1110 Pump accepts a single parameter harness. It blocks until it delivers
1111 some input or recieves some output. It returns TRUE if there is
1112 still input or output to be done, FALSE otherwise.
1113
1114 pump() will automatically call start() if need be, so you may call
1115 harness() then proceed to pump() if that helps you structure your
1116 application.
1117
1118 If pump() is called after all harnessed activities have completed, a
1119 "process ended prematurely" exception to be thrown. This allows for
1120 simple scripting of external applications without having to add lots
1121 of error handling code at each step of the script:
1122
1123 $h = harness \@smbclient, \$in, \$out, $err;
1124
1125 $in = "cd /foo\n";
1126 $h->pump until $out =~ /^smb.*> \Z/m;
1127 die "error cding to /foo:\n$out" if $out =~ "ERR";
1128 $out = '';
1129
1130 $in = "mget *\n";
1131 $h->pump until $out =~ /^smb.*> \Z/m;
1132 die "error retrieving files:\n$out" if $out =~ "ERR";
1133
1134 $h->finish;
1135
1136 warn $err if $err;
1137
1138 pump_nb
1139 pump_nb $h;
1140 $h->pump_nb;
1141
1142 "pump() non-blocking", pumps if anything's ready to be pumped,
1143 returns immediately otherwise. This is useful if you're doing some
1144 long-running task in the foreground, but don't want to starve any
1145 child processes.
1146
1147 pumpable
1148 Returns TRUE if calling pump() won't throw an immediate "process
1149 ended prematurely" exception. This means that there are open I/O
1150 channels or active processes. May yield the parent processes' time
1151 slice for 0.01 second if all pipes are to the child and all are
1152 paused. In this case we can't tell if the child is dead, so we yield
1153 the processor and then attempt to reap the child in a nonblocking
1154 way.
1155
1156 reap_nb
1157 Attempts to reap child processes, but does not block.
1158
1159 Does not currently take any parameters, one day it will allow
1160 specific children to be reaped.
1161
1162 Only call this from a signal handler if your "perl" is recent enough
1163 to have safe signal handling (5.6.1 did not, IIRC, but it was beign
1164 discussed on perl5-porters). Calling this (or doing any significant
1165 work) in a signal handler on older "perl"s is asking for seg faults.
1166
1167 finish
1168 This must be called after the last start() or pump() call for a
1169 harness, or your system will accumulate defunct processes and you
1170 may "leak" file descriptors.
1171
1172 finish() returns TRUE if all children returned 0 (and were not
1173 signaled and did not coredump, ie ! $?), and FALSE otherwise (this
1174 is like run(), and the opposite of system()).
1175
1176 Once a harness has been finished, it may be run() or start()ed
1177 again, including by pump()s auto-start.
1178
1179 If this throws an exception rather than a normal exit, the harness
1180 may be left in an unstable state, it's best to kill the harness to
1181 get rid of all the child processes, etc.
1182
1183 Specifically, if a timeout expires in finish(), finish() will not
1184 kill all the children. Call "<$h-"kill_kill>> in this case if you
1185 care. This differs from the behavior of "run".
1186
1187 $h->result;
1188
1189 Returns the first non-zero result code (ie $? >> 8). See
1190 "full_result" to get the $? value for a child process.
1191
1192 To get the result of a particular child, do:
1193
1194 $h->result( 0 ); # first child's $? >> 8
1195 $h->result( 1 ); # second child
1196
1197 or
1198
1199 ($h->results)[0]
1200 ($h->results)[1]
1201
1202 Returns undef if no child processes were spawned and no child number
1203 was specified. Throws an exception if an out-of-range child number
1204 is passed.
1205
1206 results
1207 Returns a list of child exit values. See "full_results" if you want
1208 to know if a signal killed the child.
1209
1210 Throws an exception if the harness is not in a finished state.
1211
1212 full_result
1213 $h->full_result;
1214
1215 Returns the first non-zero $?. See "result" to get the first $? >> 8
1216 value for a child process.
1217
1218 To get the result of a particular child, do:
1219
1220 $h->full_result( 0 ); # first child's $? >> 8
1221 $h->full_result( 1 ); # second child
1222
1223 or
1224
1225 ($h->full_results)[0]
1226 ($h->full_results)[1]
1227
1228 Returns undef if no child processes were spawned and no child number
1229 was specified. Throws an exception if an out-of-range child number
1230 is passed.
1231
1232 full_results
1233 Returns a list of child exit values as returned by "wait". See
1234 "results" if you don't care about coredumps or signals.
1235
1236 Throws an exception if the harness is not in a finished state.
1237
1238 FILTERS
1239 These filters are used to modify input our output between a child
1240 process and a scalar or subroutine endpoint.
1241
1242 binary
1243 run \@cmd, ">", binary, \$out;
1244 run \@cmd, ">", binary, \$out; ## Any TRUE value to enable
1245 run \@cmd, ">", binary 0, \$out; ## Any FALSE value to disable
1246
1247 This is a constructor for a "binmode" "filter" that tells IPC::Run
1248 to keep the carriage returns that would ordinarily be edited out for
1249 you (binmode is usually off). This is not a real filter, but an
1250 option masquerading as a filter.
1251
1252 It's not named "binmode" because you're likely to want to call
1253 Perl's binmode in programs that are piping binary data around.
1254
1255 new_chunker
1256 This breaks a stream of data in to chunks, based on an optional
1257 scalar or regular expression parameter. The default is the Perl
1258 input record separator in $/, which is a newline be default.
1259
1260 run \@cmd, '>', new_chunker, \&lines_handler;
1261 run \@cmd, '>', new_chunker( "\r\n" ), \&lines_handler;
1262
1263 Because this uses $/ by default, you should always pass in a
1264 parameter if you are worried about other code (modules, etc)
1265 modifying $/.
1266
1267 If this filter is last in a filter chain that dumps in to a scalar,
1268 the scalar must be set to '' before a new chunk will be written to
1269 it.
1270
1271 As an example of how a filter like this can be written, here's a
1272 chunker that splits on newlines:
1273
1274 sub line_splitter {
1275 my ( $in_ref, $out_ref ) = @_;
1276
1277 return 0 if length $$out_ref;
1278
1279 return input_avail && do {
1280 while (1) {
1281 if ( $$in_ref =~ s/\A(.*?\n)// ) {
1282 $$out_ref .= $1;
1283 return 1;
1284 }
1285 my $hmm = get_more_input;
1286 unless ( defined $hmm ) {
1287 $$out_ref = $$in_ref;
1288 $$in_ref = '';
1289 return length $$out_ref ? 1 : 0;
1290 }
1291 return 0 if $hmm eq 0;
1292 }
1293 }
1294 };
1295
1296 new_appender
1297 This appends a fixed string to each chunk of data read from the
1298 source scalar or sub. This might be useful if you're writing
1299 commands to a child process that always must end in a fixed string,
1300 like "\n":
1301
1302 run( \@cmd,
1303 '<', new_appender( "\n" ), \&commands,
1304 );
1305
1306 Here's a typical filter sub that might be created by new_appender():
1307
1308 sub newline_appender {
1309 my ( $in_ref, $out_ref ) = @_;
1310
1311 return input_avail && do {
1312 $$out_ref = join( '', $$out_ref, $$in_ref, "\n" );
1313 $$in_ref = '';
1314 1;
1315 }
1316 };
1317
1318 io Takes a filename or filehandle, a redirection operator, optional
1319 filters, and a source or destination (depends on the redirection
1320 operator). Returns an IPC::Run::IO object suitable for harness()ing
1321 (including via start() or run()).
1322
1323 This is shorthand for
1324
1325 require IPC::Run::IO;
1326
1327 ... IPC::Run::IO->new(...) ...
1328
1329 timer
1330 $h = start( \@cmd, \$in, \$out, $t = timer( 5 ) );
1331
1332 pump $h until $out =~ /expected stuff/ || $t->is_expired;
1333
1334 Instantiates a non-fatal timer. pump() returns once each time a
1335 timer expires. Has no direct effect on run(), but you can pass a
1336 subroutine to fire when the timer expires.
1337
1338 See "timeout" for building timers that throw exceptions on
1339 expiration.
1340
1341 See "timer" in IPC::Run::Timer for details.
1342
1343 timeout
1344 $h = start( \@cmd, \$in, \$out, $t = timeout( 5 ) );
1345
1346 pump $h until $out =~ /expected stuff/;
1347
1348 Instantiates a timer that throws an exception when it expires. If
1349 you don't provide an exception, a default exception that matches
1350 /^IPC::Run: .*timed out/ is thrown by default. You can pass in your
1351 own exception scalar or reference:
1352
1353 $h = start(
1354 \@cmd, \$in, \$out,
1355 $t = timeout( 5, exception => 'slowpoke' ),
1356 );
1357
1358 or set the name used in debugging message and in the default
1359 exception string:
1360
1361 $h = start(
1362 \@cmd, \$in, \$out,
1363 timeout( 50, name => 'process timer' ),
1364 $stall_timer = timeout( 5, name => 'stall timer' ),
1365 );
1366
1367 pump $h until $out =~ /started/;
1368
1369 $in = 'command 1';
1370 $stall_timer->start;
1371 pump $h until $out =~ /command 1 finished/;
1372
1373 $in = 'command 2';
1374 $stall_timer->start;
1375 pump $h until $out =~ /command 2 finished/;
1376
1377 $in = 'very slow command 3';
1378 $stall_timer->start( 10 );
1379 pump $h until $out =~ /command 3 finished/;
1380
1381 $stall_timer->start( 5 );
1382 $in = 'command 4';
1383 pump $h until $out =~ /command 4 finished/;
1384
1385 $stall_timer->reset; # Prevent restarting or expirng
1386 finish $h;
1387
1388 See "timer" for building non-fatal timers.
1389
1390 See "timer" in IPC::Run::Timer for details.
1391
1392 FILTER IMPLEMENTATION FUNCTIONS
1393 These functions are for use from within filters.
1394
1395 input_avail
1396 Returns TRUE if input is available. If none is available, then
1397 &get_more_input is called and its result is returned.
1398
1399 This is usually used in preference to &get_more_input so that the
1400 calling filter removes all data from the $in_ref before more data
1401 gets read in to $in_ref.
1402
1403 "input_avail" is usually used as part of a return expression:
1404
1405 return input_avail && do {
1406 ## process the input just gotten
1407 1;
1408 };
1409
1410 This technique allows input_avail to return the undef or 0 that a
1411 filter normally returns when there's no input to process. If a
1412 filter stores intermediate values, however, it will need to react to
1413 an undef:
1414
1415 my $got = input_avail;
1416 if ( ! defined $got ) {
1417 ## No more input ever, flush internal buffers to $out_ref
1418 }
1419 return $got unless $got;
1420 ## Got some input, move as much as need be
1421 return 1 if $added_to_out_ref;
1422
1423 get_more_input
1424 This is used to fetch more input in to the input variable. It
1425 returns undef if there will never be any more input, 0 if there is
1426 none now, but there might be in the future, and TRUE if more input
1427 was gotten.
1428
1429 "get_more_input" is usually used as part of a return expression, see
1430 "input_avail" for more information.
1431
1432 TODO
1433 These will be addressed as needed and as time allows.
1434
1435 Stall timeout.
1436
1437 Expose a list of child process objects. When I do this, each child
1438 process is likely to be blessed into IPC::Run::Proc.
1439
1440 $kid->abort(), $kid->kill(), $kid->signal( $num_or_name ).
1441
1442 Write tests for /(full_)?results?/ subs.
1443
1444 Currently, pump() and run() only work on systems where select() works on
1445 the filehandles returned by pipe(). This does *not* include ActiveState
1446 on Win32, although it does work on cygwin under Win32 (thought the tests
1447 whine a bit). I'd like to rectify that, suggestions and patches welcome.
1448
1449 Likewise start() only fully works on fork()/exec() machines (well, just
1450 fork() if you only ever pass perl subs as subprocesses). There's some
1451 scaffolding for calling Open3::spawn_with_handles(), but that's
1452 untested, and not that useful with limited select().
1453
1454 Support for "\@sub_cmd" as an argument to a command which gets replaced
1455 with /dev/fd or the name of a temporary file containing foo's output.
1456 This is like <(sub_cmd ...) found in bash and csh (IIRC).
1457
1458 Allow multiple harnesses to be combined as independant sets of processes
1459 in to one 'meta-harness'.
1460
1461 Allow a harness to be passed in place of an \@cmd. This would allow
1462 multiple harnesses to be aggregated.
1463
1464 Ability to add external file descriptors w/ filter chains and endpoints.
1465
1466 Ability to add timeouts and timing generators (i.e. repeating timeouts).
1467
1468 High resolution timeouts.
1469
1470 Win32 LIMITATIONS
1471 Fails on Win9X
1472 If you want Win9X support, you'll have to debug it or fund me
1473 because I don't use that system any more. The Win32 subsysem has
1474 been extended to use temporary files in simple run() invocations and
1475 these may actually work on Win9X too, but I don't have time to work
1476 on it.
1477
1478 May deadlock on Win2K (but not WinNT4 or WinXPPro)
1479 Spawning more than one subprocess on Win2K causes a deadlock I
1480 haven't figured out yet, but simple uses of run() often work. Passes
1481 all tests on WinXPPro and WinNT.
1482
1483 no support yet for <pty< and >pty>
1484 These are likely to be implemented as "<" and ">" with binmode on,
1485 not sure.
1486
1487 no support for file descriptors higher than 2 (stderr)
1488 Win32 only allows passing explicit fds 0, 1, and 2. If you really,
1489 really need to pass file handles, us Win32API:: GetOsFHandle() or
1490 ::FdGetOsFHandle() to get the integer handle and pass it to the
1491 child process using the command line, environment, stdin,
1492 intermediary file, or other IPC mechnism. Then use that handle in
1493 the child (Win32API.pm provides ways to reconstitute Perl file
1494 handles from Win32 file handles).
1495
1496 no support for subroutine subprocesses (CODE refs)
1497 Can't fork(), so the subroutines would have no context, and closures
1498 certainly have no meaning
1499
1500 Perhaps with Win32 fork() emulation, this can be supported in a
1501 limited fashion, but there are other very serious problems with
1502 that: all parent fds get dup()ed in to the thread emulating the
1503 forked process, and that keeps the parent from being able to close
1504 all of the appropriate fds.
1505
1506 no support for init => sub {} routines.
1507 Win32 processes are created from scratch, there is no way to do an
1508 init routine that will affect the running child. Some limited
1509 support might be implemented one day, do chdir() and %ENV changes
1510 can be made.
1511
1512 signals
1513 Win32 does not fully support signals. signal() is likely to cause
1514 errors unless sending a signal that Perl emulates, and "kill_kill()"
1515 is immediately fatal (there is no grace period).
1516
1517 helper processes
1518 IPC::Run uses helper processes, one per redirected file, to adapt
1519 between the anonymous pipe connected to the child and the TCP socket
1520 connected to the parent. This is a waste of resources and will
1521 change in the future to either use threads (instead of helper
1522 processes) or a WaitForMultipleObjects call (instead of select).
1523 Please contact me if you can help with the WaitForMultipleObjects()
1524 approach; I haven't figured out how to get at it without C code.
1525
1526 shutdown pause
1527 There seems to be a pause of up to 1 second between when a child
1528 program exits and the corresponding sockets indicate that they are
1529 closed in the parent. Not sure why.
1530
1531 binmode
1532 binmode is not supported yet. The underpinnings are implemented,
1533 just ask if you need it.
1534
1535 IPC::Run::IO
1536 IPC::Run::IO objects can be used on Unix to read or write arbitrary
1537 files. On Win32, they will need to use the same helper processes to
1538 adapt from non-select()able filehandles to select()able ones (or
1539 perhaps WaitForMultipleObjects() will work with them, not sure).
1540
1541 startup race conditions
1542 There seems to be an occasional race condition between child process
1543 startup and pipe closings. It seems like if the child is not fully
1544 created by the time CreateProcess returns and we close the TCP
1545 socket being handed to it, the parent socket can also get closed.
1546 This is seen with the Win32 pumper applications, not the "real"
1547 child process being spawned.
1548
1549 I assume this is because the kernel hasn't gotten around to
1550 incrementing the reference count on the child's end (since the child
1551 was slow in starting), so the parent's closing of the child end
1552 causes the socket to be closed, thus closing the parent socket.
1553
1554 Being a race condition, it's hard to reproduce, but I encountered it
1555 while testing this code on a drive share to a samba box. In this
1556 case, it takes t/run.t a long time to spawn it's chile processes
1557 (the parent hangs in the first select for several seconds until the
1558 child emits any debugging output).
1559
1560 I have not seen it on local drives, and can't reproduce it at will,
1561 unfortunately. The symptom is a "bad file descriptor in select()"
1562 error, and, by turning on debugging, it's possible to see that
1563 select() is being called on a no longer open file descriptor that
1564 was returned from the _socket() routine in Win32Helper. There's a
1565 new confess() that checks for this ("PARENT_HANDLE no longer open"),
1566 but I haven't been able to reproduce it (typically).
1567
1568 LIMITATIONS
1569 On Unix, requires a system that supports "waitpid( $pid, WNOHANG )" so
1570 it can tell if a child process is still running.
1571
1572 PTYs don't seem to be non-blocking on some versions of Solaris. Here's a
1573 test script contributed by Borislav Deianov <borislav@ensim.com> to see
1574 if you have the problem. If it dies, you have the problem.
1575
1576 #!/usr/bin/perl
1577
1578 use IPC::Run qw(run);
1579 use Fcntl;
1580 use IO::Pty;
1581
1582 sub makecmd {
1583 return ['perl', '-e',
1584 '<STDIN>, print "\n" x '.$_[0].'; while(<STDIN>){last if /end/}'];
1585 }
1586
1587 #pipe R, W;
1588 #fcntl(W, F_SETFL, O_NONBLOCK);
1589 #while (syswrite(W, "\n", 1)) { $pipebuf++ };
1590 #print "pipe buffer size is $pipebuf\n";
1591 my $pipebuf=4096;
1592 my $in = "\n" x ($pipebuf * 2) . "end\n";
1593 my $out;
1594
1595 $SIG{ALRM} = sub { die "Never completed!\n" };
1596
1597 print "reading from scalar via pipe...";
1598 alarm( 2 );
1599 run(makecmd($pipebuf * 2), '<', \$in, '>', \$out);
1600 alarm( 0 );
1601 print "done\n";
1602
1603 print "reading from code via pipe... ";
1604 alarm( 2 );
1605 run(makecmd($pipebuf * 3), '<', sub { $t = $in; undef $in; $t}, '>', \$out);
1606 alarm( 0 );
1607 print "done\n";
1608
1609 $pty = IO::Pty->new();
1610 $pty->blocking(0);
1611 $slave = $pty->slave();
1612 while ($pty->syswrite("\n", 1)) { $ptybuf++ };
1613 print "pty buffer size is $ptybuf\n";
1614 $in = "\n" x ($ptybuf * 3) . "end\n";
1615
1616 print "reading via pty... ";
1617 alarm( 2 );
1618 run(makecmd($ptybuf * 3), '<pty<', \$in, '>', \$out);
1619 alarm(0);
1620 print "done\n";
1621
1622 No support for ';', '&&', '||', '{ ... }', etc: use perl's, since run()
1623 returns TRUE when the command exits with a 0 result code.
1624
1625 Does not provide shell-like string interpolation.
1626
1627 No support for "cd", "setenv", or "export": do these in an init() sub
1628
1629 run(
1630 \cmd,
1631 ...
1632 init => sub {
1633 chdir $dir or die $!;
1634 $ENV{FOO}='BAR'
1635 }
1636 );
1637
1638 Timeout calculation does not allow absolute times, or specification of
1639 days, months, etc.
1640
1641 WARNING: Function coprocesses ("run \&foo, ...") suffer from two
1642 limitations. The first is that it is difficult to close all filehandles
1643 the child inherits from the parent, since there is no way to scan all
1644 open FILEHANDLEs in Perl and it both painful and a bit dangerous to
1645 close all open file descriptors with "POSIX::close()". Painful because
1646 we can't tell which fds are open at the POSIX level, either, so we'd
1647 have to scan all possible fds and close any that we don't want open
1648 (normally "exec()" closes any non-inheritable but we don't "exec()" for
1649 &sub processes.
1650
1651 The second problem is that Perl's DESTROY subs and other on-exit cleanup
1652 gets run in the child process. If objects are instantiated in the parent
1653 before the child is forked, the the DESTROY will get run once in the
1654 parent and once in the child. When coprocess subs exit, POSIX::exit is
1655 called to work around this, but it means that objects that are still
1656 referred to at that time are not cleaned up. So setting package vars or
1657 closure vars to point to objects that rely on DESTROY to affect things
1658 outside the process (files, etc), will lead to bugs.
1659
1660 I goofed on the syntax: "<pipe" vs. "<pty<" and ">filename" are both
1661 oddities.
1662
1663 TODO
1664 Allow one harness to "adopt" another:
1665 $new_h = harness \@cmd2;
1666 $h->adopt( $new_h );
1667
1668 Close all filehandles not explicitly marked to stay open.
1669 The problem with this one is that there's no good way to scan all
1670 open FILEHANDLEs in Perl, yet you don't want child processes
1671 inheriting handles willy-nilly.
1672
1673 INSPIRATION
1674 Well, select() and waitpid() badly needed wrapping, and open3() isn't
1675 open-minded enough for me.
1676
1677 The shell-like API inspired by a message Russ Allbery sent to
1678 perl5-porters, which included:
1679
1680 I've thought for some time that it would be
1681 nice to have a module that could handle full Bourne shell pipe syntax
1682 internally, with fork and exec, without ever invoking a shell. Something
1683 that you could give things like:
1684
1685 pipeopen (PIPE, [ qw/cat file/ ], '|', [ 'analyze', @args ], '>&3');
1686
1687 Message ylln51p2b6.fsf@windlord.stanford.edu, on 2000/02/04.
1688
1689 SUPPORT
1690 Bugs should always be submitted via the CPAN bug tracker
1691
1692 <http://rt.cpan.org/NoAuth/ReportBug.html?Queue=IPC-Run>
1693
1694 For other issues, contact the maintainer (the first listed author)
1695
1696 AUTHORS
1697 Adam Kennedy <adamk@cpan.org>
1698
1699 Barrie Slaymaker <barries@slaysys.com>
1700
1701 COPYRIGHT
1702 Some parts copyright 2008 Adam Kennedy.
1703
1704 Copyright 1999 Barrie Slaymaker.
1705
1706 You may distribute under the terms of either the GNU General Public
1707 License or the Artistic License, as specified in the README file.
1708
+0
-62
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-----
+6
-0
debian/changelog less more
0 libipc-run-perl (0.82-1) UNRELEASED; urgency=low
1
2 * (NOT RELEASED YET) New upstream release
3
4 -- Krzysztof Krzyżaniak (eloy) <eloy@debian.org> Fri, 19 Dec 2008 12:31:27 +0100
5
06 libipc-run-perl (0.80-3) UNRELEASED; urgency=low
17
28 * debian/control: Changed: Switched Vcs-Browser field to ViewSVN
+82
-80
lib/IPC/Run/Debug.pm less more
00 package IPC::Run::Debug;
1
2 =pod
13
24 =head1 NAME
35
5961
6062 =cut
6163
62 @ISA = qw( Exporter ) ;
63
6464 ## We use @EXPORT for the end user's convenience: there's only one function
6565 ## 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 ;
66 ## it can be suppressed by "use IPC::Run ();".
67
68 use strict;
69 use Exporter;
70 use vars qw{$VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS};
71 BEGIN {
72 $VERSION = '0.82';
73 @ISA = qw( Exporter );
74 @EXPORT = qw(
75 _debug
76 _debug_desc_fd
77 _debugging
78 _debugging_data
79 _debugging_details
80 _debugging_gory_details
81 _debugging_not_optimized
82 _set_child_debug_name
83 );
84
85 @EXPORT_OK = qw(
86 _debug_init
87 _debugging_level
88 _map_fds
89 );
90 %EXPORT_TAGS = (
91 default => \@EXPORT,
92 all => [ @EXPORT, @EXPORT_OK ],
93 );
94 }
9395
9496 my $disable_debugging =
9597 defined $ENV{IPCRUNDEBUG}
118120 use UNIVERSAL qw( isa );
119121
120122 sub _map_fds {
121 my $map = '' ;
122 my $digit = 0 ;
123 my $in_use ;
124 my $dummy ;
123 my $map = '';
124 my $digit = 0;
125 my $in_use;
126 my $dummy;
125127 for my $fd (0..63) {
126128 ## I'd like a quicker way (less user, cpu & expecially sys and kernal
127129 ## calls) to detect open file descriptors. Let me know...
128130 ## Hmmm, could do a 0 length read and check for bad file descriptor...
129131 ## 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 ;
132 my $test_fd = POSIX::dup( $fd );
133 $in_use = defined $test_fd;
134 POSIX::close $test_fd if $in_use;
133135 $map .= $in_use ? $digit : '-';
134 $digit = 0 if ++$digit > 9 ;
136 $digit = 0 if ++$digit > 9;
135137 }
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 = $$ ;
138 warn "No fds open???" unless $map =~ /\d/;
139 $map =~ s/(.{1,12})-*$/$1/;
140 return $map;
141 }
142
143 use vars qw( $parent_pid );
144
145 $parent_pid = $$;
144146
145147 ## TODO: move debugging to it's own module and make it compile-time
146148 ## optimizable.
147149
148150 ## Give kid process debugging nice names
149 my $debug_name ;
151 my $debug_name;
150152
151153 sub _set_child_debug_name {
152154 $debug_name = shift;
178180 my $warned;
179181
180182 sub _debugging_level() {
181 my $level = 0 ;
183 my $level = 0;
182184
183185 $level = $IPC::Run::cur_self->{debug} || 0
184186 if $IPC::Run::cur_self
185 && ( $IPC::Run::cur_self->{debug} || 0 ) >= $level ;
187 && ( $IPC::Run::cur_self->{debug} || 0 ) >= $level;
186188
187189 if ( defined $ENV{IPCRUNDEBUG} ) {
188190 my $v = $ENV{IPCRUNDEBUG};
191193 $warned ||= warn "Unknown debug level $ENV{IPCRUNDEBUG}, assuming 'basic' (1)\n";
192194 $v = 1;
193195 }
194 $level = $v if $v > $level ;
196 $level = $v if $v > $level;
195197 }
196 return $level ;
198 return $level;
197199 }
198200
199201 sub _debugging_atleast($) {
200 my $min_level = shift || 1 ;
201
202 my $level = _debugging_level ;
202 my $min_level = shift || 1;
203
204 my $level = _debugging_level;
203205
204 return $level >= $min_level ? $level : 0 ;
206 return $level >= $min_level ? $level : 0;
205207 }
206208
207209 sub _debugging() { _debugging_atleast 1 }
213215 sub _debug_init {
214216 ## This routine is called only in spawned children to fake out the
215217 ## debug routines so they'll emit debugging info.
216 $IPC::Run::cur_self = {} ;
218 $IPC::Run::cur_self = {};
217219 ( $parent_pid,
218220 $^T,
219221 $IPC::Run::cur_self->{debug},
220222 $IPC::Run::cur_self->{DEBUG_FD},
221223 $debug_name
222 ) = @_ ;
224 ) = @_;
223225 }
224226
225227
226228 sub _debug {
227 # return unless _debugging || _debugging_not_optimized ;
229 # return unless _debugging || _debugging_not_optimized;
228230
229231 my $fd = defined &IPC::Run::_debug_fd
230232 ? IPC::Run::_debug_fd()
231233 : fileno STDERR;
232234
233 my $s ;
234 my $debug_id ;
235 my $s;
236 my $debug_id;
235237 $debug_id = join(
236238 " ",
237239 join(
240242 "($$)",
241243 ),
242244 defined $debug_name && length $debug_name ? $debug_name : (),
243 ) ;
245 );
244246 my $prefix = join(
245247 "",
246248 "IPC::Run",
248250 ( _debugging_details ? ( " ", _map_fds ) : () ),
249251 length $debug_id ? ( " [", $debug_id, "]" ) : (),
250252 ": ",
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' ) ;
253 );
254
255 my $msg = join( '', map defined $_ ? $_ : "<undef>", @_ );
256 chomp $msg;
257 $msg =~ s{^}{$prefix}gm;
258 $msg .= "\n";
259 POSIX::write( $fd, $msg, length $msg );
260 }
261
262
263 my @fd_descs = ( 'stdin', 'stdout', 'stderr' );
262264
263265 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" ) ;
266 return unless _debugging;
267 my $text = shift;
268 my $op = pop;
269 my $kid = $_[0];
270
271 Carp::carp join " ", caller(0), $text, $op if defined $op && isa( $op, "IO::Pty" );
270272
271273 _debug(
272274 $text,
294296 )
295297 : ()
296298 ),
297 ) ;
299 );
298300 }
299301
300302 1;
301303
302304 SUBS
303305
306 =pod
307
304308 =head1 AUTHOR
305309
306310 Barrie Slaymaker <barries@slaysys.com>, with numerous suggestions by p5p.
307311
308312 =cut
309
310 1 ;
+209
-208
lib/IPC/Run/IO.pm less more
0 package IPC::Run::IO ;
0 package IPC::Run::IO;
1
2 =pod
13
24 =head1 NAME
35
911 normal file descriptors; IPC::RUN::IO needs to use IPC::Run::Win32Helper
1012 to do this.>
1113
12 use IPC::Run qw( io ) ;
14 use IPC::Run qw( io );
1315
1416 ## The sense of '>' and '<' is opposite of perl's open(),
1517 ## but agrees with IPC::Run.
16 $io = io( "filename", '>', \$recv ) ;
17 $io = io( "filename", 'r', \$recv ) ;
18 $io = io( "filename", '>', \$recv );
19 $io = io( "filename", 'r', \$recv );
1820
1921 ## 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 ) ;
22 $io = io( "filename", '>>', \$recv );
23 $io = io( "filename", 'ra', \$recv );
24
25 $io = io( "filename", '<', \$send );
26 $io = io( "filename", 'w', \$send );
27
28 $io = io( "filename", '<<', \$send );
29 $io = io( "filename", 'wa', \$send );
2830
2931 ## 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( ... ) ;
32 $io = io( \*HANDLE, '<', \$send );
33
34 $f = IO::Handle->new( ... ); # Any subclass of IO::Handle
35 $io = io( $f, '<', \$send );
36
37 require IPC::Run::IO;
38 $io = IPC::Run::IO->new( ... );
3739
3840 ## Then run(), harness(), or start():
39 run $io, ... ;
41 run $io, ...;
4042
4143 ## You can, of course, use io() or IPC::Run::IO->new() as an
4244 ## argument to run(), harness, or start():
43 run io( ... ) ;
44
45 run io( ... );
4546
4647 =head1 DESCRIPTION
4748
6364
6465 Barrie Slaymaker <barries@slaysys.com>
6566
66 =cut ;
67 =cut
6768
6869 ## This class is also used internally by IPC::Run in a very initimate way,
6970 ## since this is a partial factoring of code from IPC::Run plus some code
7071 ## needed to do standalone channels. This factoring process will continue
7172 ## at some point. Don't know how far how fast.
7273
73 use strict ;
74 use Carp ;
75 use Fcntl ;
76 use Symbol ;
77 use UNIVERSAL qw( isa ) ;
74 use strict;
75 use Carp;
76 use Fcntl;
77 use Symbol;
78 use UNIVERSAL ();
7879
7980 use IPC::Run::Debug;
8081 use IPC::Run qw( Win32_MODE );
8182
83 use vars qw{$VERSION};
8284 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
85 $VERSION = '0.82';
86 if ( Win32_MODE ) {
87 eval "use IPC::Run::Win32Helper; require IPC::Run::Win32IO; 1"
88 or ( $@ && die ) or die "$!";
89 }
90 }
91
92 sub _empty($);
93 *_empty = \&IPC::Run::_empty;
9394
9495 sub new {
95 my $class = shift ;
96 $class = ref $class || $class ;
97
98 my ( $external, $type, $internal ) = ( shift, shift, pop ) ;
96 my $class = shift;
97 $class = ref $class || $class;
98
99 my ( $external, $type, $internal ) = ( shift, shift, pop );
99100
100101 croak "$class: '$_' is not a valid I/O operator"
101 unless $type =~ /^(?:<<?|>>?)$/ ;
102 unless $type =~ /^(?:<<?|>>?)$/;
102103
103104 my IPC::Run::IO $self = $class->_new_internal(
104105 $type, undef, undef, $internal, undef, @_
105 ) ;
106 );
106107
107108 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 ;
109 $self->{FILENAME} = $external;
110 }
111 elsif ( ref eq 'GLOB' || UNIVERSAL::isa( $external, 'IO::Handle' ) ) {
112 $self->{HANDLE} = $external;
113 $self->{DONT_CLOSE} = 1;
113114 }
114115 else {
115 croak "$class: cannot accept " . ref( $external ) . " to do I/O with" ;
116 }
117
118 return $self ;
116 croak "$class: cannot accept " . ref( $external ) . " to do I/O with";
117 }
118
119 return $self;
119120 }
120121
121122
122123 ## IPC::Run uses this ctor, since it preparses things and needs more
123124 ## smarts.
124125 sub _new_internal {
125 my $class = shift ;
126 $class = ref $class || $class ;
126 my $class = shift;
127 $class = ref $class || $class;
127128
128129 $class = "IPC::Run::Win32IO"
129130 if Win32_MODE && $class eq "IPC::Run::IO";
130131
131 my IPC::Run::IO $self ;
132 $self = bless {}, $class ;
133
134 my ( $type, $kfd, $pty_id, $internal, $binmode, @filters ) = @_ ;
132 my IPC::Run::IO $self;
133 $self = bless {}, $class;
134
135 my ( $type, $kfd, $pty_id, $internal, $binmode, @filters ) = @_;
135136
136137 # Older perls (<=5.00503, at least) don't do list assign to
137138 # 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 ] ;
139 $self->{TYPE} = $type;
140 $self->{KFD} = $kfd;
141 $self->{PTY_ID} = $pty_id;
142 $self->binmode( $binmode );
143 $self->{FILTERS} = [ @filters ];
143144
144145 ## Add an adapter to the end of the filter chain (which is usually just the
145146 ## read/writer sub pushed by IPC::Run) to the DEST or SOURCE, if need be.
146147 if ( $self->op =~ />/ ) {
147 croak "'$_' missing a destination" if _empty $internal ;
148 $self->{DEST} = $internal ;
149 if ( isa( $self->{DEST}, 'CODE' ) ) {
148 croak "'$_' missing a destination" if _empty $internal;
149 $self->{DEST} = $internal;
150 if ( UNIVERSAL::isa( $self->{DEST}, 'CODE' ) ) {
150151 ## Put a filter on the end of the filter chain to pass the
151152 ## output on to the CODE ref. For SCALAR refs, the last
152153 ## filter in the chain writes directly to the scalar itself. See
155156 unshift(
156157 @{$self->{FILTERS}},
157158 sub {
158 my ( $in_ref ) = @_ ;
159 my ( $in_ref ) = @_;
159160
160161 return IPC::Run::input_avail() && do {
161 $self->{DEST}->( $$in_ref ) ;
162 $$in_ref = '' ;
163 1 ;
162 $self->{DEST}->( $$in_ref );
163 $$in_ref = '';
164 1;
164165 }
165166 }
166 ) ;
167 );
167168 }
168169 }
169170 else {
170 croak "'$_' missing a source" if _empty $internal ;
171 $self->{SOURCE} = $internal ;
172 if ( isa( $internal, 'CODE' ) ) {
171 croak "'$_' missing a source" if _empty $internal;
172 $self->{SOURCE} = $internal;
173 if ( UNIVERSAL::isa( $internal, 'CODE' ) ) {
173174 push(
174175 @{$self->{FILTERS}},
175176 sub {
176 my ( $in_ref, $out_ref ) = @_ ;
177 return 0 if length $$out_ref ;
177 my ( $in_ref, $out_ref ) = @_;
178 return 0 if length $$out_ref;
178179
179180 return undef
180 if $self->{SOURCE_EMPTY} ;
181
182 my $in = $internal->() ;
181 if $self->{SOURCE_EMPTY};
182
183 my $in = $internal->();
183184 unless ( defined $in ) {
184 $self->{SOURCE_EMPTY} = 1 ;
185 $self->{SOURCE_EMPTY} = 1;
185186 return undef
186187 }
187 return 0 unless length $in ;
188 $$out_ref = $in ;
189
190 return 1 ;
188 return 0 unless length $in;
189 $$out_ref = $in;
190
191 return 1;
191192 }
192 ) ;
193 }
194 elsif ( isa( $internal, 'SCALAR' ) ) {
193 );
194 }
195 elsif ( UNIVERSAL::isa( $internal, 'SCALAR' ) ) {
195196 push(
196197 @{$self->{FILTERS}},
197198 sub {
198 my ( $in_ref, $out_ref ) = @_ ;
199 return 0 if length $$out_ref ;
199 my ( $in_ref, $out_ref ) = @_;
200 return 0 if length $$out_ref;
200201
201202 ## pump() clears auto_close_ins, finish() sets it.
202203 return $self->{HARNESS}->{auto_close_ins} ? undef : 0
203204 if IPC::Run::_empty ${$self->{SOURCE}}
204 || $self->{SOURCE_EMPTY} ;
205
206 $$out_ref = $$internal ;
205 || $self->{SOURCE_EMPTY};
206
207 $$out_ref = $$internal;
207208 eval { $$internal = '' }
208 if $self->{HARNESS}->{clear_ins} ;
209
210 $self->{SOURCE_EMPTY} = $self->{HARNESS}->{auto_close_ins} ;
211
212 return 1 ;
209 if $self->{HARNESS}->{clear_ins};
210
211 $self->{SOURCE_EMPTY} = $self->{HARNESS}->{auto_close_ins};
212
213 return 1;
213214 }
214 ) ;
215 }
216 }
217
218 return $self ;
219 }
220
215 );
216 }
217 }
218
219 return $self;
220 }
221221
222222 =item filename
223223
227227 =cut
228228
229229 sub filename {
230 my IPC::Run::IO $self = shift ;
231 $self->{FILENAME} = shift if @_ ;
232 return $self->{FILENAME} ;
233 }
234
230 my IPC::Run::IO $self = shift;
231 $self->{FILENAME} = shift if @_;
232 return $self->{FILENAME};
233 }
235234
236235 =item init
237236
241240 =cut
242241
243242 sub init {
244 my IPC::Run::IO $self = shift ;
245
246 $self->{SOURCE_EMPTY} = 0 ;
243 my IPC::Run::IO $self = shift;
244
245 $self->{SOURCE_EMPTY} = 0;
247246 ${$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 ;
247 if $self->mode =~ /r/ && ref $self->{DEST} eq 'SCALAR';
248
249 $self->open if defined $self->filename;
250 $self->{FD} = $self->fileno;
252251
253252 if ( ! $self->{FILTERS} ) {
254 $self->{FBUFS} = undef ;
253 $self->{FBUFS} = undef;
255254 }
256255 else {
257256 @{$self->{FBUFS}} = map {
258 my $s = "" ;
259 \$s ;
260 } ( @{$self->{FILTERS}}, '' ) ;
257 my $s = "";
258 \$s;
259 } ( @{$self->{FILTERS}}, '' );
261260
262261 $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 ;
262 if $self->{DEST} && ref $self->{DEST} eq 'SCALAR';
263 push @{$self->{FBUFS}}, $self->{SOURCE};
264 }
265
266 return undef;
268267 }
269268
270269
280279 '>>' => O_RDONLY,
281280 '<' => O_WRONLY | O_CREAT | O_TRUNC,
282281 '<<' => O_WRONLY | O_CREAT | O_APPEND,
283 ) ;
282 );
284283
285284 sub open {
286 my IPC::Run::IO $self = shift ;
285 my IPC::Run::IO $self = shift;
287286
288287 croak "IPC::Run::IO: Can't open() a file with no name"
289 unless defined $self->{FILENAME} ;
290 $self->{HANDLE} = gensym unless $self->{HANDLE} ;
288 unless defined $self->{FILENAME};
289 $self->{HANDLE} = gensym unless $self->{HANDLE};
291290
292291 _debug
293292 "opening '", $self->filename, "' mode '", $self->mode, "'"
294 if _debugging_data ;
293 if _debugging_data;
295294 sysopen(
296295 $self->{HANDLE},
297296 $self->filename,
298297 $open_flags{$self->op},
299298 ) or croak
300 "IPC::Run::IO: $! opening '$self->{FILENAME}', mode '" . $self->mode . "'" ;
301
302 return undef ;
299 "IPC::Run::IO: $! opening '$self->{FILENAME}', mode '" . $self->mode . "'";
300
301 return undef;
303302 }
304303
305304
312311
313312 sub _do_open {
314313 my $self = shift;
315 my ( $child_debug_fd, $parent_handle ) = @_ ;
314 my ( $child_debug_fd, $parent_handle ) = @_;
316315
317316
318317 if ( $self->dir eq "<" ) {
319 ( $self->{TFD}, $self->{FD} ) = IPC::Run::_pipe_nb ;
318 ( $self->{TFD}, $self->{FD} ) = IPC::Run::_pipe_nb;
320319 if ( $parent_handle ) {
321320 CORE::open $parent_handle, ">&=$self->{FD}"
322 or croak "$! duping write end of pipe for caller" ;
321 or croak "$! duping write end of pipe for caller";
323322 }
324323 }
325324 else {
326 ( $self->{FD}, $self->{TFD} ) = IPC::Run::_pipe ;
325 ( $self->{FD}, $self->{TFD} ) = IPC::Run::_pipe;
327326 if ( $parent_handle ) {
328327 CORE::open $parent_handle, "<&=$self->{FD}"
329 or croak "$! duping read end of pipe for caller" ;
328 or croak "$! duping read end of pipe for caller";
330329 }
331330 }
332331 }
333332
334333 sub open_pipe {
335 my IPC::Run::IO $self = shift ;
334 my IPC::Run::IO $self = shift;
336335
337336 ## Hmmm, Maybe allow named pipes one day. But until then...
338337 croak "IPC::Run::IO: Can't pipe() when a file name has been set"
339 if defined $self->{FILENAME} ;
338 if defined $self->{FILENAME};
340339
341340 $self->_do_open( @_ );
342341
343342 ## return ( child_fd, parent_fd )
344343 return $self->dir eq "<"
345344 ? ( $self->{TFD}, $self->{FD} )
346 : ( $self->{FD}, $self->{TFD} ) ;
345 : ( $self->{FD}, $self->{TFD} );
347346 }
348347
349348
361360 =cut
362361
363362 sub close {
364 my IPC::Run::IO $self = shift ;
363 my IPC::Run::IO $self = shift;
365364
366365 if ( defined $self->{HANDLE} ) {
367366 close $self->{HANDLE}
370369 ? "'$self->{FILENAME}'"
371370 : "handle"
372371 )
373 ) ;
372 );
374373 }
375374 else {
376 IPC::Run::_close( $self->{FD} ) ;
377 }
378
379 $self->{FD} = undef ;
380
381 return undef ;
375 IPC::Run::_close( $self->{FD} );
376 }
377
378 $self->{FD} = undef;
379
380 return undef;
382381 }
383382
384383 =item fileno
389388 =cut
390389
391390 sub fileno {
392 my IPC::Run::IO $self = shift ;
393
394 my $fd = fileno $self->{HANDLE} ;
391 my IPC::Run::IO $self = shift;
392
393 my $fd = fileno $self->{HANDLE};
395394 croak( "IPC::Run::IO: $! "
396395 . ( defined $self->{FILENAME}
397396 ? "'$self->{FILENAME}'"
398397 : "handle"
399398 )
400 ) unless defined $fd ;
401
402 return $fd ;
403 }
399 ) unless defined $fd;
400
401 return $fd;
402 }
403
404 =pod
404405
405406 =item mode
406407
423424 =cut
424425
425426 sub mode {
426 my IPC::Run::IO $self = shift ;
427
428 croak "IPC::Run::IO: unexpected arguments for mode(): @_" if @_ ;
427 my IPC::Run::IO $self = shift;
428
429 croak "IPC::Run::IO: unexpected arguments for mode(): @_" if @_;
429430
430431 ## TODO: Optimize this
431432 return ( $self->{TYPE} =~ /</ ? 'w' : 'r' ) .
432 ( $self->{TYPE} =~ /<<|>>/ ? 'a' : '' ) ;
433 ( $self->{TYPE} =~ /<<|>>/ ? 'a' : '' );
433434 }
434435
435436
441442 =cut
442443
443444 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} ;
445 my IPC::Run::IO $self = shift;
446
447 croak "IPC::Run::IO: unexpected arguments for op(): @_" if @_;
448
449 return $self->{TYPE};
449450 }
450451
451452 =item binmode
456457 =cut
457458
458459 sub binmode {
459 my IPC::Run::IO $self = shift ;
460
461 $self->{BINMODE} = shift if @_ ;
462
463 return $self->{BINMODE} ;
460 my IPC::Run::IO $self = shift;
461
462 $self->{BINMODE} = shift if @_;
463
464 return $self->{BINMODE};
464465 }
465466
466467
471472 =cut
472473
473474 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 ;
475 my IPC::Run::IO $self = shift;
476
477 croak "IPC::Run::IO: unexpected arguments for dir(): @_" if @_;
478
479 return substr $self->{TYPE}, 0, 1;
479480 }
480481
481482
482483 ##
483484 ## Filter Scaffolding
484485 ##
485 #my $filter_op ; ## The op running a filter chain right now
486 #my $filter_num ; ## Which filter is being run right now.
486 #my $filter_op ; ## The op running a filter chain right now
487 #my $filter_num; ## Which filter is being run right now.
487488
488489 use vars (
489490 '$filter_op', ## The op running a filter chain right now
490491 '$filter_num' ## Which filter is being run right now.
491 ) ;
492 );
492493
493494 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} = [] ;
495 my IPC::Run::IO $self = shift;
496
497 confess "\$self not an IPC::Run::IO" unless UNIVERSAL::isa( $self, "IPC::Run::IO" );
498 $self->{FBUFS} = [];
498499
499500 $self->{FBUFS}->[0] = $self->{DEST}
500 if $self->{DEST} && ref $self->{DEST} eq 'SCALAR' ;
501
502 return unless $self->{FILTERS} && @{$self->{FILTERS}} ;
501 if $self->{DEST} && ref $self->{DEST} eq 'SCALAR';
502
503 return unless $self->{FILTERS} && @{$self->{FILTERS}};
503504
504505 push @{$self->{FBUFS}}, map {
505 my $s = "" ;
506 \$s ;
507 } ( @{$self->{FILTERS}}, '' ) ;
508
509 push @{$self->{FBUFS}}, $self->{SOURCE} ;
506 my $s = "";
507 \$s;
508 } ( @{$self->{FILTERS}}, '' );
509
510 push @{$self->{FBUFS}}, $self->{SOURCE};
510511 }
511512
512513
519520 if ( $d eq "<" ) {
520521 if ( vec $harness->{WOUT}, $self->{FD}, 1 ) {
521522 _debug_desc_fd( "filtering data to", $self )
522 if _debugging_details ;
523 if _debugging_details;
523524 return $self->_do_filters( $harness );
524525 }
525526 }
526527 elsif ( $d eq ">" ) {
527528 if ( vec $harness->{ROUT}, $self->{FD}, 1 ) {
528529 _debug_desc_fd( "filtering data from", $self )
529 if _debugging_details ;
530 if _debugging_details;
530531 return $self->_do_filters( $harness );
531532 }
532533 }
536537
537538
538539 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 ;
540 my IPC::Run::IO $self = shift;
541
542 ( $self->{HARNESS} ) = @_;
543
544 my ( $saved_op, $saved_num ) =($IPC::Run::filter_op,$IPC::Run::filter_num);
545 $IPC::Run::filter_op = $self;
546 $IPC::Run::filter_num = -1;
546547 my $c = 0;
547548 my $r;
548549 {
549550 $@ = '';
550 $r = eval { IPC::Run::get_more_input() ; } ;
551 $r = eval { IPC::Run::get_more_input(); };
551552 $c++;
552553 ##$@ and warn "redo ", substr($@, 0, 20) , " ";
553554 (($c < 200) and ($@||'')=~ m/^Resource temporarily/) and redo;
554555 }
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 ;
556 ( $IPC::Run::filter_op, $IPC::Run::filter_num ) = ( $saved_op, $saved_num );
557 $self->{HARNESS} = undef;
558 die "ack ", $@ if $@;
559 return $r;
560 }
561
562 1;
+224
-224
lib/IPC/Run/Timer.pm less more
0 package IPC::Run::Timer ;
0 package IPC::Run::Timer;
1
2 =pod
13
24 =head1 NAME
35
57
68 =head1 SYNOPSIS
79
8 use IPC::Run qw( run timer timeout ) ;
9 ## or IPC::Run::Timer ( timer timeout ) ;
10 ## or IPC::Run::Timer ( :all ) ;
10 use IPC::Run qw( run timer timeout );
11 ## or IPC::Run::Timer ( timer timeout );
12 ## or IPC::Run::Timer ( :all );
1113
1214 ## A non-fatal timer:
13 $t = timer( 5 ) ; # or...
14 $t = IO::Run::Timer->new( 5 ) ;
15 run $t, ... ;
15 $t = timer( 5 ); # or...
16 $t = IO::Run::Timer->new( 5 );
17 run $t, ...;
1618
1719 ## 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 $t = timeout( 5 ); # or...
21 $t = IO::Run::Timer->new( 5, exception => "harness timed out" );
2022
2123 =head1 DESCRIPTION
2224
2830 exception on expiration so you don't need to check them:
2931
3032 ## Give @cmd 10 seconds to get started, then 5 seconds to respond
31 my $t = timeout( 10 ) ;
33 my $t = timeout( 10 );
3234 $h = start(
3335 \@cmd, \$in, \$out,
3436 $t,
35 ) ;
36 pump $h until $out =~ /prompt/ ;
37
38 $in = "some stimulus" ;
39 $out = '' ;
37 );
38 pump $h until $out =~ /prompt/;
39
40 $in = "some stimulus";
41 $out = '';
4042 $t->time( 5 )
41 pump $h until $out =~ /expected response/ ;
43 pump $h until $out =~ /expected response/;
4244
4345 You do need to check timers:
4446
4547 ## Give @cmd 10 seconds to get started, then 5 seconds to respond
46 my $t = timer( 10 ) ;
48 my $t = timer( 10 );
4749 $h = start(
4850 \@cmd, \$in, \$out,
4951 $t,
50 ) ;
51 pump $h until $t->is_expired || $out =~ /prompt/ ;
52
53 $in = "some stimulus" ;
54 $out = '' ;
52 );
53 pump $h until $t->is_expired || $out =~ /prompt/;
54
55 $in = "some stimulus";
56 $out = '';
5557 $t->time( 5 )
56 pump $h until $out =~ /expected response/ || $t->is_expired ;
58 pump $h until $out =~ /expected response/ || $t->is_expired;
5759
5860 Timers and timeouts that are reset get started by start() and
5961 pump(). Timers change state only in pump(). Since run() and
151153
152154 =over
153155
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 ;
156 =cut
157
158 use strict;
159 use Carp;
160 use Fcntl;
161 use Symbol;
162 use Exporter;
163 use vars qw( $VERSION @ISA @EXPORT_OK %EXPORT_TAGS );
164 BEGIN {
165 $VERSION = '0.82';
166 @ISA = qw( Exporter );
167 @EXPORT_OK = qw(
168 check
169 end_time
170 exception
171 expire
172 interval
173 is_expired
174 is_reset
175 is_running
176 name
177 reset
178 start
179 timeout
180 timer
181 );
182
183 %EXPORT_TAGS = ( 'all' => \@EXPORT_OK );
184 }
185
186 require IPC::Run;
187 use IPC::Run::Debug;
187188
188189 ##
189190 ## Some helpers
190191 ##
191 my $resolution = 1 ;
192 my $resolution = 1;
192193
193194 sub _parse_time {
194195 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 ;
196 return $_ unless defined $_;
197 return $_ if /^\d*(?:\.\d*)?$/;
198
199 my @f = reverse split( /[^\d\.]+/i );
200 croak "IPC::Run: invalid time string '$_'" unless @f <= 4;
201 my ( $s, $m, $h, $d ) = @f;
201202 return
202203 ( (
203204 ( $d || 0 ) * 24
204205 + ( $h || 0 ) ) * 60
205206 + ( $m || 0 ) ) * 60
206 + ( $s || 0 ) ;
207 }
208 }
209
207 + ( $s || 0 );
208 }
209 }
210210
211211 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 ) ;
212 my IPC::Run::Timer $self = shift;
213 my $interval = $self->interval;
214 $interval += $resolution if $interval;
215 $self->end_time( $self->start_time + $interval );
218216 }
219217
220218
222220
223221 A constructor function (not method) of IPC::Run::Timer instances:
224222
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 ) ;
223 $t = timer( 5 );
224 $t = timer( 5, name => 'stall timer', debug => 1 );
225
226 $t = timer;
227 $t->interval( 5 );
228
229 run ..., $t;
230 run ..., $t = timer( 5 );
233231
234232 This convenience function is a shortened spelling of
235233
236 IPC::Run::Timer->new( ... ) ;
234 IPC::Run::Timer->new( ... );
237235
238236 . It returns a timer in the reset state with a given interval.
239237
245243 =cut
246244
247245 sub timer {
248 return IPC::Run::Timer->new( @_ ) ;
246 return IPC::Run::Timer->new( @_ );
249247 }
250248
251249
253251
254252 A constructor function (not method) of IPC::Run::Timer instances:
255253
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 ) ;
254 $t = timeout( 5 );
255 $t = timeout( 5, exception => "kablooey" );
256 $t = timeout( 5, name => "stall", exception => "kablooey" );
257
258 $t = timeout;
259 $t->interval( 5 );
260
261 run ..., $t;
262 run ..., $t = timeout( 5 );
265263
266264 A This convenience function is a shortened spelling of
267265
268 IPC::Run::Timer->new( exception => "IPC::Run: timeout ...", ... ) ;
266 IPC::Run::Timer->new( exception => "IPC::Run: timeout ...", ... );
269267
270268 . It returns a timer in the reset state that will throw an
271269 exception when it expires.
276274 =cut
277275
278276 sub timeout {
279 my $t = IPC::Run::Timer->new( @_ ) ;
277 my $t = IPC::Run::Timer->new( @_ );
280278 $t->exception( "IPC::Run: timeout on " . $t->name )
281 unless defined $t->exception ;
282 return $t ;
279 unless defined $t->exception;
280 return $t;
283281 }
284282
285283
286284 =item new
287285
288 IPC::Run::Timer->new() ;
289 IPC::Run::Timer->new( 5 ) ;
290 IPC::Run::Timer->new( 5, exception => 'kablooey' ) ;
286 IPC::Run::Timer->new() ;
287 IPC::Run::Timer->new( 5 ) ;
288 IPC::Run::Timer->new( 5, exception => 'kablooey' ) ;
291289
292290 Constructor. See L</timer> for details.
293291
294292 =cut
295293
296 my $timer_counter ;
294 my $timer_counter;
297295
298296
299297 sub new {
300 my $class = shift ;
301 $class = ref $class || $class ;
298 my $class = shift;
299 $class = ref $class || $class;
302300
303301 my IPC::Run::Timer $self = bless {}, $class;
304302
305 $self->{STATE} = 0 ;
306 $self->{DEBUG} = 0 ;
307 $self->{NAME} = "timer #" . ++$timer_counter ;
303 $self->{STATE} = 0;
304 $self->{DEBUG} = 0;
305 $self->{NAME} = "timer #" . ++$timer_counter;
308306
309307 while ( @_ ) {
310 my $arg = shift ;
308 my $arg = shift;
311309 if ( $arg =~ /^(?:\d+[^\a\d]){0,3}\d*(?:\.\d*)?$/ ) {
312 $self->interval( $arg ) ;
310 $self->interval( $arg );
313311 }
314312 elsif ( $arg eq 'exception' ) {
315 $self->exception( shift ) ;
313 $self->exception( shift );
316314 }
317315 elsif ( $arg eq 'name' ) {
318 $self->name( shift ) ;
316 $self->name( shift );
319317 }
320318 elsif ( $arg eq 'debug' ) {
321 $self->debug( shift ) ;
319 $self->debug( shift );
322320 }
323321 else {
324 croak "IPC::Run: unexpected parameter '$arg'" ;
322 croak "IPC::Run: unexpected parameter '$arg'";
325323 }
326324 }
327325
328326 _debug $self->name . ' constructed'
329 if $self->{DEBUG} || _debugging_details ;
330
331 return $self ;
327 if $self->{DEBUG} || _debugging_details;
328
329 return $self;
332330 }
333331
334332 =item check
335333
336 check $t ;
337 check $t, $now ;
338 $t->check ;
334 check $t;
335 check $t, $now;
336 $t->check;
339337
340338 Checks to see if a timer has expired since the last check. Has no effect
341339 on non-running timers. This will throw an exception if one is defined.
357355 =cut
358356
359357 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 ;
358 my IPC::Run::Timer $self = shift;
359 return undef if ! $self->is_running;
360 return 0 if $self->is_expired;
361
362 my ( $now ) = @_;
363 $now = _parse_time( $now );
364 $now = time unless defined $now;
367365
368366 _debug(
369367 "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 ;
368 ) if $self->{DEBUG} || _debugging_details;
369
370 my $left = $self->end_time - $now;
371 return $left if $left > 0;
372
373 $self->expire;
374 return 0;
377375 }
378376
379377
386384
387385
388386 sub debug {
389 my IPC::Run::Timer $self = shift ;
390 $self->{DEBUG} = shift if @_ ;
391 return $self->{DEBUG} ;
387 my IPC::Run::Timer $self = shift;
388 $self->{DEBUG} = shift if @_;
389 return $self->{DEBUG};
392390 }
393391
394392
395393 =item end_time
396394
397 $et = $t->end_time ;
398 $et = end_time $t ;
399
400 $t->end_time( time + 10 ) ;
395 $et = $t->end_time;
396 $et = end_time $t;
397
398 $t->end_time( time + 10 );
401399
402400 Returns the time when this timer will or did expire. Even if this time is
403401 in the past, the timer may not be expired, since check() may not have been
415413
416414
417415 sub end_time {
418 my IPC::Run::Timer $self = shift ;
416 my IPC::Run::Timer $self = shift;
419417 if ( @_ ) {
420 $self->{END_TIME} = shift ;
418 $self->{END_TIME} = shift;
421419 _debug $self->name, ' end_time set to ', $self->{END_TIME}
422 if $self->{DEBUG} > 2 || _debugging_details ;
423 }
424 return $self->{END_TIME} ;
420 if $self->{DEBUG} > 2 || _debugging_details;
421 }
422 return $self->{END_TIME};
425423 }
426424
427425
428426 =item exception
429427
430 $x = $t->exception ;
431 $t->exception( $x ) ;
432 $t->exception( undef ) ;
428 $x = $t->exception;
429 $t->exception( $x );
430 $t->exception( undef );
433431
434432 Sets/gets the exception to throw, if any. 'undef' means that no
435433 exception will be thrown. Exception does not need to be a scalar: you
439437
440438
441439 sub exception {
442 my IPC::Run::Timer $self = shift ;
440 my IPC::Run::Timer $self = shift;
443441 if ( @_ ) {
444 $self->{EXCEPTION} = shift ;
442 $self->{EXCEPTION} = shift;
445443 _debug $self->name, ' exception set to ', $self->{EXCEPTION}
446 if $self->{DEBUG} || _debugging_details ;
447 }
448 return $self->{EXCEPTION} ;
444 if $self->{DEBUG} || _debugging_details;
445 }
446 return $self->{EXCEPTION};
449447 }
450448
451449
452450 =item interval
453451
454 $i = interval $t ;
455 $i = $t->interval ;
456 $t->interval( $i ) ;
452 $i = interval $t;
453 $i = $t->interval;
454 $t->interval( $i );
457455
458456 Sets the interval. Sets the end time based on the start_time() and the
459457 interval (and a little fudge) if the timer is running.
461459 =cut
462460
463461 sub interval {
464 my IPC::Run::Timer $self = shift ;
462 my IPC::Run::Timer $self = shift;
465463 if ( @_ ) {
466 $self->{INTERVAL} = _parse_time( shift ) ;
464 $self->{INTERVAL} = _parse_time( shift );
467465 _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} ;
466 if $self->{DEBUG} > 2 || _debugging_details;
467
468 $self->_calc_end_time if $self->state;
469 }
470 return $self->{INTERVAL};
473471 }
474472
475473
476474 =item expire
477475
478 expire $t ;
479 $t->expire ;
476 expire $t;
477 $t->expire;
480478
481479 Sets the state to expired (undef).
482480 Will throw an exception if one
487485
488486
489487 sub expire {
490 my IPC::Run::Timer $self = shift ;
488 my IPC::Run::Timer $self = shift;
491489 if ( defined $self->state ) {
492490 _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 ;
491 if $self->{DEBUG} || _debugging;
492
493 $self->state( undef );
494 croak $self->exception if $self->exception;
495 }
496 return undef;
499497 }
500498
501499
505503
506504
507505 sub is_running {
508 my IPC::Run::Timer $self = shift ;
509 return $self->state ? 1 : 0 ;
506 my IPC::Run::Timer $self = shift;
507 return $self->state ? 1 : 0;
510508 }
511509
512510
515513 =cut
516514
517515 sub is_reset {
518 my IPC::Run::Timer $self = shift ;
519 return defined $self->state && $self->state == 0 ;
516 my IPC::Run::Timer $self = shift;
517 return defined $self->state && $self->state == 0;
520518 }
521519
522520
525523 =cut
526524
527525 sub is_expired {
528 my IPC::Run::Timer $self = shift ;
529 return ! defined $self->state ;
526 my IPC::Run::Timer $self = shift;
527 return ! defined $self->state;
530528 }
531529
532530 =item name
537535 =cut
538536
539537 sub name {
540 my IPC::Run::Timer $self = shift ;
538 my IPC::Run::Timer $self = shift;
541539
542 $self->{NAME} = shift if @_ ;
540 $self->{NAME} = shift if @_;
543541 return defined $self->{NAME}
544542 ? $self->{NAME}
545543 : defined $self->{EXCEPTION}
546544 ? 'timeout'
547 : 'timer' ;
545 : 'timer';
548546 }
549547
550548
551549 =item reset
552550
553 reset $t ;
554 $t->reset ;
551 reset $t;
552 $t->reset;
555553
556554 Resets the timer to the non-running, non-expired state and clears
557555 the end_time().
559557 =cut
560558
561559 sub reset {
562 my IPC::Run::Timer $self = shift ;
563 $self->state( 0 ) ;
564 $self->end_time( undef ) ;
560 my IPC::Run::Timer $self = shift;
561 $self->state( 0 );
562 $self->end_time( undef );
565563 _debug $self->name . ' reset'
566 if $self->{DEBUG} || _debugging ;
567
568 return undef ;
564 if $self->{DEBUG} || _debugging;
565
566 return undef;
569567 }
570568
571569
572570 =item start
573571
574 start $t ;
575 $t->start ;
576 start $t, $interval ;
577 start $t, $interval, $now ;
572 start $t;
573 $t->start;
574 start $t, $interval;
575 start $t, $interval, $now;
578576
579577 Starts or restarts a timer. This always sets the start_time. It sets the
580578 end_time based on the interval if the timer is running or if no end time
596594 =cut
597595
598596 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 ;
597 my IPC::Run::Timer $self = shift;
598
599 my ( $interval, $now ) = map { _parse_time( $_ ) } @_;
600 $now = _parse_time( $now );
601 $now = time unless defined $now;
602
603 $self->interval( $interval ) if defined $interval;
606604
607605 ## start()ing a running or expired timer clears the end_time, so that the
608606 ## interval is used. So does specifying an interval.
609 $self->end_time( undef ) if ! $self->is_reset || $interval ;
607 $self->end_time( undef ) if ! $self->is_reset || $interval;
610608
611609 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 ) ;
610 unless defined $self->interval || defined $self->end_time;
611
612 $self->state( 1 );
613 $self->start_time( $now );
616614 ## The "+ 1" is in case the START_TIME was sampled at the end of a
617615 ## tick (which are one second long in this module).
618616 $self->_calc_end_time
619 unless defined $self->end_time ;
617 unless defined $self->end_time;
620618
621619 _debug(
622620 $self->name, " started at ", $self->start_time,
623621 ", with interval ", $self->interval, ", end_time ", $self->end_time
624 ) if $self->{DEBUG} || _debugging ;
625 return undef ;
622 ) if $self->{DEBUG} || _debugging;
623 return undef;
626624 }
627625
628626
635633
636634
637635 sub start_time {
638 my IPC::Run::Timer $self = shift ;
636 my IPC::Run::Timer $self = shift;
639637 if ( @_ ) {
640 $self->{START_TIME} = _parse_time( shift ) ;
638 $self->{START_TIME} = _parse_time( shift );
641639 _debug $self->name, ' start_time set to ', $self->{START_TIME}
642 if $self->{DEBUG} > 2 || _debugging ;
643 }
644
645 return $self->{START_TIME} ;
640 if $self->{DEBUG} > 2 || _debugging;
641 }
642
643 return $self->{START_TIME};
646644 }
647645
648646
649647 =item state
650648
651 $s = state $t ;
652 $t->state( $s ) ;
649 $s = state $t;
650 $t->state( $s );
653651
654652 Get/Set the current state. Only use this if you really need to transfer the
655653 state to/from some variable.
662660 =cut
663661
664662 sub state {
665 my IPC::Run::Timer $self = shift ;
663 my IPC::Run::Timer $self = shift;
666664 if ( @_ ) {
667 $self->{STATE} = shift ;
665 $self->{STATE} = shift;
668666 _debug $self->name, ' state set to ', $self->{STATE}
669 if $self->{DEBUG} > 2 || _debugging ;
670 }
671 return $self->{STATE} ;
672 }
673
667 if $self->{DEBUG} > 2 || _debugging;
668 }
669 return $self->{STATE};
670 }
671
672
673 1;
674
675 =pod
674676
675677 =head1 TODO
676678
677 use Time::HiRes ; if it's present.
679 use Time::HiRes; if it's present.
678680
679681 Add detection and parsing of [[[HH:]MM:]SS formatted times and intervals.
680682
683685 Barrie Slaymaker <barries@slaysys.com>
684686
685687 =cut
686
687 1 ;
+98
-90
lib/IPC/Run/Win32Helper.pm less more
0 package IPC::Run::Win32Helper ;
0 package IPC::Run::Win32Helper;
1
2 =pod
13
24 =head1 NAME
35
1618
1719 =cut
1820
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 ;
21 use strict;
22 use Carp;
23 use IO::Handle;
24 use vars qw{ $VERSION @ISA @EXPORT };
25 BEGIN {
26 $VERSION = '0.82';
27 @ISA = qw( Exporter );
28 @EXPORT = qw(
29 win32_spawn
30 win32_parse_cmd_line
31 _dont_inherit
32 _inherit
33 );
34 }
35
36 require POSIX;
37
38 use Text::ParseWords;
39 use Win32::Process;
3640 use IPC::Run::Debug;
37 ## REMOVE OSFHandleOpen
3841 use Win32API::File qw(
3942 FdGetOsFHandle
4043 SetHandleInformation
4144 HANDLE_FLAG_INHERIT
4245 INVALID_HANDLE_VALUE
43 ) ;
46 );
4447
4548 ## Takes an fd or a GLOB ref, never never never a Win32 handle.
4649 sub _dont_inherit {
4750 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 ) ;
51 next unless defined $_;
52 my $fd = $_;
53 $fd = fileno $fd if ref $fd;
54 _debug "disabling inheritance of ", $fd if _debugging_details;
55 my $osfh = FdGetOsFHandle $fd;
56 croak $^E if ! defined $osfh || $osfh == INVALID_HANDLE_VALUE;
57
58 SetHandleInformation( $osfh, HANDLE_FLAG_INHERIT, 0 );
5659 }
5760 }
5861
5962 sub _inherit { #### REMOVE
6063 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
64 next unless defined $_; #### REMOVE
65 my $fd = $_; #### REMOVE
66 $fd = fileno $fd if ref $fd; #### REMOVE
67 _debug "enabling inheritance of ", $fd if _debugging_details; #### REMOVE
68 my $osfh = FdGetOsFHandle $fd; #### REMOVE
69 croak $^E if ! defined $osfh || $osfh == INVALID_HANDLE_VALUE; #### REMOVE
6770 #### REMOVE
68 SetHandleInformation( $osfh, HANDLE_FLAG_INHERIT, 1 ) ; #### REMOVE
71 SetHandleInformation( $osfh, HANDLE_FLAG_INHERIT, 1 ); #### REMOVE
6972 } #### REMOVE
7073 } #### REMOVE
7174 #### REMOVE
7275 #sub _inherit {
7376 # 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 ) ;
77 # next unless defined $_;
78 # my $osfh = GetOsFHandle $_;
79 # croak $^E if ! defined $osfh || $osfh == INVALID_HANDLE_VALUE;
80 # SetHandleInformation( $osfh, HANDLE_FLAG_INHERIT, HANDLE_FLAG_INHERIT );
7881 # }
7982 #}
8083
84 =pod
85
8186 =head1 FUNCTIONS
8287
8388 =over
84
85 =cut
8689
8790 =item optimize()
8891
308311
309312 }
310313
314 =pod
315
311316 =item win32_parse_cmd_line
312317
313 @words = win32_parse_cmd_line( q{foo bar 'baz baz' "bat bat"} ) ;
318 @words = win32_parse_cmd_line( q{foo bar 'baz baz' "bat bat"} );
314319
315320 returns 4 words. This parses like the bourne shell (see
316321 the bit about shellwords() in L<Text::ParseWords>), assuming we're
330335 =cut
331336
332337 sub win32_parse_cmd_line {
333 my $line = shift ;
334 $line =~ s{(\\[\w\s])}{\\$1}g ;
335 return shellwords $line ;
336 }
337
338 my $line = shift;
339 $line =~ s{(\\[\w\s])}{\\$1}g;
340 return shellwords $line;
341 }
342
343 =pod
338344
339345 =item win32_spawn
340346
358364 =cut
359365
360366 sub _save {
361 my ( $saved, $saved_as, $fd ) = @_ ;
367 my ( $saved, $saved_as, $fd ) = @_;
362368
363369 ## 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} ;
370 return if exists $saved->{$fd};
371
372 my $saved_fd = IPC::Run::_dup( $fd );
373 _dont_inherit $saved_fd;
374
375 $saved->{$fd} = $saved_fd;
376 $saved_as->{$saved_fd} = $fd;
377
378 _dont_inherit $saved->{$fd};
373379 }
374380
375381 sub _dup2_gently {
376 my ( $saved, $saved_as, $fd1, $fd2 ) = @_ ;
377 _save $saved, $saved_as, $fd2 ;
382 my ( $saved, $saved_as, $fd1, $fd2 ) = @_;
383 _save $saved, $saved_as, $fd2;
378384
379385 if ( exists $saved_as->{$fd2} ) {
380386 ## The target fd is colliding with a saved-as fd, gotta bump
381387 ## 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 my $orig_fd = delete $saved_as->{$fd2};
389 my $saved_fd = IPC::Run::_dup( $fd2 );
390 _dont_inherit $saved_fd;
391
392 $saved->{$orig_fd} = $saved_fd;
393 $saved_as->{$saved_fd} = $orig_fd;
388394 }
389 _debug "moving $fd1 to kid's $fd2" if _debugging_details ;
390 IPC::Run::_dup2_rudely( $fd1, $fd2 ) ;
395 _debug "moving $fd1 to kid's $fd2" if _debugging_details;
396 IPC::Run::_dup2_rudely( $fd1, $fd2 );
391397 }
392398
393399 sub win32_spawn {
394 my ( $cmd, $ops) = @_ ;
400 my ( $cmd, $ops) = @_;
395401
396402 ## NOTE: The debug pipe write handle is passed to pump processes as STDOUT.
397403 ## and is not to the "real" child process, since they would not know
398404 ## what to do with it...unlike Unix, we have no code executing in the
399405 ## child before the "real" child is exec()ed.
400406
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
407 my %saved; ## Map of parent's orig fd -> saved fd
408 my %saved_as; ## Map of parent's saved fd -> orig fd, used to
403409 ## detect collisions between a KFD and the fd a
404410 ## parent's fd happened to be saved to.
405411
406412 for my $op ( @$ops ) {
407 _dont_inherit $op->{FD} if defined $op->{FD} ;
413 _dont_inherit $op->{FD} if defined $op->{FD};
408414
409415 if ( defined $op->{KFD} && $op->{KFD} > 2 ) {
410416 ## TODO: Detect this in harness()
411417 ## TODO: enable temporary redirections if ever necessary, not
412418 ## sure why they would be...
413419 ## 4>&1 1>/dev/null 1>&4 4>&-
414 croak "Can't redirect fd #", $op->{KFD}, " on Win32" ;
420 croak "Can't redirect fd #", $op->{KFD}, " on Win32";
415421 }
416422
417423 ## This is very similar logic to IPC::Run::_do_kid_and_exit().
418424 if ( defined $op->{TFD} ) {
419425 unless ( $op->{TFD} == $op->{KFD} ) {
420 _dup2_gently \%saved, \%saved_as, $op->{TFD}, $op->{KFD} ;
421 _dont_inherit $op->{TFD} ;
426 _dup2_gently \%saved, \%saved_as, $op->{TFD}, $op->{KFD};
427 _dont_inherit $op->{TFD};
422428 }
423429 }
424430 elsif ( $op->{TYPE} eq "dup" ) {
425431 _dup2_gently \%saved, \%saved_as, $op->{KFD1}, $op->{KFD2}
426 unless $op->{KFD1} == $op->{KFD2} ;
432 unless $op->{KFD1} == $op->{KFD2};
427433 }
428434 elsif ( $op->{TYPE} eq "close" ) {
429 _save \%saved, \%saved_as, $op->{KFD} ;
430 IPC::Run::_close( $op->{KFD} ) ;
435 _save \%saved, \%saved_as, $op->{KFD};
436 IPC::Run::_close( $op->{KFD} );
431437 }
432438 elsif ( $op->{TYPE} eq "init" ) {
433439 ## TODO: detect this in harness()
434 croak "init subs not allowed on Win32" ;
440 croak "init subs not allowed on Win32";
435441 }
436442 }
437443
438 my $process ;
444 my $process;
439445 my $cmd_line = join " ", map {
440446 ( my $s = $_ ) =~ s/"/"""/g;
441 $s = qq{"$s"} if /["\s]/;
442 $s ;
443 } @$cmd ;
447 $s = qq{"$s"} if /[\"\s]/;
448 $s;
449 } @$cmd;
444450
445451 _debug "cmd line: ", $cmd_line
446452 if _debugging;
452458 1, ## Inherit handles
453459 NORMAL_PRIORITY_CLASS,
454460 ".",
455 ) or croak "$!: Win32::Process::Create()" ;
461 ) or croak "$!: Win32::Process::Create()";
456462
457463 for my $orig_fd ( keys %saved ) {
458 IPC::Run::_dup2_rudely( $saved{$orig_fd}, $orig_fd ) ;
459 IPC::Run::_close( $saved{$orig_fd} ) ;
464 IPC::Run::_dup2_rudely( $saved{$orig_fd}, $orig_fd );
465 IPC::Run::_close( $saved{$orig_fd} );
460466 }
461467
462 return ( $process->GetProcessID(), $process ) ;
463 }
464
468 return ( $process->GetProcessID(), $process );
469 }
470
471
472 1;
473
474 =pod
465475
466476 =back
467477
476486 You may use this under the terms of either the GPL 2.0 ir the Artistic License.
477487
478488 =cut
479
480 1 ;
+93
-87
lib/IPC/Run/Win32IO.pm less more
00 package IPC::Run::Win32IO;
1
2 =pod
13
24 =head1 NAME
35
1416 time, not sure if it will ever work on Win95 or Win98. If you have experience
1517 in this area, please contact me at barries@slaysys.com, thanks!.
1618
19 =head1 DESCRIPTION
20
21 A specialized IO class used on Win32.
22
1723 =cut
1824
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 ;
25 use strict;
26 use Carp;
27 use IO::Handle;
28 use Socket;
29 require POSIX;
30
31 use vars qw{$VERSION};
32 BEGIN {
33 $VERSION = '0.82';
34 }
35
36 use Socket qw( IPPROTO_TCP TCP_NODELAY );
37 use Symbol;
38 use Text::ParseWords;
39 use Win32::Process;
3540 use IPC::Run::Debug qw( :default _debugging_level );
3641 use IPC::Run::Win32Helper qw( _inherit _dont_inherit );
3742 use Fcntl qw( O_TEXT O_RDONLY );
7782 FILE_FLAG_WRITE_THROUGH
7883
7984 FILE_BEGIN
80 ) ;
85 );
8186
8287 # FILE_ATTRIBUTE_HIDDEN
8388 # FILE_ATTRIBUTE_SYSTEM
96101 );
97102 }
98103
99
100104 use constant temp_file_flags => (
101105 FILE_ATTRIBUTE_TEMPORARY() |
102106 FILE_FLAG_DELETE_ON_CLOSE() |
260264 []
261265 ) or croak "$^E reading from $self->{TEMP_FILE_NAME}";
262266
263 _debug "ReadFile( $self->{TFD} ) = $r chars '$s'" if _debugging_data ;
267 _debug "ReadFile( $self->{TFD} ) = $r chars '$s'" if _debugging_data;
264268
265269 return undef unless $r;
266270
299303 ## closing off the ones we don't want.
300304
301305 sub _spawn_pumper {
302 my ( $stdin, $stdout, $debug_fd, $binmode, $child_label, @opts ) = @_ ;
303 my ( $stdin_fd, $stdout_fd ) = ( fileno $stdin, fileno $stdout ) ;
306 my ( $stdin, $stdout, $debug_fd, $binmode, $child_label, @opts ) = @_;
307 my ( $stdin_fd, $stdout_fd ) = ( fileno $stdin, fileno $stdout );
304308
305309 _debug "pumper stdin = ", $stdin_fd if _debugging_details;
306310 _debug "pumper stdout = ", $stdout_fd if _debugging_details;
307 _inherit $stdin_fd, $stdout_fd, $debug_fd ;
311 _inherit $stdin_fd, $stdout_fd, $debug_fd;
308312 my @I_options = map qq{"-I$_"}, @INC;
309313
310314 my $cmd_line = join( " ",
322326 $binmode ? 1 : 0,
323327 $$, $^T, _debugging_level, qq{"$child_label"},
324328 @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
329 );
330
331 # open SAVEIN, "<&STDIN" or croak "$! saving STDIN"; #### ADD
332 # open SAVEOUT, ">&STDOUT" or croak "$! saving STDOUT"; #### ADD
333 # open SAVEERR, ">&STDERR" or croak "$! saving STDERR"; #### ADD
334 # _dont_inherit \*SAVEIN; #### ADD
335 # _dont_inherit \*SAVEOUT; #### ADD
336 # _dont_inherit \*SAVEERR; #### ADD
337 # open STDIN, "<&$stdin_fd" or croak "$! dup2()ing $stdin_fd (pumper's STDIN)"; #### ADD
338 # open STDOUT, ">&$stdout_fd" or croak "$! dup2()ing $stdout_fd (pumper's STDOUT)"; #### ADD
339 # open STDERR, ">&$debug_fd" or croak "$! dup2()ing $debug_fd (pumper's STDERR/debug_fd)"; #### ADD
336340
337341 _debug "pump cmd line: ", $cmd_line if _debugging_details;
338342
339 my $process ;
343 my $process;
340344 Win32::Process::Create(
341345 $process,
342346 $^X,
344348 1, ## Inherit handles
345349 NORMAL_PRIORITY_CLASS,
346350 ".",
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" ;
351 ) or croak "$!: Win32::Process::Create()";
352
353 # open STDIN, "<&SAVEIN" or croak "$! restoring STDIN"; #### ADD
354 # open STDOUT, ">&SAVEOUT" or croak "$! restoring STDOUT"; #### ADD
355 # open STDERR, ">&SAVEERR" or croak "$! restoring STDERR"; #### ADD
356 # close SAVEIN or croak "$! closing SAVEIN"; #### ADD
357 # close SAVEOUT or croak "$! closing SAVEOUT"; #### ADD
358 # close SAVEERR or croak "$! closing SAVEERR"; #### ADD
359
360 close $stdin or croak "$! closing pumper's stdin in parent";
361 close $stdout or croak "$! closing pumper's stdout in parent";
358362 # Don't close $debug_fd, we need it, as do other pumpers.
359363
360364 # Pause a moment to allow the child to get up and running and emit
361365 # debug messages. This does not always work.
362 # select undef, undef, undef, 1 if _debugging_details ;
366 # select undef, undef, undef, 1 if _debugging_details;
363367
364368 _debug "_spawn_pumper pid = ", $process->GetProcessID
365369 if _debugging_data;
366370 }
367371
368372
369 my $next_port = 2048 ;
370 my $loopback = inet_aton "127.0.0.1" ;
373 my $next_port = 2048;
374 my $loopback = inet_aton "127.0.0.1";
371375 my $tcp_proto = getprotobyname('tcp');
372 croak "$!: getprotobyname('tcp')" unless defined $tcp_proto ;
376 croak "$!: getprotobyname('tcp')" unless defined $tcp_proto;
373377
374378 sub _socket {
375 my ( $server ) = @_ ;
376 $server ||= gensym ;
377 my $client = gensym ;
378
379 my $listener = gensym ;
379 my ( $server ) = @_;
380 $server ||= gensym;
381 my $client = gensym;
382
383 my $listener = gensym;
380384 socket $listener, PF_INET, SOCK_STREAM, $tcp_proto
381385 or croak "$!: socket()";
382386 setsockopt $listener, SOL_SOCKET, SO_REUSEADDR, pack("l", 0)
383387 or croak "$!: setsockopt()";
384388
385 my $port ;
386 my @errors ;
389 my $port;
390 my @errors;
387391 PORT_FINDER_LOOP:
388392 {
389 $port = $next_port ;
390 $next_port = 2048 if ++$next_port > 65_535 ;
393 $port = $next_port;
394 $next_port = 2048 if ++$next_port > 65_535;
391395 unless ( bind $listener, sockaddr_in( $port, INADDR_ANY ) ) {
392 push @errors, "$! on port $port" ;
393 croak join "\n", @errors if @errors > 10 ;
396 push @errors, "$! on port $port";
397 croak join "\n", @errors if @errors > 10;
394398 goto PORT_FINDER_LOOP;
395399 }
396400 }
398402 _debug "win32 port = $port" if _debugging_details;
399403
400404 listen $listener, my $queue_size = 1
401 or croak "$!: listen()" ;
405 or croak "$!: listen()";
402406
403407 {
404408 socket $client, PF_INET, SOCK_STREAM, $tcp_proto
407411 my $paddr = sockaddr_in($port, $loopback );
408412
409413 connect $client, $paddr
410 or croak "$!: connect()" ;
414 or croak "$!: connect()";
411415
412 croak "$!: accept" unless defined $paddr ;
416 croak "$!: accept" unless defined $paddr;
413417
414418 ## The windows "default" is SO_DONTLINGER, which should make
415419 ## sure all socket data goes through. I have my doubts based
421425
422426 {
423427 _debug "accept()ing on port $port" if _debugging_details;
424 my $paddr = accept( $server, $listener ) ;
425 croak "$!: accept()" unless defined $paddr ;
428 my $paddr = accept( $server, $listener );
429 croak "$!: accept()" unless defined $paddr;
426430 }
427431
428432 _debug
429433 "win32 _socket = ( ", fileno $server, ", ", fileno $client, " ) on port $port"
430434 if _debugging_details;
431 return ( $server, $client ) ;
435 return ( $server, $client );
432436 }
433437
434438
435439 sub _open_socket_pipe {
436440 my IPC::Run::Win32IO $self = shift;
437 my ( $debug_fd, $parent_handle ) = @_ ;
441 my ( $debug_fd, $parent_handle ) = @_;
438442
439443 my $is_send_to_child = $self->dir eq "<";
440444
444448 (
445449 $self->{PARENT_HANDLE},
446450 $self->{PUMP_SOCKET_HANDLE}
447 ) = _socket $parent_handle ;
451 ) = _socket $parent_handle;
448452
449453 ## These binmodes seem to have no effect on Win2K, but just to be safe
450454 ## I do them.
453457
454458 _debug "PUMP_SOCKET_HANDLE = ", fileno $self->{PUMP_SOCKET_HANDLE}
455459 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 ) ;
460 ##my $buf;
461 ##$buf = "write on child end of " . fileno( $self->{WRITE_HANDLE} ) . "\n\n\n\n\n";
462 ##POSIX::write(fileno $self->{WRITE_HANDLE}, $buf, length $buf) or warn "$! in syswrite";
463 ##$buf = "write on parent end of " . fileno( $self->{CHILD_HANDLE} ) . "\r\n";
464 ##POSIX::write(fileno $self->{CHILD_HANDLE},$buf, length $buf) or warn "$! in syswrite";
465 ## $self->{CHILD_HANDLE}->autoflush( 1 );
466 ## $self->{WRITE_HANDLE}->autoflush( 1 );
463467
464468 ## Now fork off a data pump and arrange to return the correct fds.
465469 if ( $is_send_to_child ) {
466470 pipe $self->{CHILD_HANDLE}, $self->{PUMP_PIPE_HANDLE}
467 or croak "$! opening child pipe" ;
471 or croak "$! opening child pipe";
468472 _debug "CHILD_HANDLE = ", fileno $self->{CHILD_HANDLE}
469473 if _debugging_details;
470474 _debug "PUMP_PIPE_HANDLE = ", fileno $self->{PUMP_PIPE_HANDLE}
472476 }
473477 else {
474478 pipe $self->{PUMP_PIPE_HANDLE}, $self->{CHILD_HANDLE}
475 or croak "$! opening child pipe" ;
479 or croak "$! opening child pipe";
476480 _debug "CHILD_HANDLE = ", fileno $self->{CHILD_HANDLE}
477481 if _debugging_details;
478482 _debug "PUMP_PIPE_HANDLE = ", fileno $self->{PUMP_PIPE_HANDLE}
485489 binmode $self->{PUMP_PIPE_HANDLE};
486490
487491 ## No child should ever see this.
488 _dont_inherit $self->{PARENT_HANDLE} ;
492 _dont_inherit $self->{PARENT_HANDLE};
489493
490494 ## We clear the inherit flag so these file descriptors are not inherited.
491495 ## It'll be dup()ed on to STDIN/STDOUT/STDERR before CreateProcess is
492496 ## 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} ;
497 _dont_inherit $self->{PUMP_SOCKET_HANDLE};
498 _dont_inherit $self->{PUMP_PIPE_HANDLE};
499 _dont_inherit $self->{CHILD_HANDLE};
496500
497501 ## Need to return $self so the HANDLEs don't get freed.
498502 ## Return $self, $parent_fd, $child_fd
499503 my ( $parent_fd, $child_fd ) = (
500504 fileno $self->{PARENT_HANDLE},
501505 fileno $self->{CHILD_HANDLE}
502 ) ;
506 );
503507
504508 ## Both PUMP_..._HANDLEs will be closed, no need to worry about
505509 ## inheritance.
511515 $debug_fd,
512516 $self->binmode,
513517 $child_fd . $self->dir . "pump" . $self->dir . $parent_fd,
514 ) ;
518 );
515519
516520 {
517 my $foo ;
521 my $foo;
518522 confess "PARENT_HANDLE no longer open"
519 unless POSIX::read( $parent_fd, $foo, 0 ) ;
523 unless POSIX::read( $parent_fd, $foo, 0 );
520524 }
521525
522526 _debug "win32_fake_pipe = ( $parent_fd, $child_fd )"
540544 }
541545 }
542546
547 1;
548
549 =pod
550
543551 =head1 AUTHOR
544552
545553 Barries Slaymaker <barries@slaysys.com>. Funded by Perforce Software, Inc.
551559 You may use this under the terms of either the GPL 2.0 ir the Artistic License.
552560
553561 =cut
554
555 1;
+45
-37
lib/IPC/Run/Win32Pump.pm less more
00 package IPC::Run::Win32Pump;
1
2 =pod
13
24 =head1 NAME
35
2325
2426 =cut
2527
26 use strict ;
28 use strict;
29 use vars qw{$VERSION};
30 BEGIN {
31 $VERSION = '0.82';
32 }
2733
2834 use Win32API::File qw(
2935 OsFHandleOpen
30 ) ;
36 );
3137
3238
3339 my ( $stdin_fh, $stdout_fh, $debug_fh, $binmode, $parent_pid, $parent_start_time, $debug, $child_label );
3440 BEGIN {
35 ( $stdin_fh, $stdout_fh, $debug_fh, $binmode, $parent_pid, $parent_start_time, $debug, $child_label ) = @ARGV ;
41 ( $stdin_fh, $stdout_fh, $debug_fh, $binmode, $parent_pid, $parent_start_time, $debug, $child_label ) = @ARGV;
3642 ## Rather than letting IPC::Run::Debug export all-0 constants
3743 ## when not debugging, we do it manually in order to not even
3844 ## load IPC::Run::Debug.
5864 if ( $debug ) { #### REMOVE
5965 close STDERR; #### REMOVE
6066 OsFHandleOpen( \*STDERR, $debug_fh, "w" ) #### REMOVE
61 or print "$! opening STDERR as Win32 handle $debug_fh in pumper $$" ; #### REMOVE
67 or print "$! opening STDERR as Win32 handle $debug_fh in pumper $$"; #### REMOVE
6268 } #### REMOVE
6369 close STDIN; #### REMOVE
6470 OsFHandleOpen( \*STDIN, $stdin_fh, "r" ) #### REMOVE
65 or die "$! opening STDIN as Win32 handle $stdin_fh in pumper $$" ; #### REMOVE
71 or die "$! opening STDIN as Win32 handle $stdin_fh in pumper $$"; #### REMOVE
6672 close STDOUT; #### REMOVE
6773 OsFHandleOpen( \*STDOUT, $stdout_fh, "w" ) #### REMOVE
68 or die "$! opening STDOUT as Win32 handle $stdout_fh in pumper $$" ; #### REMOVE
74 or die "$! opening STDOUT as Win32 handle $stdout_fh in pumper $$"; #### REMOVE
6975
7076 binmode STDIN;
7177 binmode STDOUT;
72 $| = 1 ;
73 select STDERR ; $| = 1 ; select STDOUT ;
78 $| = 1;
79 select STDERR; $| = 1; select STDOUT;
7480
75 $child_label ||= "pump" ;
81 $child_label ||= "pump";
7682 _debug_init(
7783 $parent_pid,
7884 $parent_start_time,
7985 $debug,
8086 fileno STDERR,
8187 $child_label,
82 ) ;
88 );
8389
84 _debug "Entered" if _debugging_details ;
90 _debug "Entered" if _debugging_details;
8591
8692 # 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 ;
93 $| = 1;
94 my $buf;
95 my $total_count = 0;
9096 while (1) {
91 my $count = sysread STDIN, $buf, 10_000 ;
92 last unless $count ;
97 my $count = sysread STDIN, $buf, 10_000;
98 last unless $count;
9399 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 ;
100 my $msg = "'$buf'";
101 substr( $msg, 100, -1 ) = '...' if length $msg > 100;
102 $msg =~ s/\n/\\n/g;
103 $msg =~ s/\r/\\r/g;
104 $msg =~ s/\t/\\t/g;
105 $msg =~ s/([\000-\037\177-\277])/sprintf "\0x%02x", ord $1/eg;
106 _debug sprintf( "%5d chars revc: ", $count ), $msg;
101107 }
102 $total_count += $count ;
108 $total_count += $count;
103109 $buf =~ s/\r//g unless $binmode;
104110 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 ;
111 my $msg = "'$buf'";
112 substr( $msg, 100, -1 ) = '...' if length $msg > 100;
113 $msg =~ s/\n/\\n/g;
114 $msg =~ s/\r/\\r/g;
115 $msg =~ s/\t/\\t/g;
116 $msg =~ s/([\000-\037\177-\277])/sprintf "\0x%02x", ord $1/eg;
117 _debug sprintf( "%5d chars sent: ", $count ), $msg;
112118 }
113 print $buf ;
119 print $buf;
114120 }
115121
116 _debug "Exiting, transferred $total_count chars" if _debugging_details ;
122 _debug "Exiting, transferred $total_count chars" if _debugging_details;
117123
118124 ## Perform a graceful socket shutdown. Windows defaults to SO_DONTLINGER,
119125 ## which should cause a "graceful shutdown in the background" on sockets.
143149 ## 3) Use Inline::C or a hand-tooled XS module to do helper threads.
144150 ## This would be faster than #1, but would require a ppm distro.
145151 ##
146 close STDOUT ;
147 close STDERR ;
152 close STDOUT;
153 close STDERR;
154
155 1;
156
157 =pod
148158
149159 =head1 AUTHOR
150160
157167 You may use this under the terms of either the GPL 2.0 ir the Artistic License.
158168
159169 =cut
160
161 1 ;
+1393
-1506
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";
0 package IPC::Run;
1
2 =pod
93
104 =head1 NAME
115
148 =head1 SYNOPSIS
159
1610 ## First,a command to run:
17 my @cat = qw( cat ) ;
11 my @cat = qw( cat );
1812
1913 ## Using run() instead of system():
20 use IPC::Run qw( run timeout ) ;
14 use IPC::Run qw( run timeout );
2115
2216 run \@cmd, \$in, \$out, \$err, timeout( 10 ) or die "cat: $?"
2317
2418 # Can do I/O to sub refs and filenames, too:
2519 run \@cmd, '<', "in.txt", \&out, \&err or die "cat: $?"
26 run \@cat, '<', "in.txt", '>>', "out.txt", '2>>', "err.txt" ;
20 run \@cat, '<', "in.txt", '>>', "out.txt", '2>>', "err.txt";
2721
2822
2923 # Redirecting using psuedo-terminals instad of pipes.
30 run \@cat, '<pty<', \$in, '>pty>', \$out_and_err ;
24 run \@cat, '<pty<', \$in, '>pty>', \$out_and_err;
3125
3226 ## Scripting subprocesses (like Expect):
3327
34 use IPC::Run qw( start pump finish timeout ) ;
28 use IPC::Run qw( start pump finish timeout );
3529
3630 # Incrementally read from / write to scalars.
3731 # $in is drained as it is fed to cat's stdin,
3832 # $out accumulates cat's stdout
3933 # $err accumulates cat's stderr
4034 # $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
35 my $h = start \@cat, \$in, \$out, \$err, timeout( 10 );
36
37 $in .= "some input\n";
38 pump $h until $out =~ /input\n/g;
39
40 $in .= "some more input\n";
41 pump $h until $out =~ /\G.*more input\n/;
42
43 $in .= "some final input\n";
44 finish $h or die "cat returned $?";
45
46 warn $err if $err;
47 print $out; ## All of cat's output
5448
5549 # Piping between children
56 run \@cat, '|', \@gzip ;
50 run \@cat, '|', \@gzip;
5751
5852 # Multiple children simultaneously (run() blocks until all
5953 # children exit, use start() for background execution):
60 run \@foo1, '&', \@foo2 ;
54 run \@foo1, '&', \@foo2;
6155
6256 # Calling \&set_up_child in the child before it executes the
6357 # command (only works on systems with true fork() & exec())
6458 # exceptions thrown in set_up_child() will be propagated back
6559 # to the parent and thrown from run().
6660 run \@cat, \$in, \$out,
67 init => \&set_up_child ;
61 init => \&set_up_child;
6862
6963 # 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 ;
64 open IN, '<in.txt' or die $!;
65 open OUT, '>out.txt' or die $!;
66 print OUT "preamble\n";
67 run \@cat, \*IN, \*OUT or die "cat returned $?";
68 print OUT "postamble\n";
69 close IN;
70 close OUT;
7771
7872 # Create pipes for you to read / write (like IPC::Open2 & 3).
7973 $h = start
8175 '<pipe', \*IN,
8276 '>pipe', \*OUT,
8377 '2>pipe', \*ERR
84 or die "cat returned $?" ;
85 print IN "some input\n" ;
86 close IN ;
87 print <OUT>, <ERR> ;
88 finish $h ;
78 or die "cat returned $?";
79 print IN "some input\n";
80 close IN;
81 print <OUT>, <ERR>;
82 finish $h;
8983
9084 # Mixing input and output modes
91 run \@cat, 'in.txt', \&catch_some_out, \*ERR_LOG ) ;
85 run \@cat, 'in.txt', \&catch_some_out, \*ERR_LOG );
9286
9387 # 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 ;
88 run \@cat, '>&', \$out_and_err;
89 run \@cat, '2>&1';
90 run \@cat, '0<&3';
91 run \@cat, '<&-';
92 run \@cat, '3<', \$in3;
93 run \@cat, '4>', \$out4;
10094 # etc.
10195
10296 # Passing options:
103 run \@cat, 'in.txt', debug => 1 ;
97 run \@cat, 'in.txt', debug => 1;
10498
10599 # Call this system's shell, returns TRUE on 0 exit code
106100 # THIS IS THE OPPOSITE SENSE OF system()'s RETURN VALUE
107 run "cat a b c" or die "cat returned $?" ;
101 run "cat a b c" or die "cat returned $?";
108102
109103 # Launch a sub process directly, no shell. Can't do redirection
110104 # with this form, it's here to behave like system() with an
111105 # inverted result.
112 $r = run "cat a b c" ;
106 $r = run "cat a b c";
113107
114108 # Read from a file in to a scalar
115 run io( "filename", 'r', \$recv ) ;
116 run io( \*HANDLE, 'r', \$recv ) ;
109 run io( "filename", 'r', \$recv );
110 run io( \*HANDLE, 'r', \$recv );
117111
118112 =head1 DESCRIPTION
119113
180174 get around this limitation). The harness is run and all output is
181175 collected from it, then any child processes are waited for:
182176
183 run \@cmd, \<<IN, \$out ;
177 run \@cmd, \<<IN, \$out;
184178 blah
185179 IN
186180
187181 ## To precompile harnesses and run them later:
188 my $h = harness \@cmd, \<<IN, \$out ;
182 my $h = harness \@cmd, \<<IN, \$out;
189183 blah
190184 IN
191185
192 run $h ;
186 run $h;
193187
194188 The background and scripting API is provided by start(), pump(), and
195189 finish(): start() creates a harness if need be (by calling harness())
198192 complete.
199193
200194 ## Build the harness, open all pipes, and launch the subprocesses
201 my $h = start \@cat, \$in, \$out ;
202 $in = "first input\n" ;
195 my $h = start \@cat, \$in, \$out;
196 $in = "first input\n";
203197
204198 ## Now do I/O. start() does no I/O.
205 pump $h while length $in ; ## Wait for all input to go
199 pump $h while length $in; ## Wait for all input to go
206200
207201 ## Now do some more I/O.
208 $in = "second input\n" ;
209 pump $h until $out =~ /second input/ ;
202 $in = "second input\n";
203 pump $h until $out =~ /second input/;
210204
211205 ## Clean up
212 finish $h or die "cat returned $?" ;
206 finish $h or die "cat returned $?";
213207
214208 You can optionally compile the harness with harness() prior to
215209 start()ing or run()ing, and you may omit start() between harness() and
230224 how to pump() until some string appears in the output. Here's an
231225 example that uses C<smb> to fetch files from a remote server:
232226
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 ;
227 $h = harness \@smbclient, \$in, \$out;
228
229 $in = "cd /src\n";
230 $h->pump until $out =~ /^smb.*> \Z/m;
231 die "error cding to /src:\n$out" if $out =~ "ERR";
232 $out = '';
233
234 $in = "mget *\n";
235 $h->pump until $out =~ /^smb.*> \Z/m;
236 die "error retrieving files:\n$out" if $out =~ "ERR";
237
238 $in = "quit\n";
239 $h->finish;
246240
247241 Notice that we carefully clear $out after the first command/response
248242 cycle? That's because IPC::Run does not delete $out when we continue,
259253 resetting the prior match position if the expected prompt doesn't
260254 materialize immediately:
261255
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 ) ;
256 $h = harness \@smbclient, \$in, \$out;
257
258 $in = "cd /src\n";
259 $h->pump until $out =~ /^smb.*> \Z/mgc;
260 die "error cding to /src:\n$out" if $out =~ "ERR";
261
262 $in = "mget *\n";
263 $h->pump until $out =~ /^smb.*> \Z/mgc;
264 die "error retrieving files:\n$out" if $out =~ "ERR";
265
266 $in = "quit\n";
267 $h->finish;
268
269 analyze( $out );
276270
277271 When using this technique, you may want to preallocate $out to have
278272 plenty of memory or you may find that the act of growing $out each time
280274 Say we expect no more than 10,000 characters of input at the most. To
281275 preallocate memory to $out, do something like:
282276
283 my $out = "x" x 10_000 ;
284 $out = "" ;
277 my $out = "x" x 10_000;
278 $out = "";
285279
286280 C<perl> will allocate at least 10,000 characters' worth of space, then
287281 mark the $out as having 0 length without freeing all that yummy RAM.
324318 ## Start with a nice long timeout to let smbclient connect. If
325319 ## pump or finish take too long, an exception will be thrown.
326320
327 my $h ;
321 my $h;
328322 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" ;
323 $h = harness \@smbclient, \$in, \$out, \$err, ( my $t = timeout 30 );
324 sleep 11; # No effect: timer not running yet
325
326 start $h;
327 $in = "cd /src\n";
328 pump $h until ! length $in;
329
330 $in = "ls\n";
337331 ## 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 } ;
332 $t->start( 5 );
333 pump $h until ! length $in;
334
335 $t->start( 10 ); ## Give smbclient a little while to shut down.
336 $h->finish;
337 };
344338 if ( $@ ) {
345 my $x = $@ ; ## Preserve $@ in case another exception occurs
346 $h->kill_kill ; ## kill it gently, then brutally if need be, or just
339 my $x = $@; ## Preserve $@ in case another exception occurs
340 $h->kill_kill; ## kill it gently, then brutally if need be, or just
347341 ## brutally on Win32.
348 die $x ;
342 die $x;
349343 }
350344
351345 Timeouts and timers are I<not> checked once the subprocesses are shut
365359 example:
366360
367361 eval {
368 run \@cmd, init => sub { die "blast it! foiled again!" } ;
369 } ;
370 print $@ ;
362 run \@cmd, init => sub { die "blast it! foiled again!" };
363 };
364 print $@;
371365
372366 the exception "blast it! foiled again" will be thrown from the child
373367 process (preventing the exec()) and printed by the parent.
374368
375369 In situations like
376370
377 run \@cmd1, "|", \@cmd2, "|", \@cmd3 ;
371 run \@cmd1, "|", \@cmd2, "|", \@cmd3;
378372
379373 @cmd1 will be initted and exec()ed before @cmd2, and @cmd2 before @cmd3.
380374 This can save time and prevent oddball errors emitted by later commands
413407 as input. A harness specification is either a single string to be passed
414408 to the systems' shell:
415409
416 run "echo 'hi there'" ;
410 run "echo 'hi there'";
417411
418412 or a list of commands, io operations, and/or timers/timeouts to execute.
419413 Consecutive commands must be separated by a pipe operator '|' or an '&'.
420414 External commands are passed in as array references, and, on systems
421415 supporting fork(), Perl code may be passed in as subs:
422416
423 run \@cmd ;
424 run \@cmd1, '|', \@cmd2 ;
425 run \@cmd1, '&', \@cmd2 ;
426 run \&sub1 ;
427 run \&sub1, '|', \&sub2 ;
428 run \&sub1, '&', \&sub2 ;
417 run \@cmd;
418 run \@cmd1, '|', \@cmd2;
419 run \@cmd1, '&', \@cmd2;
420 run \&sub1;
421 run \&sub1, '|', \&sub2;
422 run \&sub1, '&', \&sub2;
429423
430424 '|' pipes the stdout of \@cmd1 the stdin of \@cmd2, just like a
431425 shell pipe. '&' does not. Child processes to the right of a '&'
434428 L<IPC::Run::IO> objects may be passed in as well, whether or not
435429 child processes are also specified:
436430
437 run io( "infile", ">", \$in ), io( "outfile", "<", \$in ) ;
431 run io( "infile", ">", \$in ), io( "outfile", "<", \$in );
438432
439433 as can L<IPC::Run::Timer> objects:
440434
441 run \@cmd, io( "outfile", "<", \$in ), timeout( 10 ) ;
435 run \@cmd, io( "outfile", "<", \$in ), timeout( 10 );
442436
443437 Commands may be followed by scalar, sub, or i/o handle references for
444438 redirecting
445439 child process input & output:
446440
447 run \@cmd, \undef, \$out ;
448 run \@cmd, \$in, \$out ;
449 run \@cmd1, \&in, '|', \@cmd2, \*OUT ;
450 run \@cmd1, \*IN, '|', \@cmd2, \&out ;
441 run \@cmd, \undef, \$out;
442 run \@cmd, \$in, \$out;
443 run \@cmd1, \&in, '|', \@cmd2, \*OUT;
444 run \@cmd1, \*IN, '|', \@cmd2, \&out;
451445
452446 This is known as succinct redirection syntax, since run(), start()
453447 and harness(), figure out which file descriptor to redirect and how.
459453 To be explicit about your redirects, or if you need to do more complex
460454 things, there's also a redirection operator syntax:
461455
462 run \@cmd, '<', \undef, '>', \$out ;
463 run \@cmd, '<', \undef, '>&', \$out_and_err ;
456 run \@cmd, '<', \undef, '>', \$out;
457 run \@cmd, '<', \undef, '>&', \$out_and_err;
464458 run(
465459 \@cmd1,
466460 '<', \$in,
467461 '|', \@cmd2,
468462 \$out
469 ) ;
463 );
470464
471465 Operator syntax is required if you need to do something other than simple
472466 redirection to/from scalars or subs, like duping or closing file descriptors
498492
499493 If you want to close a child processes stdin, you may do any of:
500494
501 run \@cmd, \undef ;
502 run \@cmd, \"" ;
503 run \@cmd, '<&-' ;
504 run \@cmd, '0<&-' ;
495 run \@cmd, \undef;
496 run \@cmd, \"";
497 run \@cmd, '<&-';
498 run \@cmd, '0<&-';
505499
506500 Redirection is done by placing redirection specifications immediately
507501 after a command or child subroutine:
508502
509 run \@cmd1, \$in, '|', \@cmd2, \$out ;
510 run \@cmd1, '<', \$in, '|', \@cmd2, '>', \$out ;
503 run \@cmd1, \$in, '|', \@cmd2, \$out;
504 run \@cmd1, '<', \$in, '|', \@cmd2, '>', \$out;
511505
512506 If you omit the redirection operators, descriptors are counted
513507 starting at 0. Descriptor 0 is assumed to be input, all others
514508 are outputs. A leading '|' consumes descriptor 0, so this
515509 works as expected.
516510
517 run \@cmd1, \$in, '|', \@cmd2, \$out ;
511 run \@cmd1, \$in, '|', \@cmd2, \$out;
518512
519513 The parameter following a redirection operator can be a scalar ref,
520514 a subroutine ref, a file name, an open filehandle, or a closed
523517 If it's a scalar ref, the child reads input from or sends output to
524518 that variable:
525519
526 $in = "Hello World.\n" ;
527 run \@cat, \$in, \$out ;
528 print $out ;
520 $in = "Hello World.\n";
521 run \@cat, \$in, \$out;
522 print $out;
529523
530524 Scalars used in incremental (start()/pump()/finish()) applications are treated
531525 as queues: input is removed from input scalers, resulting in them dwindling
535529 It's usually wise to append new input to be sent to the child to the input
536530 queue, and you'll often want to zap output queues to '' before pumping.
537531
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 ;
532 $h = start \@cat, \$in;
533 $in = "line 1\n";
534 pump $h;
535 $in .= "line 2\n";
536 pump $h;
537 $in .= "line 3\n";
538 finish $h;
545539
546540 The final call to finish() must be there: it allows the child process(es)
547541 to run to completion and waits for their exit values.
598592
599593 You should also look for your prompt to be the only thing on a line:
600594
601 pump $h until $out =~ /^<SILLYPROMPT>\s?\z/m ;
595 pump $h until $out =~ /^<SILLYPROMPT>\s?\z/m;
602596
603597 (use C<(?!\n)\Z> in place of C<\z> on older perls).
604598
685679 The pseudo terminal redirects both stdout and stderr unless you specify
686680 a file descriptor. If you want to grab stderr separately, do this:
687681
688 start \@cmd, '<pty<', \$in, '>pty>', \$out, '2>', \$err ;
682 start \@cmd, '<pty<', \$in, '>pty>', \$out, '2>', \$err;
689683
690684 =item stdin, stdout, and stderr not inherited
691685
741735 is not redirected, the parent's stdin is inherited.
742736
743737 run \@cat, \undef ## Closes child's stdin immediately
744 or die "cat returned $?" ;
745
746 run \@cat, \$in ;
747
748 run \@cat, \<<TOHERE ;
738 or die "cat returned $?";
739
740 run \@cat, \$in;
741
742 run \@cat, \<<TOHERE;
749743 blah
750744 TOHERE
751745
752 run \@cat, \&input ; ## Calls &input, feeding data returned
746 run \@cat, \&input; ## Calls &input, feeding data returned
753747 ## to child's. Closes child's stdin
754748 ## when undef is returned.
755749
756750 Redirecting from named files requires you to use the input
757751 redirection operator:
758752
759 run \@cat, '<.profile' ;
760 run \@cat, '<', '.profile' ;
761
762 open IN, "<foo" ;
763 run \@cat, \*IN ;
764 run \@cat, *IN{IO} ;
753 run \@cat, '<.profile';
754 run \@cat, '<', '.profile';
755
756 open IN, "<foo";
757 run \@cat, \*IN;
758 run \@cat, *IN{IO};
765759
766760 The form used second example here is the safest,
767761 since filenames like "0" and "&more\n" won't confuse &run:
768762
769763 You can't do either of
770764
771 run \@a, *IN ; ## INVALID
772 run \@a, '<', *IN ; ## BUGGY: Reads file named like "*main::A"
765 run \@a, *IN; ## INVALID
766 run \@a, '<', *IN; ## BUGGY: Reads file named like "*main::A"
773767
774768 because perl passes a scalar containing a string that
775769 looks like "*main::A" to &run, and &run can't tell the difference
780774 than 0 (stdin), you can use a redirection operator with any of the
781775 valid input forms (scalar ref, sub ref, etc.):
782776
783 run \@cat, '3<', \$in3 ;
777 run \@cat, '3<', \$in3;
784778
785779 When redirecting input from a scalar ref, the scalar ref is
786780 used as a queue. This allows you to use &harness and pump() to
790784 The <pipe operator opens the write half of a pipe on the filehandle
791785 glob reference it takes as an argument:
792786
793 $h = start \@cat, '<pipe', \*IN ;
794 print IN "hello world\n" ;
795 pump $h ;
796 close IN ;
797 finish $h ;
787 $h = start \@cat, '<pipe', \*IN;
788 print IN "hello world\n";
789 pump $h;
790 close IN;
791 finish $h;
798792
799793 Unlike the other '<' operators, IPC::Run does nothing further with
800794 it: you are responsible for it. The previous example is functionally
801795 equivalent to:
802796
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 ;
797 pipe( \*R, \*IN ) or die $!;
798 $h = start \@cat, '<', \*IN;
799 print IN "hello world\n";
800 pump $h;
801 close IN;
802 finish $h;
809803
810804 This is like the behavior of IPC::Open2 and IPC::Open3.
811805
821815 receiving end of a pipeline ('|'), you can omit the redirection
822816 operator:
823817
824 @ls = ( 'ls' ) ;
818 @ls = ( 'ls' );
825819 run \@ls, \undef, \$out
826 or die "ls returned $?" ;
827
828 run \@ls, \undef, \&out ; ## Calls &out each time some output
820 or die "ls returned $?";
821
822 run \@ls, \undef, \&out; ## Calls &out each time some output
829823 ## is received from the child's
830824 ## when undef is returned.
831825
832 run \@ls, \undef, '2>ls.err' ;
833 run \@ls, '2>', 'ls.err' ;
826 run \@ls, \undef, '2>ls.err';
827 run \@ls, '2>', 'ls.err';
834828
835829 The two parameter form guarantees that the filename
836830 will not be interpreted as a redirection operator:
837831
838 run \@ls, '>', "&more" ;
839 run \@ls, '2>', ">foo\n" ;
832 run \@ls, '>', "&more";
833 run \@ls, '2>', ">foo\n";
840834
841835 You can pass file handles you've opened for writing:
842836
843 open( *OUT, ">out.txt" ) ;
844 open( *ERR, ">err.txt" ) ;
845 run \@cat, \*OUT, \*ERR ;
837 open( *OUT, ">out.txt" );
838 open( *ERR, ">err.txt" );
839 run \@cat, \*OUT, \*ERR;
846840
847841 Passing a scalar reference and a code reference requires a little
848842 more work, but allows you to capture all of the output in a scalar
850844
851845 These two do the same things:
852846
853 run( [ 'ls' ], '2>', sub { $err_out .= $_[0] } ) ;
847 run( [ 'ls' ], '2>', sub { $err_out .= $_[0] } );
854848
855849 does the same basic thing as:
856850
857 run( [ 'ls' ], '2>', \$err_out ) ;
851 run( [ 'ls' ], '2>', \$err_out );
858852
859853 The subroutine will be called each time some data is read from the child.
860854
861855 The >pipe operator is different in concept than the other '>' operators,
862856 although it's syntax is similar:
863857
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 ;
858 $h = start \@cat, $in, '>pipe', \*OUT, '2>pipe', \*ERR;
859 $in = "hello world\n";
860 finish $h;
861 print <OUT>;
862 print <ERR>;
863 close OUT;
864 close ERR;
871865
872866 causes two pipe to be created, with one end attached to cat's stdout
873867 and stderr, respectively, and the other left open on OUT and ERR, so
893887 This closes descriptor number n (default is 0 if n is omitted). The
894888 following commands are equivalent:
895889
896 run \@cmd, \undef ;
897 run \@cmd, '<&-' ;
898 run \@cmd, '<in.txt', '<&-' ;
890 run \@cmd, \undef;
891 run \@cmd, '<&-';
892 run \@cmd, '<in.txt', '<&-';
899893
900894 Doing
901895
902 run \@cmd, \$in, '<&-' ; ## SIGPIPE recipe.
896 run \@cmd, \$in, '<&-'; ## SIGPIPE recipe.
903897
904898 is dangerous: the parent will get a SIGPIPE if $in is not empty.
905899
907901
908902 The following pairs of commands are equivalent:
909903
910 run \@cmd, '>&', \$out ; run \@cmd, '>', \$out, '2>&1' ;
911 run \@cmd, '>&', 'out.txt' ; run \@cmd, '>', 'out.txt', '2>&1' ;
904 run \@cmd, '>&', \$out; run \@cmd, '>', \$out, '2>&1';
905 run \@cmd, '>&', 'out.txt'; run \@cmd, '>', 'out.txt', '2>&1';
912906
913907 etc.
914908
931925 \@cmd
932926 '<', \&in_filter_2, \&in_filter_1, $in,
933927 '>', \&out_filter_1, \&in_filter_2, $out,
934 ) ;
928 );
935929
936930 This capability is not provided for IO handles or named files.
937931
943937 \@cmd
944938 '<', new_appender( "\n" ), $in,
945939 '>', new_chunker, $out,
946 ) ;
940 );
947941
948942 =back
949943
953947 may specify a filehandle or filename instead of a command in the harness
954948 specification:
955949
956 run io( "filename", '>', \$recv ) ;
957
958 $h = start io( $io, '>', \$recv ) ;
959
960 $h = harness \@cmd, '&', io( "file", '<', \$send ) ;
950 run io( "filename", '>', \$recv );
951
952 $h = start io( $io, '>', \$recv );
953
954 $h = harness \@cmd, '&', io( "file", '<', \$send );
961955
962956 =head2 Options
963957
964958 Options are passed in as name/value pairs:
965959
966 run \@cat, \$in, debug => 1 ;
960 run \@cat, \$in, debug => 1;
967961
968962 If you pass the debug option, you may want to pass it in first, so you
969963 can see what parsing is going on:
970964
971 run debug => 1, \@cat, \$in ;
965 run debug => 1, \@cat, \$in;
972966
973967 =over
974968
987981 blessed in to the IPC::Run package, so you may make later calls to
988982 functions as members if you like:
989983
990 $h = harness( ... ) ;
991 $h->start ;
992 $h->pump ;
993 $h->finish ;
994
995 $h = start( .... ) ;
996 $h->pump ;
984 $h = harness( ... );
985 $h->start;
986 $h->pump;
987 $h->finish;
988
989 $h = start( .... );
990 $h->pump;
997991 ...
998992
999993 Of course, using method call syntax lets you deal with any IPC::Run
10141008
10151009 =cut
10161010
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
1011 use strict;
1012 use Exporter ();
1013 use vars qw{$VERSION @ISA @FILTER_IMP @FILTERS @API @EXPORT_OK %EXPORT_TAGS};
1014 BEGIN {
1015 $VERSION = '0.82';
1016 @ISA = qw{ Exporter };
1017
1018 ## We use @EXPORT for the end user's convenience: there's only one function
1019 ## exported, it's homonymous with the module, it's an unusual name, and
1020 ## it can be suppressed by "use IPC::Run ();".
1021 @FILTER_IMP = qw( input_avail get_more_input );
1022 @FILTERS = qw(
1023 new_appender
1024 new_chunker
1025 new_string_source
1026 new_string_sink
1027 );
1028 @API = qw(
1029 run
1030 harness start pump pumpable finish
1031 signal kill_kill reap_nb
1032 io timer timeout
1033 close_terminal
1034 binary
1035 );
1036 @EXPORT_OK = ( @API, @FILTER_IMP, @FILTERS, qw( Win32_MODE ) );
1037 %EXPORT_TAGS = (
1038 'filter_imp' => \@FILTER_IMP,
1039 'all' => \@EXPORT_OK,
1040 'filters' => \@FILTERS,
1041 'api' => \@API,
1042 );
1043
1044 }
1045
1046 use strict;
10491047 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 ;
1048 use Exporter;
1049 use Fcntl;
1050 use POSIX ();
1051 use Symbol;
1052 use Carp;
1053 use File::Spec ();
1054 use IO::Handle;
1055 require IPC::Run::IO;
1056 require IPC::Run::Timer;
1057 use UNIVERSAL ();
1058
1059 use constant Win32_MODE => $^O =~ /os2|Win32/i;
10621060
10631061 BEGIN {
10641062 if ( Win32_MODE ) {
10651063 eval "use IPC::Run::Win32Helper; 1;"
1066 or ( $@ && die ) or die "$!" ;
1064 or ( $@ && die ) or die "$!";
10671065 }
10681066 else {
1069 eval "use File::Basename; 1;" or die $! ;
1070 }
1071 }
1072
1073
1074 sub input_avail() ;
1075 sub get_more_input() ;
1067 eval "use File::Basename; 1;" or die $!;
1068 }
1069 }
1070
1071 sub input_avail();
1072 sub get_more_input();
10761073
10771074 ###############################################################################
10781075
10911088 ## we aren't all that rigorous about closing these off, but that's ok. This
10921089 ## is used on Unixish OSs to close all fds in the child that aren't needed
10931090 ## by that particular child.
1094 my %fds ;
1091 my %fds;
10951092
10961093 ## There's a bit of hackery going on here.
10971094 ##
11021099 ##
11031100 ## Thus, $cur_self was born.
11041101
1105 use vars qw( $cur_self ) ;
1102 use vars qw( $cur_self );
11061103
11071104 sub _debug_fd {
1108 return fileno STDERR unless defined $cur_self ;
1105 return fileno STDERR unless defined $cur_self;
11091106
11101107 if ( _debugging && ! defined $cur_self->{DEBUG_FD} ) {
1111 my $fd = select STDERR ; $| = 1 ; select $fd ;
1112 $cur_self->{DEBUG_FD} = POSIX::dup fileno STDERR ;
1108 my $fd = select STDERR; $| = 1; select $fd;
1109 $cur_self->{DEBUG_FD} = POSIX::dup fileno STDERR;
11131110 _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} ;
1111 if _debugging_details;
1112 }
1113
1114 return fileno STDERR unless defined $cur_self->{DEBUG_FD};
11181115
11191116 return $cur_self->{DEBUG_FD}
11201117 }
11231120 ## We absolutely do not want to do anything else here. We are likely
11241121 ## to be in a child process and we don't want to do things like kill_kill
11251122 ## 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 ;
1123 my IPC::Run $self = shift;
1124 POSIX::close $self->{DEBUG_FD} if defined $self->{DEBUG_FD};
1125 $self->{DEBUG_FD} = undef;
11291126 }
11301127
11311128 ##
11321129 ## Support routines (NOT METHODS)
11331130 ##
1134 my %cmd_cache ;
1131 my %cmd_cache;
11351132
11361133 sub _search_path {
1137 my ( $cmd_name ) = @_ ;
1134 my ( $cmd_name ) = @_;
11381135 if ( File::Spec->file_name_is_absolute( $cmd_name ) && -x $cmd_name) {
11391136 _debug "'", $cmd_name, "' is absolute"
1140 if _debugging_details ;
1141 return $cmd_name ;
1137 if _debugging_details;
1138 return $cmd_name;
11421139 }
11431140
11441141 my $dirsep =
11491146 : $^O =~ /VMS/
11501147 ? '[\[\]]'
11511148 : '/'
1152 ) ;
1149 );
11531150
11541151 if ( Win32_MODE
11551152 && ( $cmd_name =~ /$dirsep/ )
11631160
11641161 if ( $cmd_name =~ /($dirsep)/ ) {
11651162 _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 ;
1163 croak "file not found: $cmd_name" unless -e $cmd_name;
1164 croak "not a file: $cmd_name" unless -f $cmd_name;
1165 croak "permission denied: $cmd_name" unless -x $cmd_name;
1166 return $cmd_name;
11701167 }
11711168
11721169 if ( exists $cmd_cache{$cmd_name} ) {
11731170 _debug "'$cmd_name' found in cache: '$cmd_cache{$cmd_name}'"
11741171 if _debugging;
1175 return $cmd_cache{$cmd_name} if -x $cmd_cache{$cmd_name} ;
1172 return $cmd_cache{$cmd_name} if -x $cmd_cache{$cmd_name};
11761173 _debug "'$cmd_cache{$cmd_name}' no longer executable, searching..."
11771174 if _debugging;
1178 delete $cmd_cache{$cmd_name} ;
1179 }
1180
1181 my @searched_in ;
1175 delete $cmd_cache{$cmd_name};
1176 }
1177
1178 my @searched_in;
11821179
11831180 ## This next bit is Unix/Win32 specific, unfortunately.
11841181 ## There's been some conversation about extending File::Spec to provide
11851182 ## a universal interface to PATH, but I haven't seen it yet.
1186 my $re = Win32_MODE ? qr/;/ : qr/:/ ;
1183 my $re = Win32_MODE ? qr/;/ : qr/:/;
11871184
11881185 LOOP:
11891186 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 ;
1187 $_ = "." unless length $_;
1188 push @searched_in, $_;
1189
1190 my $prospect = File::Spec->catfile( $_, $cmd_name );
1191 my @prospects;
11951192
11961193 @prospects =
11971194 ( Win32_MODE && ! ( -f $prospect && -x _ ) )
11981195 ? map "$prospect$_", split /;/, $ENV{PATHEXT} || ".COM;.BAT;.EXE"
1199 : ( $prospect ) ;
1196 : ( $prospect );
12001197
12011198 for my $found ( @prospects ) {
12021199 if ( -f $found && -x _ ) {
1203 $cmd_cache{$cmd_name} = $found ;
1204 last LOOP ;
1200 $cmd_cache{$cmd_name} = $found;
1201 last LOOP;
12051202 }
12061203 }
12071204 }
12081205
12091206 if ( exists $cmd_cache{$cmd_name} ) {
12101207 _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 ) ;
1208 if _debugging_details;
1209 return $cmd_cache{$cmd_name};
1210 }
1211
1212 croak "Command '$cmd_name' not found in " . join( ", ", @searched_in );
12161213 }
12171214
12181215
12201217
12211218 ## 'safe' versions of otherwise fun things to do. See also IPC::Run::Win32Helper.
12221219 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 ;
1220 confess 'undef' unless defined $_[0];
1221 no strict 'refs';
1222 my $fd = $_[0] =~ /^\d+$/ ? $_[0] : fileno $_[0];
1223 my $r = POSIX::close $fd;
1224 $r = $r ? '' : " ERROR $!";
1225 delete $fds{$fd};
1226 _debug "close( $fd ) = " . ( $r || 0 ) if _debugging_details;
12301227 }
12311228
12321229 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 ;
1230 confess 'undef' unless defined $_[0];
1231 my $r = POSIX::dup( $_[0] );
1232 croak "$!: dup( $_[0] )" unless defined $r;
1233 $r = 0 if $r eq '0 but true';
1234 _debug "dup( $_[0] ) = $r" if _debugging_details;
1235 $fds{$r} = 1;
1236 return $r;
12401237 }
12411238
12421239
12431240 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 ;
1241 confess 'undef' unless defined $_[0] && defined $_[1];
1242 my $r = POSIX::dup2( $_[0], $_[1] );
1243 croak "$!: dup2( $_[0], $_[1] )" unless defined $r;
1244 $r = 0 if $r eq '0 but true';
1245 _debug "dup2( $_[0], $_[1] ) = $r" if _debugging_details;
1246 $fds{$r} = 1;
1247 return $r;
12511248 }
12521249
12531250 sub _exec {
1254 confess 'undef passed' if grep !defined, @_ ;
1255 # exec @_ or croak "$!: exec( " . join( ', ', @_ ) . " )" ;
1256 _debug 'exec()ing ', join " ", map "'$_'", @_ if _debugging_details ;
1251 confess 'undef passed' if grep !defined, @_;
1252 # exec @_ or croak "$!: exec( " . join( ', ', @_ ) . " )";
1253 _debug 'exec()ing ', join " ", map "'$_'", @_ if _debugging_details;
12571254
12581255 # {
12591256 ## Commented out since we don't call this on Win32.
12611258 # # "Can't exec ...: No error" after an exec on NT, where
12621259 # # exec() is simulated and actually returns in Perl's C
12631260 # # code, though Perl's &exec does not...
1264 # no warnings "exec" ;
1261 # no warnings "exec";
12651262 #
12661263 # # Just in case the no warnings workaround
12671264 # # stops beign a workaround, we don't want
12681265 # # old values of $! causing spurious strerr()
12691266 # # messages to appear in the "Can't exec" message
1270 # undef $! ;
1271 exec @_ ;
1267 # undef $!;
1268 exec @_;
12721269 # }
1273 # croak "$!: exec( " . join( ', ', map "'$_'", @_ ) . " )" ;
1270 # croak "$!: exec( " . join( ', ', map "'$_'", @_ ) . " )";
12741271 ## Fall through so $! can be reported to parent.
12751272 }
12761273
12771274
12781275 sub _sysopen {
1279 confess 'undef' unless defined $_[0] && defined $_[1] ;
1276 confess 'undef' unless defined $_[0] && defined $_[1];
12801277 _debug sprintf( "O_RDONLY=0x%02x ", O_RDONLY ),
12811278 sprintf( "O_WRONLY=0x%02x ", O_WRONLY ),
12821279 sprintf( "O_RDWR=0x%02x ", O_RDWR ),
12831280 sprintf( "O_TRUNC=0x%02x ", O_TRUNC),
12841281 sprintf( "O_CREAT=0x%02x ", O_CREAT),
12851282 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 ;
1283 if _debugging_details;
1284 my $r = POSIX::open( $_[0], $_[1], 0644 );
1285 croak "$!: open( $_[0], ", sprintf( "0x%03x", $_[1] ), " )" unless defined $r;
12891286 _debug "open( $_[0], ", sprintf( "0x%03x", $_[1] ), " ) = $r"
1290 if _debugging_data ;
1291 $fds{$r} = 1 ;
1292 return $r ;
1287 if _debugging_data;
1288 $fds{$r} = 1;
1289 return $r;
12931290 }
12941291
12951292 sub _pipe {
12961293 ## Normal, blocking write for pipes that we read and the child writes,
12971294 ## since most children expect writes to stdout to block rather than
12981295 ## 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 ) ;
1296 my ( $r, $w ) = POSIX::pipe;
1297 croak "$!: pipe()" unless defined $r;
1298 _debug "pipe() = ( $r, $w ) " if _debugging_details;
1299 $fds{$r} = $fds{$w} = 1;
1300 return ( $r, $w );
13041301 }
13051302
13061303 sub _pipe_nb {
13081305 ## and continue to select().
13091306 ## Contributed by Borislav Deianov <borislav@ensim.com>, with minor
13101307 ## 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 ;
1308 local ( *R, *W );
1309 my $f = pipe( R, W );
1310 croak "$!: pipe()" unless defined $f;
1311 my ( $r, $w ) = ( fileno R, fileno W );
1312 _debug "pipe_nb pipe() = ( $r, $w )" if _debugging_details;
13161313 unless ( Win32_MODE ) {
13171314 ## POSIX::fcntl doesn't take fd numbers, so gotta use Perl's and
13181315 ## then _dup the originals (which get closed on leaving this block)
13191316 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 ) ;
1317 croak "$!: fcntl( $w, F_SETFL, O_NONBLOCK )" unless $fres;
1318 _debug "fcntl( $w, F_SETFL, O_NONBLOCK )" if _debugging_details;
1319 }
1320 ( $r, $w ) = ( _dup( $r ), _dup( $w ) );
1321 _debug "pipe_nb() = ( $r, $w )" if _debugging_details;
1322 return ( $r, $w );
13261323 }
13271324
13281325 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 )" ;
1326 require IO::Pty;
1327 my $pty = IO::Pty->new();
1328 croak "$!: pty ()" unless $pty;
1329 $pty->autoflush();
1330 $pty->blocking( 0 ) or croak "$!: pty->blocking ( 0 )";
13341331 _debug "pty() = ( ", $pty->fileno, ", ", $pty->slave->fileno, " )"
1335 if _debugging_details ;
1336 $fds{$pty->fileno} = $fds{$pty->slave->fileno} = 1 ;
1337 return $pty ;
1332 if _debugging_details;
1333 $fds{$pty->fileno} = $fds{$pty->slave->fileno} = 1;
1334 return $pty;
13381335 }
13391336
13401337
13411338 sub _read {
1342 confess 'undef' unless defined $_[0] ;
1343 my $s = '' ;
1344 my $r = POSIX::read( $_[0], $s, 10_000 ) ;
1339 confess 'undef' unless defined $_[0];
1340 my $s = '';
1341 my $r = POSIX::read( $_[0], $s, 10_000 );
13451342 croak "$!: read( $_[0] )" if not($r) and $! != POSIX::EINTR;
13461343 $r ||= 0;
1347 _debug "read( $_[0] ) = $r chars '$s'" if _debugging_data ;
1348 return $s ;
1344 _debug "read( $_[0] ) = $r chars '$s'" if _debugging_data;
1345 return $s;
13491346 }
13501347
13511348
13521349 ## A METHOD, not a function.
13531350 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} ;
1351 my IPC::Run $self = shift;
1352 my ( $kid ) = @_;
1353
1354 _debug "opening sync pipe ", $kid->{PID} if _debugging_details;
1355 my $sync_reader_fd;
1356 ( $sync_reader_fd, $self->{SYNC_WRITER_FD} ) = _pipe;
1357 $kid->{PID} = fork();
1358 croak "$! during fork" unless defined $kid->{PID};
13621359
13631360 unless ( $kid->{PID} ) {
13641361 ## _do_kid_and_exit closes sync_reader_fd since it closes all unwanted and
13651362 ## unloved fds.
1366 $self->_do_kid_and_exit( $kid ) ;
1367 }
1368 _debug "fork() = ", $kid->{PID} if _debugging_details ;
1363 $self->_do_kid_and_exit( $kid );
1364 }
1365 _debug "fork() = ", $kid->{PID} if _debugging_details;
13691366
13701367 ## 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 ;
1368 _close $self->{SYNC_WRITER_FD};
1369 my $sync_pulse = _read $sync_reader_fd;
1370 _close $sync_reader_fd;
13741371
13751372 if ( ! defined $sync_pulse || length $sync_pulse ) {
13761373 if ( waitpid( $kid->{PID}, 0 ) >= 0 ) {
1377 $kid->{RESULT} = $? ;
1374 $kid->{RESULT} = $?;
13781375 }
13791376 else {
1380 $kid->{RESULT} = -1 ;
1377 $kid->{RESULT} = -1;
13811378 }
13821379 $sync_pulse =
13831380 "error reading synchronization pipe for $kid->{NUM}, pid $kid->{PID}"
1384 unless length $sync_pulse ;
1385 croak $sync_pulse ;
1386 }
1387 return $kid->{PID} ;
1381 unless length $sync_pulse;
1382 croak $sync_pulse;
1383 }
1384 return $kid->{PID};
13881385
13891386 ## Wait for pty to get set up. This is a hack until we get synchronous
13901387 ## selects.
13911388 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 ;
1389 _debug "sleeping to give pty a chance to init, will fix when newer IO::Pty arrives.";
1390 sleep 1;
13941391 }
13951392 }
13961393
13971394
13981395 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
1396 confess 'undef' unless defined $_[0] && defined $_[1];
1397 my $r = POSIX::write( $_[0], $_[1], length $_[1] );
1398 croak "$!: write( $_[0], '$_[1]' )" unless $r;
1399 _debug "write( $_[0], '$_[1]' ) = $r" if _debugging_data;
1400 return $r;
1401 }
1402
1403 =pod
14061404
14071405 =item run
14081406
14141412
14151413 You may think of C<run( ... )> as being like
14161414
1417 start( ... )->finish() ;
1415 start( ... )->finish();
14181416
14191417 , though there is one subtle difference: run() does not
14201418 set \$input_scalars to '' like finish() does. If an exception is thrown
14261424
14271425 =cut
14281426
1429 use vars qw( $in_run ); ## No, not Enron ;)
1427 use vars qw( $in_run ); ## No, not Enron;)
14301428
14311429 sub run {
14321430 local $in_run = 1; ## Allow run()-only optimizations.
14331431 my IPC::Run $self = start( @_ );
14341432 my $r = eval {
1435 $self->{clear_ins} = 0 ;
1436 $self->finish ;
1437 } ;
1433 $self->{clear_ins} = 0;
1434 $self->finish;
1435 };
14381436 if ( $@ ) {
1439 my $x = $@ ;
1440 $self->kill_kill ;
1441 die $x ;
1442 }
1443 return $r ;
1444 }
1445
1437 my $x = $@;
1438 $self->kill_kill;
1439 die $x;
1440 }
1441 return $r;
1442 }
1443
1444 =pod
14461445
14471446 =item signal
14481447
14491448 ## To send it a specific signal by name ("USR1"):
1450 signal $h, "USR1" ;
1451 $h->signal ( "USR1" ) ;
1449 signal $h, "USR1";
1450 $h->signal ( "USR1" );
14521451
14531452 If $signal is provided and defined, sends a signal to all child processes. Try
14541453 not to send numeric signals, use C<"KILL"> instead of C<9>, for instance.
14781477 entering the signal handler, altering the flag's value in the
14791478 handler, and responding to the changed value in the main system:
14801479
1481 my $got_usr1 = 0 ;
1480 my $got_usr1 = 0;
14821481 sub usr1_handler { ++$got_signal }
14831482
1484 $SIG{USR1} = \&usr1_handler ;
1485 while () { sleep 1 ; print "GOT IT" while $got_usr1-- ; }
1483 $SIG{USR1} = \&usr1_handler;
1484 while () { sleep 1; print "GOT IT" while $got_usr1--; }
14861485
14871486 Even this approach is perilous if ++ and -- aren't atomic on your system
14881487 (I've never heard of this on any modern CPU large enough to run perl).
14901489 =cut
14911490
14921491 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 ;
1492 my IPC::Run $self = shift;
1493
1494 local $cur_self = $self;
1495
1496 $self->_kill_kill_kill_pussycat_kill unless @_;
1497
1498 Carp::cluck "Ignoring extra parameters passed to kill()" if @_ > 1;
1499
1500 my ( $signal ) = @_;
1501 croak "Undefined signal passed to signal" unless defined $signal;
15031502 for ( grep $_->{PID} && ! defined $_->{RESULT}, @{$self->{KIDS}} ) {
15041503 _debug "sending $signal to $_->{PID}"
15051504 if _debugging;
15061505 kill $signal, $_->{PID}
1507 or _debugging && _debug "$! sending $signal to $_->{PID}" ;
1506 or _debugging && _debug "$! sending $signal to $_->{PID}";
15081507 }
15091508
1510 return ;
1511 }
1512
1509 return;
1510 }
1511
1512 =pod
15131513
15141514 =item kill_kill
15151515
15161516 ## To kill off a process:
1517 $h->kill_kill ;
1518 kill_kill $h ;
1517 $h->kill_kill;
1518 kill_kill $h;
15191519
15201520 ## To specify the grace period other than 30 seconds:
1521 kill_kill $h, grace => 5 ;
1521 kill_kill $h, grace => 5;
15221522
15231523 ## To send QUIT instead of KILL if a process refuses to die:
1524 kill_kill $h, coup_d_grace => "QUIT" ;
1524 kill_kill $h, coup_d_grace => "QUIT";
15251525
15261526 Sends a C<TERM>, waits for all children to exit for up to 30 seconds, then
15271527 sends a C<KILL> to any that survived the C<TERM>.
15521552 =cut
15531553
15541554 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 ) ;
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 );
15661566 Carp::cluck "Ignoring unknown options for kill_kill: ",
15671567 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 ;
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;
15771577
15781578 while () {
15791579 ## 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 ;
1580 select undef, undef, undef, $delay;
1581 $accum_delay += $delay;
1582
1583 $self->reap_nb;
1584 last unless $self->_running_kids;
15851585
15861586 if ( $accum_delay >= $grace*0.8 ) {
15871587 ## No point in checking until delay has grown some.
15881588 if ( time >= $quitting_time ) {
15891589 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 ;
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;
15961596 }
15971597 croak "Unable to reap all children, even after KILLing them"
15981598 }
15991599 }
16001600
1601 $delay *= 2 ;
1602 $delay = 0.5 if $delay >= 0.5 ;
1603 }
1604
1605 $self->_cleanup ;
1606 return $have_killed_before ;
1607 }
1608
1601 $delay *= 2;
1602 $delay = 0.5 if $delay >= 0.5;
1603 }
1604
1605 $self->_cleanup;
1606 return $have_killed_before;
1607 }
1608
1609 =pod
16091610
16101611 =item harness
16111612
16331634 ## lexical scope hash, or per instance? 'Course they can do that
16341635 ## now by using a [...] to hold the command.
16351636 ##
1636 my $harness_id = 0 ;
1637 my $harness_id = 0;
16371638 sub harness {
1638 my $options ;
1639 my $options;
16391640 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 ) ;
1641 $options = pop;
1642 require Data::Dumper;
1643 carp "Passing in options as a hash is deprecated:\n", Data::Dumper::Dumper( $options );
16431644 }
16441645
16451646 # local $IPC::Run::debug = $options->{debug}
1646 # if $options && defined $options->{debug} ;
1647
1648 my @args ;
1647 # if $options && defined $options->{debug};
1648
1649 my @args;
16491650
16501651 if ( @_ == 1 && ! ref $_[0] ) {
16511652 if ( Win32_MODE ) {
1652 @args = ( [ qw( command /c ), win32_parse_cmd_line $_[0] ] ) ;
1653 @args = ( [ qw( command /c ), win32_parse_cmd_line $_[0] ] );
16531654 }
16541655 else {
1655 @args = ( [ qw( sh -c ), @_ ] ) ;
1656 @args = ( [ qw( sh -c ), @_ ] );
16561657 }
16571658 }
16581659 elsif ( @_ > 1 && ! grep ref $_, @_ ) {
1659 @args = ( [ @_ ] ) ;
1660 @args = ( [ @_ ] );
16601661 }
16611662 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
1663 @args = @_;
1664 }
1665
1666 my @errs; # Accum errors, emit them when done.
1667
1668 my $succinct; # set if no redir ops are required yet. Cleared
16681669 # if an op is seen.
16691670
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
1671 my $cur_kid; # references kid or handle being parsed
1672
1673 my $assumed_fd = 0; # fd to assume in succinct mode (no redir ops)
1674 my $handle_num = 0; # 1... is which handle we're parsing
16741675
16751676 my IPC::Run $self = bless {}, __PACKAGE__;
16761677
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 ;
1678 local $cur_self = $self;
1679
1680 $self->{ID} = ++$harness_id;
1681 $self->{IOS} = [];
1682 $self->{KIDS} = [];
1683 $self->{PIPES} = [];
1684 $self->{PTYS} = {};
1685 $self->{STATE} = _newed;
16851686
16861687 if ( $options ) {
16871688 $self->{$_} = $options->{$_}
1688 for keys %$options ;
1689 for keys %$options;
16891690 }
16901691
16911692 _debug "****** harnessing *****" if _debugging;
16921693
1693 my $first_parse ;
1694 local $_ ;
1695 my $arg_count = @args ;
1694 my $first_parse;
1695 local $_;
1696 my $arg_count = @args;
16961697 while ( @args ) { for ( shift @args ) {
16971698 eval {
1698 $first_parse = 1 ;
1699 $first_parse = 1;
16991700 _debug(
17001701 "parsing ",
17011702 defined $_
17121713
17131714 REPARSE:
17141715 if ( ref eq 'ARRAY' || ( ! $cur_kid && ref eq 'CODE' ) ) {
1715 croak "Process control symbol ('|', '&') missing" if $cur_kid ;
1716 croak "Process control symbol ('|', '&') missing" if $cur_kid;
17161717 croak "Can't spawn a subroutine on Win32"
1717 if Win32_MODE && ref eq "CODE" ;
1718 if Win32_MODE && ref eq "CODE";
17181719 $cur_kid = {
17191720 TYPE => 'cmd',
17201721 VAL => $_,
17221723 OPS => [],
17231724 PID => '',
17241725 RESULT => undef,
1725 } ;
1726 push @{$self->{KIDS}}, $cur_kid ;
1727 $succinct = 1 ;
1726 };
1727 push @{$self->{KIDS}}, $cur_kid;
1728 $succinct = 1;
17281729 }
17291730
1730 elsif ( isa( $_, 'IPC::Run::IO' ) ) {
1731 push @{$self->{IOS}}, $_ ;
1732 $cur_kid = undef ;
1733 $succinct = 1 ;
1731 elsif ( UNIVERSAL::isa( $_, 'IPC::Run::IO' ) ) {
1732 push @{$self->{IOS}}, $_;
1733 $cur_kid = undef;
1734 $succinct = 1;
17341735 }
17351736
1736 elsif ( isa( $_, 'IPC::Run::Timer' ) ) {
1737 push @{$self->{TIMERS}}, $_ ;
1738 $cur_kid = undef ;
1739 $succinct = 1 ;
1737 elsif ( UNIVERSAL::isa( $_, 'IPC::Run::Timer' ) ) {
1738 push @{$self->{TIMERS}}, $_;
1739 $cur_kid = undef;
1740 $succinct = 1;
17401741 }
17411742
17421743 elsif ( /^(\d*)>&(\d+)$/ ) {
1743 croak "No command before '$_'" unless $cur_kid ;
1744 croak "No command before '$_'" unless $cur_kid;
17441745 push @{$cur_kid->{OPS}}, {
17451746 TYPE => 'dup',
17461747 KFD1 => $2,
17471748 KFD2 => length $1 ? $1 : 1,
1748 } ;
1749 _debug "redirect operators now required" if _debugging_details ;
1750 $succinct = ! $first_parse ;
1749 };
1750 _debug "redirect operators now required" if _debugging_details;
1751 $succinct = ! $first_parse;
17511752 }
17521753
17531754 elsif ( /^(\d*)<&(\d+)$/ ) {
1754 croak "No command before '$_'" unless $cur_kid ;
1755 croak "No command before '$_'" unless $cur_kid;
17551756 push @{$cur_kid->{OPS}}, {
17561757 TYPE => 'dup',
17571758 KFD1 => $2,
17581759 KFD2 => length $1 ? $1 : 0,
1759 } ;
1760 $succinct = ! $first_parse ;
1760 };
1761 $succinct = ! $first_parse;
17611762 }
17621763
17631764 elsif ( /^(\d*)<&-$/ ) {
1764 croak "No command before '$_'" unless $cur_kid ;
1765 croak "No command before '$_'" unless $cur_kid;
17651766 push @{$cur_kid->{OPS}}, {
17661767 TYPE => 'close',
17671768 KFD => length $1 ? $1 : 0,
1768 } ;
1769 $succinct = ! $first_parse ;
1769 };
1770 $succinct = ! $first_parse;
17701771 }
17711772
17721773 elsif (
17741775 || /^(\d*) (<pty) ((?:\s+\S+)?) (<) () $/x
17751776 || /^(\d*) (<) () () (.*)$/x
17761777 ) {
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 ;
1778 croak "No command before '$_'" unless $cur_kid;
1779
1780 $succinct = ! $first_parse;
1781
1782 my $type = $2 . $4;
1783
1784 my $kfd = length $1 ? $1 : 0;
1785
1786 my $pty_id;
17861787 if ( $type eq '<pty<' ) {
1787 $pty_id = length $3 ? $3 : '0' ;
1788 $pty_id = length $3 ? $3 : '0';
17881789 ## do the require here to cause early error reporting
1789 require IO::Pty ;
1790 require IO::Pty;
17901791 ## Just flag the pyt's existence for now. It'll be
17911792 ## converted to a real IO::Pty by _open_pipes.
1792 $self->{PTYS}->{$pty_id} = undef ;
1793 $self->{PTYS}->{$pty_id} = undef;
17931794 }
17941795
1795 my $source = $5 ;
1796
1797 my @filters ;
1798 my $binmode ;
1796 my $source = $5;
1797
1798 my @filters;
1799 my $binmode;
17991800
18001801 unless ( length $source ) {
18011802 if ( ! $succinct ) {
18021803 while ( @args > 1
18031804 && (
1804 ( ref $args[1] && ! isa $args[1], "IPC::Run::Timer" )
1805 || isa $args[0], "IPC::Run::binmode_pseudo_filter"
1805 ( ref $args[1] && ! UNIVERSAL::isa $args[1], "IPC::Run::Timer" )
1806 || UNIVERSAL::isa $args[0], "IPC::Run::binmode_pseudo_filter"
18061807 )
18071808 ) {
1808 if ( isa $args[0], "IPC::Run::binmode_pseudo_filter" ) {
1809 $binmode = shift( @args )->() ;
1809 if ( UNIVERSAL::isa $args[0], "IPC::Run::binmode_pseudo_filter" ) {
1810 $binmode = shift( @args )->();
18101811 }
18111812 else {
18121813 push @filters, shift @args
18131814 }
18141815 }
18151816 }
1816 $source = shift @args ;
1817 croak "'$_' missing a source" if _empty $source ;
1817 $source = shift @args;
1818 croak "'$_' missing a source" if _empty $source;
18181819
18191820 _debug(
18201821 'Kid ', $cur_kid->{NUM}, "'s input fd ", $kfd,
18211822 ' has ', scalar( @filters ), ' filters.'
1822 ) if _debugging_details && @filters ;
1823 } ;
1823 ) if _debugging_details && @filters;
1824 };
18241825
18251826 my IPC::Run::IO $pipe = IPC::Run::IO->_new_internal(
18261827 $type, $kfd, $pty_id, $source, $binmode, @filters
1827 ) ;
1828
1829 if ( ( ref $source eq 'GLOB' || isa $source, 'IO::Handle' )
1828 );
1829
1830 if ( ( ref $source eq 'GLOB' || UNIVERSAL::isa $source, 'IO::Handle' )
18301831 && $type !~ /^<p(ty<|ipe)$/
18311832 ) {
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 ;
1833 _debug "setting DONT_CLOSE" if _debugging_details;
1834 $pipe->{DONT_CLOSE} = 1; ## this FD is not closed by us.
1835 _dont_inherit( $source ) if Win32_MODE;
18351836 }
18361837
1837 push @{$cur_kid->{OPS}}, $pipe ;
1838 push @{$cur_kid->{OPS}}, $pipe;
18381839 }
18391840
18401841 elsif ( /^() (>>?) (&) () (.*)$/x
18471848 || /^() (&) (>>?) () (.*)$/x
18481849 || /^(\d*)() (>>?) () (.*)$/x
18491850 ) {
1850 croak "No command before '$_'" unless $cur_kid ;
1851
1852 $succinct = ! $first_parse ;
1851 croak "No command before '$_'" unless $cur_kid;
1852
1853 $succinct = ! $first_parse;
18531854
18541855 my $type = (
18551856 $2 eq '>pipe' || $3 eq '>pipe'
18571858 : $2 eq '>pty' || $3 eq '>pty'
18581859 ? '>pty>'
18591860 : '>'
1860 ) ;
1861 my $kfd = length $1 ? $1 : 1 ;
1862 my $trunc = ! ( $2 eq '>>' || $3 eq '>>' ) ;
1861 );
1862 my $kfd = length $1 ? $1 : 1;
1863 my $trunc = ! ( $2 eq '>>' || $3 eq '>>' );
18631864 my $pty_id = (
18641865 $2 eq '>pty' || $3 eq '>pty'
18651866 ? length $4 ? $4 : 0
18661867 : undef
1867 ) ;
1868 );
18681869
18691870 my $stderr_too =
18701871 $2 eq '&'
18711872 || $3 eq '&'
1872 || ( ! length $1 && substr( $type, 0, 4 ) eq '>pty' ) ;
1873
1874 my $dest = $5 ;
1875 my @filters ;
1876 my $binmode = 0 ;
1873 || ( ! length $1 && substr( $type, 0, 4 ) eq '>pty' );
1874
1875 my $dest = $5;
1876 my @filters;
1877 my $binmode = 0;
18771878 unless ( length $dest ) {
18781879 if ( ! $succinct ) {
18791880 ## unshift...shift: '>' filters source...sink left...right
18801881 while ( @args > 1
18811882 && (
1882 ( ref $args[1] && ! isa $args[1], "IPC::Run::Timer" )
1883 || isa $args[0], "IPC::Run::binmode_pseudo_filter"
1883 ( ref $args[1] && ! UNIVERSAL::isa $args[1], "IPC::Run::Timer" )
1884 || UNIVERSAL::isa $args[0], "IPC::Run::binmode_pseudo_filter"
18841885 )
18851886 ) {
1886 if ( isa $args[0], "IPC::Run::binmode_pseudo_filter" ) {
1887 $binmode = shift( @args )->() ;
1887 if ( UNIVERSAL::isa $args[0], "IPC::Run::binmode_pseudo_filter" ) {
1888 $binmode = shift( @args )->();
18881889 }
18891890 else {
1890 unshift @filters, shift @args ;
1891 unshift @filters, shift @args;
18911892 }
18921893 }
18931894 }
18941895
1895 $dest = shift @args ;
1896 $dest = shift @args;
18961897
18971898 _debug(
18981899 'Kid ', $cur_kid->{NUM}, "'s output fd ", $kfd,
18991900 ' has ', scalar( @filters ), ' filters.'
1900 ) if _debugging_details && @filters ;
1901 ) if _debugging_details && @filters;
19011902
19021903 if ( $type eq '>pty>' ) {
19031904 ## do the require here to cause early error reporting
1904 require IO::Pty ;
1905 require IO::Pty;
19051906 ## Just flag the pyt's existence for now. _open_pipes()
19061907 ## will new an IO::Pty for each key.
1907 $self->{PTYS}->{$pty_id} = undef ;
1908 $self->{PTYS}->{$pty_id} = undef;
19081909 }
19091910 }
19101911
1911 croak "'$_' missing a destination" if _empty $dest ;
1912 croak "'$_' missing a destination" if _empty $dest;
19121913 my $pipe = IPC::Run::IO->_new_internal(
19131914 $type, $kfd, $pty_id, $dest, $binmode, @filters
1914 ) ;
1915 $pipe->{TRUNC} = $trunc ;
1916
1917 if ( ( isa( $dest, 'GLOB' ) || isa( $dest, 'IO::Handle' ) )
1915 );
1916 $pipe->{TRUNC} = $trunc;
1917
1918 if ( ( UNIVERSAL::isa( $dest, 'GLOB' ) || UNIVERSAL::isa( $dest, 'IO::Handle' ) )
19181919 && $type !~ /^>(pty>|pipe)$/
19191920 ) {
1920 _debug "setting DONT_CLOSE" if _debugging_details ;
1921 $pipe->{DONT_CLOSE} = 1 ; ## this FD is not closed by us.
1921 _debug "setting DONT_CLOSE" if _debugging_details;
1922 $pipe->{DONT_CLOSE} = 1; ## this FD is not closed by us.
19221923 }
1923 push @{$cur_kid->{OPS}}, $pipe ;
1924 push @{$cur_kid->{OPS}}, $pipe;
19241925 push @{$cur_kid->{OPS}}, {
19251926 TYPE => 'dup',
19261927 KFD1 => 1,
19271928 KFD2 => 2,
1928 } if $stderr_too ;
1929 } if $stderr_too;
19291930 }
19301931
19311932 elsif ( $_ eq "|" ) {
1932 croak "No command before '$_'" unless $cur_kid ;
1933 croak "No command before '$_'" unless $cur_kid;
19331934 unshift @{$cur_kid->{OPS}}, {
19341935 TYPE => '|',
19351936 KFD => 1,
1936 } ;
1937 $succinct = 1 ;
1938 $assumed_fd = 1 ;
1939 $cur_kid = undef ;
1937 };
1938 $succinct = 1;
1939 $assumed_fd = 1;
1940 $cur_kid = undef;
19401941 }
19411942
19421943 elsif ( $_ eq "&" ) {
1943 croak "No command before '$_'" unless $cur_kid ;
1944 croak "No command before '$_'" unless $cur_kid;
19441945 unshift @{$cur_kid->{OPS}}, {
19451946 TYPE => 'close',
19461947 KFD => 0,
1947 } ;
1948 $succinct = 1 ;
1949 $assumed_fd = 0 ;
1950 $cur_kid = undef ;
1948 };
1949 $succinct = 1;
1950 $assumed_fd = 0;
1951 $cur_kid = undef;
19511952 }
19521953
19531954 elsif ( $_ eq 'init' ) {
1954 croak "No command before '$_'" unless $cur_kid ;
1955 croak "No command before '$_'" unless $cur_kid;
19551956 push @{$cur_kid->{OPS}}, {
19561957 TYPE => 'init',
19571958 SUB => shift @args,
1958 } ;
1959 };
19591960 }
19601961
19611962 elsif ( ! ref $_ ) {
19631964 }
19641965
19651966 elsif ( $_ eq 'init' ) {
1966 croak "No command before '$_'" unless $cur_kid ;
1967 croak "No command before '$_'" unless $cur_kid;
19671968 push @{$cur_kid->{OPS}}, {
19681969 TYPE => 'init',
19691970 SUB => shift @args,
1970 } ;
1971 };
19711972 }
19721973
19731974 elsif ( $succinct && $first_parse ) {
19741975 ## It's not an opcode, and no explicit opcodes have been
19751976 ## seen yet, so assume it's a file name.
1976 unshift @args, $_ ;
1977 unshift @args, $_;
19771978 if ( ! $assumed_fd ) {
19781979 $_ = "$assumed_fd<",
19791980 }
19801981 else {
19811982 $_ = "$assumed_fd>",
19821983 }
1983 _debug "assuming '", $_, "'" if _debugging_details ;
1984 ++$assumed_fd ;
1985 $first_parse = 0 ;
1986 goto REPARSE ;
1984 _debug "assuming '", $_, "'" if _debugging_details;
1985 ++$assumed_fd;
1986 $first_parse = 0;
1987 goto REPARSE;
19871988 }
19881989
19891990 else {
19931994 ( ref() ? $_ : 'scalar' ),
19941995 ' in harness() parameter ',
19951996 $arg_count - @args
1996 ) ;
1997 );
19971998 }
1998 } ;
1999 };
19992000 if ( $@ ) {
2000 push @errs, $@ ;
2001 push @errs, $@;
20012002 _debug 'caught ', $@ if _debugging;
20022003 }
20032004 } }
20042005
2005 die join( '', @errs ) if @errs ;
2006
2007
2008 $self->{STATE} = _harnessed ;
2009 # $self->timeout( $options->{timeout} ) if exists $options->{timeout} ;
2010 return $self ;
2006 die join( '', @errs ) if @errs;
2007
2008
2009 $self->{STATE} = _harnessed;
2010 # $self->timeout( $options->{timeout} ) if exists $options->{timeout};
2011 return $self;
20112012 }
20122013
20132014
20142015 sub _open_pipes {
2015 my IPC::Run $self = shift ;
2016
2017 my @errs ;
2018
2019 my @close_on_fail ;
2016 my IPC::Run $self = shift;
2017
2018 my @errs;
2019
2020 my @close_on_fail;
20202021
20212022 ## When a pipe character is seen, a pipe is created. $pipe_read_fd holds
20222023 ## the dangling read end of the pipe until we get to the next process.
2023 my $pipe_read_fd ;
2024 my $pipe_read_fd;
20242025
20252026 ## Output descriptors for the last command are shared by all children.
20262027 ## @output_fds_accum accumulates the current set of output fds.
2027 my @output_fds_accum ;
2028 my @output_fds_accum;
20282029
20292030 for ( sort keys %{$self->{PTYS}} ) {
2030 _debug "opening pty '", $_, "'" if _debugging_details ;
2031 my $pty = _pty ;
2032 $self->{PTYS}->{$_} = $pty ;
2031 _debug "opening pty '", $_, "'" if _debugging_details;
2032 my $pty = _pty;
2033 $self->{PTYS}->{$_} = $pty;
20332034 }
20342035
20352036 for ( @{$self->{IOS}} ) {
2036 eval { $_->init ; } ;
2037 eval { $_->init; };
20372038 if ( $@ ) {
2038 push @errs, $@ ;
2039 push @errs, $@;
20392040 _debug 'caught ', $@ if _debugging;
20402041 }
20412042 else {
2042 push @close_on_fail, $_ ;
2043 push @close_on_fail, $_;
20432044 }
20442045 }
20452046
20472048 ## parent-side actions.
20482049 for my $kid ( @{$self->{KIDS}} ) {
20492050 unless ( ref $kid->{VAL} eq 'CODE' ) {
2050 $kid->{PATH} = _search_path $kid->{VAL}->[0] ;
2051 $kid->{PATH} = _search_path $kid->{VAL}->[0];
20512052 }
20522053 if ( defined $pipe_read_fd ) {
20532054 _debug "placing write end of pipe on kid $kid->{NUM}'s stdin"
2054 if _debugging_details ;
2055 if _debugging_details;
20552056 unshift @{$kid->{OPS}}, {
20562057 TYPE => 'PIPE', ## Prevent next loop from triggering on this
20572058 KFD => 0,
20582059 TFD => $pipe_read_fd,
2059 } ;
2060 $pipe_read_fd = undef ;
2061 }
2062 @output_fds_accum = () ;
2060 };
2061 $pipe_read_fd = undef;
2062 }
2063 @output_fds_accum = ();
20632064 for my $op ( @{$kid->{OPS}} ) {
2064 # next if $op->{IS_DEBUG} ;
2065 # next if $op->{IS_DEBUG};
20652066 my $ok = eval {
20662067 if ( $op->{TYPE} eq '<' ) {
20672068 my $source = $op->{SOURCE};
20692070 _debug(
20702071 "kid ", $kid->{NUM}, " to read ", $op->{KFD},
20712072 " from '" . $source, "' (read only)"
2072 ) if _debugging_details ;
2073 ) if _debugging_details;
20732074 croak "simulated open failure"
2074 if $self->{_simulate_open_failure} ;
2075 $op->{TFD} = _sysopen( $source, O_RDONLY ) ;
2076 push @close_on_fail, $op->{TFD} ;
2075 if $self->{_simulate_open_failure};
2076 $op->{TFD} = _sysopen( $source, O_RDONLY );
2077 push @close_on_fail, $op->{TFD};
20772078 }
2078 elsif ( isa( $source, 'GLOB' )
2079 || isa( $source, 'IO::Handle' )
2079 elsif ( UNIVERSAL::isa( $source, 'GLOB' )
2080 || UNIVERSAL::isa( $source, 'IO::Handle' )
20802081 ) {
20812082 croak
20822083 "Unopened filehandle in input redirect for $op->{KFD}"
2083 unless defined fileno $source ;
2084 $op->{TFD} = fileno $source ;
2084 unless defined fileno $source;
2085 $op->{TFD} = fileno $source;
20852086 _debug(
20862087 "kid ", $kid->{NUM}, " to read ", $op->{KFD},
20872088 " from fd ", $op->{TFD}
2088 ) if _debugging_details ;
2089 ) if _debugging_details;
20892090 }
2090 elsif ( isa( $source, 'SCALAR' ) ) {
2091 elsif ( UNIVERSAL::isa( $source, 'SCALAR' ) ) {
20912092 _debug(
20922093 "kid ", $kid->{NUM}, " to read ", $op->{KFD},
20932094 " 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 ;
2095 ) if _debugging_details;
2096
2097 $op->open_pipe( $self->_debug_fd );
2098 push @close_on_fail, $op->{KFD}, $op->{FD};
2099
2100 my $s = '';
2101 $op->{KIN_REF} = \$s;
21012102 }
2102 elsif ( isa( $source, 'CODE' ) ) {
2103 elsif ( UNIVERSAL::isa( $source, 'CODE' ) ) {
21032104 _debug(
21042105 'kid ', $kid->{NUM}, ' to read ', $op->{KFD}, ' from CODE'
2105 ) if _debugging_details ;
2106 ) if _debugging_details;
21062107
2107 $op->open_pipe( $self->_debug_fd ) ;
2108 push @close_on_fail, $op->{KFD}, $op->{FD} ;
2108 $op->open_pipe( $self->_debug_fd );
2109 push @close_on_fail, $op->{KFD}, $op->{FD};
21092110
2110 my $s = '' ;
2111 $op->{KIN_REF} = \$s ;
2111 my $s = '';
2112 $op->{KIN_REF} = \$s;
21122113 }
21132114 else {
21142115 croak(
21152116 "'"
21162117 . ref( $source )
21172118 . "' not allowed as a source for input redirection"
2118 ) ;
2119 );
21192120 }
2120 $op->_init_filters ;
2121 $op->_init_filters;
21212122 }
21222123 elsif ( $op->{TYPE} eq '<pipe' ) {
21232124 _debug(
21242125 'kid to read ', $op->{KFD},
21252126 ' 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} ) ;
2127 ) if _debugging_details;
2128
2129 my ( $r, $w ) = $op->open_pipe( $self->_debug_fd, $op->{SOURCE} );
21292130 _debug "caller will write to ", fileno $op->{SOURCE}
21302131 if _debugging_details;
21312132
2132 $op->{TFD} = $r ;
2133 $op->{FD} = undef ; # we don't manage this fd
2134 $op->_init_filters ;
2133 $op->{TFD} = $r;
2134 $op->{FD} = undef; # we don't manage this fd
2135 $op->_init_filters;
21352136 }
21362137 elsif ( $op->{TYPE} eq '<pty<' ) {
21372138 _debug(
21382139 'kid to read ', $op->{KFD}, " from pty '", $op->{PTY_ID}, "'",
2139 ) if _debugging_details ;
2140 ) if _debugging_details;
21402141
21412142 for my $source ( $op->{SOURCE} ) {
2142 if ( isa( $source, 'SCALAR' ) ) {
2143 if ( UNIVERSAL::isa( $source, 'SCALAR' ) ) {
21432144 _debug(
21442145 "kid ", $kid->{NUM}, " to read ", $op->{KFD},
21452146 " from SCALAR via pty '", $op->{PTY_ID}, "'"
2146 ) if _debugging_details ;
2147
2148 my $s = '' ;
2149 $op->{KIN_REF} = \$s ;
2147 ) if _debugging_details;
2148
2149 my $s = '';
2150 $op->{KIN_REF} = \$s;
21502151 }
2151 elsif ( isa( $source, 'CODE' ) ) {
2152 elsif ( UNIVERSAL::isa( $source, 'CODE' ) ) {
21522153 _debug(
21532154 "kid ", $kid->{NUM}, " to read ", $op->{KFD},
21542155 " from CODE via pty '", $op->{PTY_ID}, "'"
2155 ) if _debugging_details ;
2156 my $s = '' ;
2157 $op->{KIN_REF} = \$s ;
2156 ) if _debugging_details;
2157 my $s = '';
2158 $op->{KIN_REF} = \$s;
21582159 }
21592160 else {
21602161 croak(
21612162 "'"
21622163 . ref( $source )
21632164 . "' not allowed as a source for '<pty<' redirection"
2164 ) ;
2165 );
21652166 }
21662167 }
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 ;
2168 $op->{FD} = $self->{PTYS}->{$op->{PTY_ID}}->fileno;
2169 $op->{TFD} = undef; # The fd isn't known until after fork().
2170 $op->_init_filters;
21702171 }
21712172 elsif ( $op->{TYPE} eq '>' ) {
21722173 ## N> output redirection.
2173 my $dest = $op->{DEST} ;
2174 my $dest = $op->{DEST};
21742175 if ( ! ref $dest ) {
21752176 _debug(
21762177 "kid ", $kid->{NUM}, " to write ", $op->{KFD},
21772178 " to '", $dest, "' (write only, create, ",
21782179 ( $op->{TRUNC} ? 'truncate' : 'append' ),
21792180 ")"
2180 ) if _debugging_details ;
2181 ) if _debugging_details;
21812182 croak "simulated open failure"
2182 if $self->{_simulate_open_failure} ;
2183 if $self->{_simulate_open_failure};
21832184 $op->{TFD} = _sysopen(
21842185 $dest,
21852186 ( O_WRONLY
21862187 | O_CREAT
21872188 | ( $op->{TRUNC} ? O_TRUNC : O_APPEND )
21882189 )
2189 ) ;
2190 );
21902191 if ( Win32_MODE ) {
21912192 ## I have no idea why this is needed to make the current
21922193 ## file position survive the gyrations TFD must go
21932194 ## through...
2194 POSIX::lseek( $op->{TFD}, 0, POSIX::SEEK_END() ) ;
2195 POSIX::lseek( $op->{TFD}, 0, POSIX::SEEK_END() );
21952196 }
2196 push @close_on_fail, $op->{TFD} ;
2197 push @close_on_fail, $op->{TFD};
21972198 }
2198 elsif ( isa( $dest, 'GLOB' ) ) {
2199 elsif ( UNIVERSAL::isa( $dest, 'GLOB' ) ) {
21992200 croak(
22002201 "Unopened filehandle in output redirect, command $kid->{NUM}"
2201 ) unless defined fileno $dest ;
2202 ) unless defined fileno $dest;
22022203 ## Turn on autoflush, mostly just to flush out
22032204 ## existing output.
2204 my $old_fh = select( $dest ) ; $| = 1 ; select( $old_fh ) ;
2205 $op->{TFD} = fileno $dest ;
2205 my $old_fh = select( $dest ); $| = 1; select( $old_fh );
2206 $op->{TFD} = fileno $dest;
22062207 _debug(
22072208 'kid to write ', $op->{KFD}, ' to handle ', $op->{TFD}
2208 ) if _debugging_details ;
2209 ) if _debugging_details;
22092210 }
2210 elsif ( isa( $dest, 'SCALAR' ) ) {
2211 elsif ( UNIVERSAL::isa( $dest, 'SCALAR' ) ) {
22112212 _debug(
22122213 "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} ;
2214 ) if _debugging_details;
2215
2216 $op->open_pipe( $self->_debug_fd );
2217 push @close_on_fail, $op->{FD}, $op->{TFD};
2218 $$dest = '' if $op->{TRUNC};
22182219 }
2219 elsif ( isa( $dest, 'CODE' ) ) {
2220 elsif ( UNIVERSAL::isa( $dest, 'CODE' ) ) {
22202221 _debug(
22212222 "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} ;
2223 ) if _debugging_details;
2224
2225 $op->open_pipe( $self->_debug_fd );
2226 push @close_on_fail, $op->{FD}, $op->{TFD};
22262227 }
22272228 else {
22282229 croak(
22292230 "'"
22302231 . ref( $dest )
22312232 . "' not allowed as a sink for output redirection"
2232 ) ;
2233 );
22332234 }
2234 $output_fds_accum[$op->{KFD}] = $op ;
2235 $op->_init_filters ;
2235 $output_fds_accum[$op->{KFD}] = $op;
2236 $op->_init_filters;
22362237 }
22372238
22382239 elsif ( $op->{TYPE} eq '>pipe' ) {
22412242 _debug(
22422243 "kid ", $kid->{NUM}, " to write ", $op->{KFD},
22432244 ' 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} ) ;
2245 ) if _debugging_details;
2246
2247 my ( $r, $w ) = $op->open_pipe( $self->_debug_fd, $op->{DEST} );
22472248 _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 ;
2249 if _debugging_details;
2250
2251 $op->{TFD} = $w;
2252 $op->{FD} = undef; # we don't manage this fd
2253 $op->_init_filters;
2254
2255 $output_fds_accum[$op->{KFD}] = $op;
22552256 }
22562257 elsif ( $op->{TYPE} eq '>pty>' ) {
2257 my $dest = $op->{DEST} ;
2258 if ( isa( $dest, 'SCALAR' ) ) {
2258 my $dest = $op->{DEST};
2259 if ( UNIVERSAL::isa( $dest, 'SCALAR' ) ) {
22592260 _debug(
22602261 "kid ", $kid->{NUM}, " to write ", $op->{KFD},
22612262 " to SCALAR via pty '", $op->{PTY_ID}, "'"
2262 ) if _debugging_details ;
2263
2264 $$dest = '' if $op->{TRUNC} ;
2263 ) if _debugging_details;
2264
2265 $$dest = '' if $op->{TRUNC};
22652266 }
2266 elsif ( isa( $dest, 'CODE' ) ) {
2267 elsif ( UNIVERSAL::isa( $dest, 'CODE' ) ) {
22672268 _debug(
22682269 "kid ", $kid->{NUM}, " to write ", $op->{KFD},
22692270 " to CODE via pty '", $op->{PTY_ID}, "'"
2270 ) if _debugging_details ;
2271 ) if _debugging_details;
22712272 }
22722273 else {
22732274 croak(
22742275 "'"
22752276 . ref( $dest )
22762277 . "' not allowed as a sink for output redirection"
2277 ) ;
2278 );
22782279 }
22792280
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 ;
2281 $op->{FD} = $self->{PTYS}->{$op->{PTY_ID}}->fileno;
2282 $op->{TFD} = undef; # The fd isn't known until after fork().
2283 $output_fds_accum[$op->{KFD}] = $op;
2284 $op->_init_filters;
22842285 }
22852286 elsif ( $op->{TYPE} eq '|' ) {
22862287 _debug(
22872288 "pipelining $kid->{NUM} and "
22882289 . ( $kid->{NUM} + 1 )
2289 ) if _debugging_details ;
2290 ( $pipe_read_fd, $op->{TFD} ) = _pipe ;
2290 ) if _debugging_details;
2291 ( $pipe_read_fd, $op->{TFD} ) = _pipe;
22912292 if ( Win32_MODE ) {
2292 _dont_inherit( $pipe_read_fd ) ;
2293 _dont_inherit( $op->{TFD} ) ;
2293 _dont_inherit( $pipe_read_fd );
2294 _dont_inherit( $op->{TFD} );
22942295 }
2295 @output_fds_accum = () ;
2296 @output_fds_accum = ();
22962297 }
22972298 elsif ( $op->{TYPE} eq '&' ) {
2298 @output_fds_accum = () ;
2299 @output_fds_accum = ();
22992300 } # end if $op->{TYPE} tree
23002301 1;
2301 } ; # end eval
2302 }; # end eval
23022303 unless ( $ok ) {
2303 push @errs, $@ ;
2304 push @errs, $@;
23042305 _debug 'caught ', $@ if _debugging;
23052306 }
23062307 } # end for ( OPS }
23082309
23092310 if ( @errs ) {
23102311 for ( @close_on_fail ) {
2311 _close( $_ ) ;
2312 $_ = undef ;
2312 _close( $_ );
2313 $_ = undef;
23132314 }
23142315 for ( keys %{$self->{PTYS}} ) {
2315 next unless $self->{PTYS}->{$_} ;
2316 close $self->{PTYS}->{$_} ;
2317 $self->{PTYS}->{$_} = undef ;
2316 next unless $self->{PTYS}->{$_};
2317 close $self->{PTYS}->{$_};
2318 $self->{PTYS}->{$_} = undef;
23182319 }
23192320 die join( '', @errs )
23202321 }
23322333 ## have closed (when $self->{PIPES} has emptied). This means that we
23332334 ## need to scan the KIDS whenever @{$self->{PIPES}} is empty to see
23342335 ## if there any of them are still alive.
2335 for ( my $num = 0 ; $num < $#{$self->{KIDS}} ; ++$num ) {
2336 for ( my $num = 0; $num < $#{$self->{KIDS}}; ++$num ) {
23362337 for ( reverse @output_fds_accum ) {
2337 next unless defined $_ ;
2338 next unless defined $_;
23382339 _debug(
23392340 'kid ', $self->{KIDS}->[$num]->{NUM}, ' also to write ', $_->{KFD},
23402341 ' to ', ref $_->{DEST}
2341 ) if _debugging_details ;
2342 unshift @{$self->{KIDS}->[$num]->{OPS}}, $_ ;
2342 ) if _debugging_details;
2343 unshift @{$self->{KIDS}->[$num]->{OPS}}, $_;
23432344 }
23442345 }
23452346
23472348 ## Create the list of PIPES we need to scan and the bit vectors needed by
23482349 ## select(). Do this first so that _cleanup can _clobber() them if an
23492350 ## exception occurs.
2350 @{$self->{PIPES}} = () ;
2351 $self->{RIN} = '' ;
2352 $self->{WIN} = '' ;
2353 $self->{EIN} = '' ;
2351 @{$self->{PIPES}} = ();
2352 $self->{RIN} = '';
2353 $self->{WIN} = '';
2354 $self->{EIN} = '';
23542355 ## PIN is a vec()tor that indicates who's paused.
2355 $self->{PIN} = '' ;
2356 $self->{PIN} = '';
23562357 for my $kid ( @{$self->{KIDS}} ) {
23572358 for ( @{$kid->{OPS}} ) {
23582359 if ( defined $_->{FD} ) {
23592360 _debug(
23602361 'kid ', $kid->{NUM}, '[', $kid->{PID}, "]'s ", $_->{KFD},
23612362 ' 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}}, $_ ;
2363 ) if _debugging_details;
2364 vec( $self->{ $_->{TYPE} =~ /^</ ? 'WIN' : 'RIN' }, $_->{FD}, 1 ) = 1;
2365 # vec( $self->{EIN}, $_->{FD}, 1 ) = 1;
2366 push @{$self->{PIPES}}, $_;
23662367 }
23672368 }
23682369 }
23692370
23702371 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 ;
2372 my $fd = $io->fileno;
2373 vec( $self->{RIN}, $fd, 1 ) = 1 if $io->mode =~ /r/;
2374 vec( $self->{WIN}, $fd, 1 ) = 1 if $io->mode =~ /w/;
2375 # vec( $self->{EIN}, $fd, 1 ) = 1;
2376 push @{$self->{PIPES}}, $io;
23762377 }
23772378
23782379 ## Put filters on the end of the filter chains to read & write the pipes.
23792380 ## Clear pipe states
23802381 for my $pipe ( @{$self->{PIPES}} ) {
2381 $pipe->{SOURCE_EMPTY} = 0 ;
2382 $pipe->{PAUSED} = 0 ;
2382 $pipe->{SOURCE_EMPTY} = 0;
2383 $pipe->{PAUSED} = 0;
23832384 if ( $pipe->{TYPE} =~ /^>/ ) {
23842385 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} ) } ;
2386 my ( undef, $out_ref ) = @_;
2387
2388 return undef unless defined $pipe->{FD};
2389 return 0 unless vec( $self->{ROUT}, $pipe->{FD}, 1 );
2390
2391 vec( $self->{ROUT}, $pipe->{FD}, 1 ) = 0;
2392
2393 _debug_desc_fd( 'reading from', $pipe ) if _debugging_details;
2394 my $in = eval { _read( $pipe->{FD} ) };
23942395 if ( $@ ) {
2395 $in = '' ;
2396 $in = '';
23962397 ## IO::Pty throws the Input/output error if the kid dies.
23972398 ## read() throws the bad file descriptor message if the
23982399 ## kid dies on Win32.
23992400 die $@ unless
24002401 $@ =~ /^Input\/output error: read/ ||
24012402 ($@ =~ /input or output/ && $^O =~ /aix/)
2402 || ( Win32_MODE && $@ =~ /Bad file descriptor/ ) ;
2403 || ( Win32_MODE && $@ =~ /Bad file descriptor/ );
24032404 }
24042405
24052406 unless ( length $in ) {
2406 $self->_clobber( $pipe ) ;
2407 return undef ;
2407 $self->_clobber( $pipe );
2408 return undef;
24082409 }
24092410
24102411 ## 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 } ;
2412 my $pos = pos $$out_ref;
2413 $$out_ref .= $in;
2414 pos( $$out_ref ) = $pos;
2415 return 1;
2416 };
24162417 ## Input filters are the last filters
2417 push @{$pipe->{FILTERS}}, $pipe_reader ;
2418 push @{$self->{TEMP_FILTERS}}, $pipe_reader ;
2418 push @{$pipe->{FILTERS}}, $pipe_reader;
2419 push @{$self->{TEMP_FILTERS}}, $pipe_reader;
24192420 }
24202421 else {
24212422 my $pipe_writer = sub {
2422 my ( $in_ref, $out_ref ) = @_ ;
2423 return undef unless defined $pipe->{FD} ;
2423 my ( $in_ref, $out_ref ) = @_;
2424 return undef unless defined $pipe->{FD};
24242425 return 0
24252426 unless vec( $self->{WOUT}, $pipe->{FD}, 1 )
2426 || $pipe->{PAUSED} ;
2427
2428 vec( $self->{WOUT}, $pipe->{FD}, 1 ) = 0 ;
2427 || $pipe->{PAUSED};
2428
2429 vec( $self->{WOUT}, $pipe->{FD}, 1 ) = 0;
24292430
24302431 if ( ! length $$in_ref ) {
24312432 if ( ! defined get_more_input ) {
2432 $self->_clobber( $pipe ) ;
2433 return undef ;
2433 $self->_clobber( $pipe );
2434 return undef;
24342435 }
24352436 }
24362437
24372438 unless ( length $$in_ref ) {
24382439 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 ;
2440 _debug_desc_fd( 'pausing', $pipe ) if _debugging_details;
2441 vec( $self->{WIN}, $pipe->{FD}, 1 ) = 0;
2442 # vec( $self->{EIN}, $pipe->{FD}, 1 ) = 0;
2443 vec( $self->{PIN}, $pipe->{FD}, 1 ) = 1;
2444 $pipe->{PAUSED} = 1;
24442445 }
2445 return 0 ;
2446 return 0;
24462447 }
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 } ;
2448 _debug_desc_fd( 'writing to', $pipe ) if _debugging_details;
2449
2450 my $c = _write( $pipe->{FD}, $$in_ref );
2451 substr( $$in_ref, 0, $c, '' );
2452 return 1;
2453 };
24532454 ## Output filters are the first filters
2454 unshift @{$pipe->{FILTERS}}, $pipe_writer ;
2455 push @{$self->{TEMP_FILTERS}}, $pipe_writer ;
2455 unshift @{$pipe->{FILTERS}}, $pipe_writer;
2456 push @{$self->{TEMP_FILTERS}}, $pipe_writer;
24562457 }
24572458 }
24582459 }
24602461
24612462 sub _dup2_gently {
24622463 ## A METHOD, NOT A FUNCTION, NEEDS $self!
2463 my IPC::Run $self = shift ;
2464 my ( $files, $fd1, $fd2 ) = @_ ;
2464 my IPC::Run $self = shift;
2465 my ( $files, $fd1, $fd2 ) = @_;
24652466 ## Moves TFDs that are using the destination fd out of the
24662467 ## way before calling _dup2
24672468 for ( @$files ) {
2468 next unless defined $_->{TFD} ;
2469 $_->{TFD} = _dup( $_->{TFD} ) if $_->{TFD} == $fd2 ;
2469 next unless defined $_->{TFD};
2470 $_->{TFD} = _dup( $_->{TFD} ) if $_->{TFD} == $fd2;
24702471 }
24712472 $self->{DEBUG_FD} = _dup $self->{DEBUG_FD}
2472 if defined $self->{DEBUG_FD} && $self->{DEBUG_FD} == $fd2 ;
2473
2474 _dup2_rudely( $fd1, $fd2 ) ;
2475 }
2473 if defined $self->{DEBUG_FD} && $self->{DEBUG_FD} == $fd2;
2474
2475 _dup2_rudely( $fd1, $fd2 );
2476 }
2477
2478 =pod
24762479
24772480 =item close_terminal
24782481
24862489 sub close_terminal {
24872490 ## Cast of the bonds of a controlling terminal
24882491
2489 POSIX::setsid() || croak "POSIX::setsid() failed" ;
2492 POSIX::setsid() || croak "POSIX::setsid() failed";
24902493 _debug "closing stdin, out, err"
2491 if _debugging_details ;
2492 close STDIN ;
2493 close STDERR ;
2494 close STDOUT ;
2494 if _debugging_details;
2495 close STDIN;
2496 close STDERR;
2497 close STDOUT;
24952498 }
24962499
24972500
24982501 sub _do_kid_and_exit {
2499 my IPC::Run $self = shift ;
2500 my ( $kid ) = @_ ;
2502 my IPC::Run $self = shift;
2503 my ( $kid ) = @_;
25012504
25022505 ## For unknown reasons, placing these two statements in the eval{}
25032506 ## causes the eval {} to not catch errors after they are executed in
25052508 ## Part of this could be that these symbols get destructed when
25062509 ## exiting the eval, and that destruction might be what's (wrongly)
25072510 ## confusing the eval{}, allowing the exception to probpogate.
2508 my $s1 = gensym ;
2509 my $s2 = gensym ;
2511 my $s1 = gensym;
2512 my $s2 = gensym;
25102513
25112514 eval {
2512 local $cur_self = $self ;
2515 local $cur_self = $self;
25132516
25142517 _set_child_debug_name( ref $kid->{VAL} eq "CODE"
25152518 ? "CODE"
25192522 ## close parent FD's first so they're out of the way.
25202523 ## Don't close STDIN, STDOUT, STDERR: they should be inherited or
25212524 ## 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 my @needed = $self->{noinherit} ? () : ( 1, 1, 1 );
2526 $needed[ $self->{SYNC_WRITER_FD} ] = 1;
2527 $needed[ $self->{DEBUG_FD} ] = 1 if defined $self->{DEBUG_FD};
25252528
25262529 for ( @{$kid->{OPS}} ) {
2527 $needed[ $_->{TFD} ] = 1 if defined $_->{TFD} ;
2530 $needed[ $_->{TFD} ] = 1 if defined $_->{TFD};
25282531 }
25292532
25302533 ## TODO: use the forthcoming IO::Pty to close the terminal and
25312534 ## make the first pty for this child the controlling terminal.
25322535 ## This will also make it so that pty-laden kids don't cause
25332536 ## other kids to lose stdin/stdout/stderr.
2534 my @closed ;
2537 my @closed;
25352538 if ( %{$self->{PTYS}} ) {
25362539 ## Clean up the parent's fds.
25372540 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 ;
2541 _debug "Cleaning up parent's ptty '$_'" if _debugging_details;
2542 my $slave = $self->{PTYS}->{$_}->slave;
2543 $closed[ $self->{PTYS}->{$_}->fileno ] = 1;
2544 close $self->{PTYS}->{$_};
2545 $self->{PTYS}->{$_} = $slave;
25432546 }
25442547
2545 close_terminal ;
2546 $closed[ $_ ] = 1 for ( 0..2 ) ;
2548 close_terminal;
2549 $closed[ $_ ] = 1 for ( 0..2 );
25472550 }
25482551
25492552 for my $sibling ( @{$self->{KIDS}} ) {
25502553 for ( @{$sibling->{OPS}} ) {
25512554 if ( $_->{TYPE} =~ /^.pty.$/ ) {
2552 $_->{TFD} = $self->{PTYS}->{$_->{PTY_ID}}->fileno ;
2553 $needed[$_->{TFD}] = 1 ;
2555 $_->{TFD} = $self->{PTYS}->{$_->{PTY_ID}}->fileno;
2556 $needed[$_->{TFD}] = 1;
25542557 }
25552558
25562559 # for ( $_->{FD}, ( $sibling != $kid ? $_->{TFD} : () ) ) {
25572560 # if ( defined $_ && ! $closed[$_] && ! $needed[$_] ) {
2558 # _close( $_ ) ;
2559 # $closed[$_] = 1 ;
2560 # $_ = undef ;
2561 # _close( $_ );
2562 # $closed[$_] = 1;
2563 # $_ = undef;
25612564 # }
25622565 # }
25632566 }
25652568
25662569 ## This is crude: we have no way of keeping track of browsing all open
25672570 ## fds, so we scan to a fairly high fd.
2568 _debug "open fds: ", join " ", keys %fds if _debugging_details ;
2571 _debug "open fds: ", join " ", keys %fds if _debugging_details;
25692572 for (keys %fds) {
25702573 if ( ! $closed[$_] && ! $needed[$_] ) {
2571 _close( $_ ) ;
2572 $closed[$_] = 1 ;
2574 _close( $_ );
2575 $closed[$_] = 1;
25732576 }
25742577 }
25752578
25762579 ## Lazy closing is so the same fd (ie the same TFD value) can be dup2'ed on
25772580 ## several times.
2578 my @lazy_close ;
2581 my @lazy_close;
25792582 for ( @{$kid->{OPS}} ) {
25802583 if ( defined $_->{TFD} ) {
25812584 unless ( $_->{TFD} == $_->{KFD} ) {
2582 $self->_dup2_gently( $kid->{OPS}, $_->{TFD}, $_->{KFD} ) ;
2583 push @lazy_close, $_->{TFD} ;
2585 $self->_dup2_gently( $kid->{OPS}, $_->{TFD}, $_->{KFD} );
2586 push @lazy_close, $_->{TFD};
25842587 }
25852588 }
25862589 elsif ( $_->{TYPE} eq 'dup' ) {
25872590 $self->_dup2_gently( $kid->{OPS}, $_->{KFD1}, $_->{KFD2} )
2588 unless $_->{KFD1} == $_->{KFD2} ;
2591 unless $_->{KFD1} == $_->{KFD2};
25892592 }
25902593 elsif ( $_->{TYPE} eq 'close' ) {
25912594 for ( $_->{KFD} ) {
25922595 if ( ! $closed[$_] ) {
2593 _close( $_ ) ;
2594 $closed[$_] = 1 ;
2595 $_ = undef ;
2596 _close( $_ );
2597 $closed[$_] = 1;
2598 $_ = undef;
25962599 }
25972600 }
25982601 }
25992602 elsif ( $_->{TYPE} eq 'init' ) {
2600 $_->{SUB}->() ;
2603 $_->{SUB}->();
26012604 }
26022605 }
26032606
26042607 for ( @lazy_close ) {
26052608 unless ( $closed[$_] ) {
2606 _close( $_ ) ;
2607 $closed[$_] = 1 ;
2609 _close( $_ );
2610 $closed[$_] = 1;
26082611 }
26092612 }
26102613
26112614 if ( ref $kid->{VAL} ne 'CODE' ) {
26122615 open $s1, ">&=$self->{SYNC_WRITER_FD}"
2613 or croak "$! setting filehandle to fd SYNC_WRITER_FD" ;
2614 fcntl $s1, F_SETFD, 1 ;
2616 or croak "$! setting filehandle to fd SYNC_WRITER_FD";
2617 fcntl $s1, F_SETFD, 1;
26152618
26162619 if ( defined $self->{DEBUG_FD} ) {
26172620 open $s2, ">&=$self->{DEBUG_FD}"
2618 or croak "$! setting filehandle to fd DEBUG_FD" ;
2619 fcntl $s2, F_SETFD, 1 ;
2621 or croak "$! setting filehandle to fd DEBUG_FD";
2622 fcntl $s2, F_SETFD, 1;
26202623 }
26212624
2622 my @cmd = ( $kid->{PATH}, @{$kid->{VAL}}[1..$#{$kid->{VAL}}] ) ;
2623 _debug 'execing ', join " ", map { /[\s"]/ ? "'$_'" : $_ } @cmd
2624 if _debugging ;
2625 my @cmd = ( $kid->{PATH}, @{$kid->{VAL}}[1..$#{$kid->{VAL}}] );
2626 _debug 'execing ', join " ", map { /[\s\"]/ ? "'$_'" : $_ } @cmd
2627 if _debugging;
26252628
26262629 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 } ;
2630 if $self->{_simulate_exec_failure};
2631
2632 _exec $kid->{PATH}, @{$kid->{VAL}}[1..$#{$kid->{VAL}}];
2633
2634 croak "exec failed: $!";
2635 }
2636 };
26342637 if ( $@ ) {
2635 _write $self->{SYNC_WRITER_FD}, $@ ;
2638 _write $self->{SYNC_WRITER_FD}, $@;
26362639 ## Avoid DESTROY.
2637 POSIX::exit 1 ;
2640 POSIX::exit 1;
26382641 }
26392642
26402643 ## We must be executing code in the child, otherwise exec() would have
26412644 ## prevented us from being here.
2642 _close $self->{SYNC_WRITER_FD} ;
2645 _close $self->{SYNC_WRITER_FD};
26432646 _debug 'calling fork()ed CODE ref' if _debugging;
2644 POSIX::close $self->{DEBUG_FD} if defined $self->{DEBUG_FD} ;
2647 POSIX::close $self->{DEBUG_FD} if defined $self->{DEBUG_FD};
26452648 ## TODO: Overload CORE::GLOBAL::exit...
2646 $kid->{VAL}->() ;
2649 $kid->{VAL}->();
26472650
26482651 ## There are bugs in perl closures up to and including 5.6.1
26492652 ## that may keep this next line from having any effect, and it
26502653 ## won't have any effect if our caller has kept a copy of it, but
26512654 ## this may cause the closure to be cleaned up. Maybe.
2652 $kid->{VAL} = undef ;
2655 $kid->{VAL} = undef;
26532656
26542657 ## Use POSIX::exit to avoid global destruction, since this might
26552658 ## cause DESTROY() to be called on objects created in the parent
26562659 ## and thus cause double cleanup. For instance, if DESTROY() unlinks
26572660 ## a file in the child, we don't want the parent to suddenly miss
26582661 ## it.
2659 POSIX::exit 0 ;
2660 }
2661
2662 POSIX::exit 0;
2663 }
2664
2665 =pod
26622666
26632667 =item start
26642668
26662670 \@cmd, \$in, \$out, ...,
26672671 timeout( 30, name => "process timeout" ),
26682672 $stall_timeout = timeout( 10, name => "stall timeout" ),
2669 ) ;
2670
2671 $h = start \@cmd, '<', \$in, '|', \@cmd2, ... ;
2673 );
2674
2675 $h = start \@cmd, '<', \$in, '|', \@cmd2, ...;
26722676
26732677 start() accepts a harness or harness specification and returns a harness
26742678 after building all of the pipes and launching (via fork()/exec(), or, maybe
26902694 Here's how if you don't want to alter the state of $| for your
26912695 filehandle:
26922696
2693 $ofh = select HANDLE ; $of = $| ; $| = 1 ; $| = $of ; select $ofh;
2697 $ofh = select HANDLE; $of = $|; $| = 1; $| = $of; select $ofh;
26942698
26952699 If you don't mind leaving output unbuffered on HANDLE, you can do
26962700 the slightly shorter
26972701
2698 $ofh = select HANDLE ; $| = 1 ; select $ofh;
2702 $ofh = select HANDLE; $| = 1; select $ofh;
26992703
27002704 Or, you can use IO::Handle's flush() method:
27012705
2702 use IO::Handle ;
2703 flush HANDLE ;
2706 use IO::Handle;
2707 flush HANDLE;
27042708
27052709 Perl needs the equivalent of C's fflush( (FILE *)NULL ).
27062710
27072711 =cut
27082712
27092713 sub start {
2710 # $SIG{__DIE__} = sub { my $s = shift ; Carp::cluck $s ; die $s } ;
2711 my $options ;
2714 # $SIG{__DIE__} = sub { my $s = shift; Carp::cluck $s; die $s };
2715 my $options;
27122716 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 ;
2717 $options = pop;
2718 require Data::Dumper;
2719 carp "Passing in options as a hash is deprecated:\n", Data::Dumper::Dumper( $options );
2720 }
2721
2722 my IPC::Run $self;
2723 if ( @_ == 1 && UNIVERSAL::isa( $_[0], __PACKAGE__ ) ) {
2724 $self = shift;
2725 $self->{$_} = $options->{$_} for keys %$options;
27222726 }
27232727 else {
2724 $self = harness( @_, $options ? $options : () ) ;
2725 }
2726
2727 local $cur_self = $self ;
2728
2729 $self->kill_kill if $self->{STATE} == _started ;
2728 $self = harness( @_, $options ? $options : () );
2729 }
2730
2731 local $cur_self = $self;
2732
2733 $self->kill_kill if $self->{STATE} == _started;
27302734
27312735 _debug "** starting" if _debugging;
27322736
2733 $_->{RESULT} = undef for @{$self->{KIDS}} ;
2737 $_->{RESULT} = undef for @{$self->{KIDS}};
27342738
27352739 ## Assume we're not being called from &run. It will correct our
27362740 ## assumption if need be. This affects whether &_select_loop clears
27372741 ## input queues to '' when they're empty.
2738 $self->{clear_ins} = 1 ;
2742 $self->{clear_ins} = 1;
27392743
27402744 IPC::Run::Win32Helper::optimize $self
27412745 if Win32_MODE && $in_run;
27422746
2743 my @errs ;
2747 my @errs;
27442748
27452749 for ( @{$self->{TIMERS}} ) {
2746 eval { $_->start } ;
2750 eval { $_->start };
27472751 if ( $@ ) {
2748 push @errs, $@ ;
2752 push @errs, $@;
27492753 _debug 'caught ', $@ if _debugging;
27502754 }
27512755 }
27522756
2753 eval { $self->_open_pipes } ;
2757 eval { $self->_open_pipes };
27542758 if ( $@ ) {
2755 push @errs, $@ ;
2759 push @errs, $@;
27562760 _debug 'caught ', $@ if _debugging;
27572761 }
27582762
27622766 ## autoflush STDOUT and STDERR. This is done so that the children don't
27632767 ## inherit output buffers chock full o' redundant data. It's really
27642768 ## confusing to track that down.
2765 { my $ofh = select STDOUT ; local $| = 1 ; select $ofh; }
2766 { my $ofh = select STDERR ; local $| = 1 ; select $ofh; }
2769 { my $ofh = select STDOUT; local $| = 1; select $ofh; }
2770 { my $ofh = select STDERR; local $| = 1; select $ofh; }
27672771 for my $kid ( @{$self->{KIDS}} ) {
2768 $kid->{RESULT} = undef ;
2772 $kid->{RESULT} = undef;
27692773 _debug "child: ",
27702774 ref( $kid->{VAL} ) eq "CODE"
27712775 ? "CODE ref"
27732777 "`",
27742778 join( " ", map /[^\w.-]/ ? "'$_'" : $_, @{$kid->{VAL}} ),
27752779 "`"
2776 ) if _debugging_details ;
2780 ) if _debugging_details;
27772781 eval {
27782782 croak "simulated failure of fork"
2779 if $self->{_simulate_fork_failure} ;
2783 if $self->{_simulate_fork_failure};
27802784 unless ( Win32_MODE ) {
2781 $self->_spawn( $kid ) ;
2785 $self->_spawn( $kid );
27822786 }
27832787 else {
27842788 ## TODO: Test and debug spawing code. Someday.
27942798 ) if _debugging;
27952799 ## The external kid wouldn't know what to do with it anyway.
27962800 ## This is only used by the "helper" pump processes on Win32.
2797 _dont_inherit( $self->{DEBUG_FD} ) ;
2801 _dont_inherit( $self->{DEBUG_FD} );
27982802 ( $kid->{PID}, $kid->{PROCESS} ) =
27992803 IPC::Run::Win32Helper::win32_spawn(
28002804 [ $kid->{PATH}, @{$kid->{VAL}}[1..$#{$kid->{VAL}}] ],
28012805 $kid->{OPS},
2802 ) ;
2806 );
28032807 _debug "spawn() = ", $kid->{PID} if _debugging;
28042808 }
2805 } ;
2809 };
28062810 if ( $@ ) {
2807 push @errs, $@ ;
2811 push @errs, $@;
28082812 _debug 'caught ', $@ if _debugging;
28092813 }
28102814 }
28122816
28132817 ## Close all those temporary filehandles that the kids needed.
28142818 for my $pty ( values %{$self->{PTYS}} ) {
2815 close $pty->slave ;
2816 }
2817
2818 my @closed ;
2819 close $pty->slave;
2820 }
2821
2822 my @closed;
28192823 for my $kid ( @{$self->{KIDS}} ) {
28202824 for ( @{$kid->{OPS}} ) {
28212825 my $close_it = eval {
28232827 && ! $_->{DONT_CLOSE}
28242828 && ! $closed[$_->{TFD}]
28252829 && ( ! Win32_MODE || ! $_->{RECV_THROUGH_TEMP_FILE} ) ## Win32 hack
2826 } ;
2830 };
28272831 if ( $@ ) {
2828 push @errs, $@ ;
2832 push @errs, $@;
28292833 _debug 'caught ', $@ if _debugging;
28302834 }
28312835 if ( $close_it || $@ ) {
28322836 eval {
2833 _close( $_->{TFD} ) ;
2834 $closed[$_->{TFD}] = 1 ;
2835 $_->{TFD} = undef ;
2836 } ;
2837 _close( $_->{TFD} );
2838 $closed[$_->{TFD}] = 1;
2839 $_->{TFD} = undef;
2840 };
28372841 if ( $@ ) {
2838 push @errs, $@ ;
2842 push @errs, $@;
28392843 _debug 'caught ', $@ if _debugging;
28402844 }
28412845 }
28422846 }
28432847 }
2844 confess "gak!" unless defined $self->{PIPES} ;
2848 confess "gak!" unless defined $self->{PIPES};
28452849
28462850 if ( @errs ) {
2847 eval { $self->_cleanup } ;
2848 warn $@ if $@ ;
2849 die join( '', @errs ) ;
2850 }
2851
2852 $self->{STATE} = _started ;
2853 return $self ;
2851 eval { $self->_cleanup };
2852 warn $@ if $@;
2853 die join( '', @errs );
2854 }
2855
2856 $self->{STATE} = _started;
2857 return $self;
28542858 }
28552859
28562860
28572861 sub adopt {
28582862 ## NOT FUNCTIONAL YET, NEED TO CLOSE FDS BETTER IN CHILDREN. SEE
28592863 ## t/adopt.t for a test suite.
2860 my IPC::Run $self = shift ;
2864 my IPC::Run $self = shift;
28612865
28622866 for my $adoptee ( @_ ) {
2863 push @{$self->{IOS}}, @{$adoptee->{IOS}} ;
2867 push @{$self->{IOS}}, @{$adoptee->{IOS}};
28642868 ## NEED TO RENUMBER THE KIDS!!
2865 push @{$self->{KIDS}}, @{$adoptee->{KIDS}} ;
2866 push @{$self->{PIPES}}, @{$adoptee->{PIPES}} ;
2869 push @{$self->{KIDS}}, @{$adoptee->{KIDS}};
2870 push @{$self->{PIPES}}, @{$adoptee->{PIPES}};
28672871 $self->{PTYS}->{$_} = $adoptee->{PTYS}->{$_}
2868 for keys %{$adoptee->{PYTS}} ;
2869 push @{$self->{TIMERS}}, @{$adoptee->{TIMERS}} ;
2870 $adoptee->{STATE} = _finished ;
2872 for keys %{$adoptee->{PYTS}};
2873 push @{$self->{TIMERS}}, @{$adoptee->{TIMERS}};
2874 $adoptee->{STATE} = _finished;
28712875 }
28722876 }
28732877
28742878
28752879 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 ;
2880 my IPC::Run $self = shift;
2881 my ( $file ) = @_;
2882 _debug_desc_fd( "closing", $file ) if _debugging_details;
2883 my $doomed = $file->{FD};
2884 my $dir = $file->{TYPE} =~ /^</ ? 'WIN' : 'RIN';
2885 vec( $self->{$dir}, $doomed, 1 ) = 0;
2886 # vec( $self->{EIN}, $doomed, 1 ) = 0;
2887 vec( $self->{PIN}, $doomed, 1 ) = 0;
28842888 if ( $file->{TYPE} =~ /^(.)pty.$/ ) {
28852889 if ( $1 eq '>' ) {
28862890 ## Only close output ptys. This is so that ptys as inputs are
28872891 ## never autoclosed, which would risk losing data that was
28882892 ## in the slave->parent queue.
2889 _debug_desc_fd "closing pty", $file if _debugging_details ;
2893 _debug_desc_fd "closing pty", $file if _debugging_details;
28902894 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} ;
2895 if defined $self->{PTYS}->{$file->{PTY_ID}};
2896 $self->{PTYS}->{$file->{PTY_ID}} = undef;
2897 }
2898 }
2899 elsif ( UNIVERSAL::isa( $file, 'IPC::Run::IO' ) ) {
2900 $file->close unless $file->{DONT_CLOSE};
28972901 }
28982902 else {
2899 _close( $doomed ) ;
2903 _close( $doomed );
29002904 }
29012905
29022906 @{$self->{PIPES}} = grep
29032907 defined $_->{FD} && ( $_->{TYPE} ne $file->{TYPE} || $_->{FD} ne $doomed),
2904 @{$self->{PIPES}} ;
2905
2906 $file->{FD} = undef ;
2908 @{$self->{PIPES}};
2909
2910 $file->{FD} = undef;
29072911 }
29082912
29092913 sub _select_loop {
2910 my IPC::Run $self = shift ;
2911
2912 my $io_occurred ;
2913
2914 my $not_forever = 0.01 ;
2914 my IPC::Run $self = shift;
2915
2916 my $io_occurred;
2917
2918 my $not_forever = 0.01;
29152919
29162920 SELECT:
29172921 while ( $self->pumpable ) {
29182922 if ( $io_occurred && $self->{break_on_io} ) {
29192923 _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 ;
2924 if _debugging_details;
2925 last;
2926 }
2927
2928 my $timeout = $self->{non_blocking} ? 0 : undef;
29252929
29262930 if ( @{$self->{TIMERS}} ) {
2927 my $now = time ;
2928 my $time_left ;
2931 my $now = time;
2932 my $time_left;
29292933 for ( @{$self->{TIMERS}} ) {
2930 next unless $_->is_running ;
2931 $time_left = $_->check( $now ) ;
2934 next unless $_->is_running;
2935 $time_left = $_->check( $now );
29322936 ## Return when a timer expires
2933 return if defined $time_left && ! $time_left ;
2937 return if defined $time_left && ! $time_left;
29342938 $timeout = $time_left
2935 if ! defined $timeout || $time_left < $timeout ;
2939 if ! defined $timeout || $time_left < $timeout;
29362940 }
29372941 }
29382942
29392943 ##
29402944 ## See if we can unpause any input channels
29412945 ##
2942 my $paused = 0 ;
2946 my $paused = 0;
29432947
29442948 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 ) ;
2949 next unless $file->{PAUSED} && $file->{TYPE} =~ /^</;
2950
2951 _debug_desc_fd( "checking for more input", $file ) if _debugging_details;
2952 my $did;
2953 1 while $did = $file->_do_filters( $self );
29502954 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 ;
2955 _debug_desc_fd( "unpausing", $file ) if _debugging_details;
2956 $file->{PAUSED} = 0;
2957 vec( $self->{WIN}, $file->{FD}, 1 ) = 1;
2958 # vec( $self->{EIN}, $file->{FD}, 1 ) = 1;
2959 vec( $self->{PIN}, $file->{FD}, 1 ) = 0;
29562960 }
29572961 else {
29582962 ## This gets incremented occasionally when the IO channel
29592963 ## was actually closed. That's a bug, but it seems mostly
29602964 ## harmless: it causes us to exit if break_on_io, or to set
29612965 ## the timeout to not be forever. I need to fix it, though.
2962 ++$paused ;
2966 ++$paused;
29632967 }
29642968 }
29652969
29672971 my $map = join(
29682972 '',
29692973 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 ;
2974 my $out;
2975 $out = 'r' if vec( $self->{RIN}, $_, 1 );
2976 $out = $out ? 'b' : 'w' if vec( $self->{WIN}, $_, 1 );
2977 $out = 'p' if ! $out && vec( $self->{PIN}, $_, 1 );
2978 $out = $out ? uc( $out ) : 'x' if vec( $self->{EIN}, $_, 1 );
2979 $out = '-' unless $out;
2980 $out;
29772981 } (0..1024)
2978 ) ;
2979 $map =~ s/((?:[a-zA-Z-]|\([^\)]*\)){12,}?)-*$/$1/ ;
2980 _debug 'fds for select: ', $map if _debugging_details ;
2982 );
2983 $map =~ s/((?:[a-zA-Z-]|\([^\)]*\)){12,}?)-*$/$1/;
2984 _debug 'fds for select: ', $map if _debugging_details;
29812985 }
29822986
29832987 ## _do_filters may have closed our last fd, and we need to see if
29882992 ## No I/O will wake the select loop up, but we have children
29892993 ## lingering, so we need to poll them with a short timeout.
29902994 ## 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 ;
2995 $timeout = $not_forever;
2996 $not_forever *= 2;
2997 $not_forever = 0.5 if $not_forever >= 0.5;
29942998 }
29952999
29963000 ## Make sure we don't block forever in select() because inputs are
30023006 if ( $self->{break_on_io} ) {
30033007 _debug "exiting _select(): no I/O to do and timeout=forever"
30043008 if _debugging;
3005 last ;
3009 last;
30063010 }
30073011
30083012 ## 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 ;
3013 $timeout = $not_forever;
3014 $not_forever *= 2;
3015 $not_forever = 0.5 if $not_forever >= 0.5;
30123016 }
30133017
30143018 _debug 'timeout=', defined $timeout ? $timeout : 'forever'
3015 if _debugging_details ;
3016
3017 my $nfound ;
3019 if _debugging_details;
3020
3021 my $nfound;
30183022 unless ( Win32_MODE ) {
30193023 $nfound = select(
30203024 $self->{ROUT} = $self->{RIN},
30213025 $self->{WOUT} = $self->{WIN},
30223026 $self->{EOUT} = $self->{EIN},
30233027 $timeout
3024 ) ;
3028 );
30253029 }
30263030 else {
3027 my @in = map $self->{$_}, qw( RIN WIN EIN ) ;
3031 my @in = map $self->{$_}, qw( RIN WIN EIN );
30283032 ## Win32's select() on Win32 seems to die if passed vectors of
30293033 ## all 0's. Need to report this when I get back online.
30303034 for ( @in ) {
3031 $_ = undef unless index( ( unpack "b*", $_ ), 1 ) >= 0 ;
3035 $_ = undef unless index( ( unpack "b*", $_ ), 1 ) >= 0;
30323036 }
30333037
30343038 $nfound = select(
30363040 $self->{WOUT} = $in[1],
30373041 $self->{EOUT} = $in[2],
30383042 $timeout
3039 ) ;
3043 );
30403044
30413045 for ( $self->{ROUT}, $self->{WOUT}, $self->{EOUT} ) {
3042 $_ = "" unless defined $_ ;
3046 $_ = "" unless defined $_;
30433047 }
30443048 }
3045 last if ! $nfound && $self->{non_blocking} ;
3049 last if ! $nfound && $self->{non_blocking};
30463050
30473051 croak "$! in select" if $nfound < 0 and $! != POSIX::EINTR;
30483052 ## TODO: Analyze the EINTR failure mode and see if this patch
30533057 my $map = join(
30543058 '',
30553059 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 ;
3060 my $out;
3061 $out = 'r' if vec( $self->{ROUT}, $_, 1 );
3062 $out = $out ? 'b' : 'w' if vec( $self->{WOUT}, $_, 1 );
3063 $out = $out ? uc( $out ) : 'x' if vec( $self->{EOUT}, $_, 1 );
3064 $out = '-' unless $out;
3065 $out;
30623066 } (0..128)
3063 ) ;
3064 $map =~ s/((?:[a-zA-Z-]|\([^\)]*\)){12,}?)-*$/$1/ ;
3065 _debug "selected ", $map ;
3067 );
3068 $map =~ s/((?:[a-zA-Z-]|\([^\)]*\)){12,}?)-*$/$1/;
3069 _debug "selected ", $map;
30663070 }
30673071
30683072 ## Need to copy since _clobber alters @{$self->{PIPES}}.
30693073 ## TODO: Rethink _clobber(). Rethink $file->{PAUSED}, too.
3070 my @pipes = @{$self->{PIPES}} ;
3074 my @pipes = @{$self->{PIPES}};
30713075 $io_occurred = $_->poll( $self ) ? 1 : $io_occurred for @pipes;
30723076 # FILE:
30733077 # for my $pipe ( @pipes ) {
30793083 # && defined $pipe->{FD}
30803084 # && vec( $self->{ROUT}, $pipe->{FD}, 1 )
30813085 # ) {
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 ) ;
3086 # _debug_desc_fd( "filtering data from", $pipe ) if _debugging_details;
3087 #confess "phooey" unless UNIVERSAL::isa( $pipe, "IPC::Run::IO" );
3088 # $io_occurred = 1 if $pipe->_do_filters( $self );
30853089 #
3086 # next FILE unless defined $pipe->{FD} ;
3090 # next FILE unless defined $pipe->{FD};
30873091 # }
30883092 #
30893093 # ## On Win32, pipes to the child can be optimized to be files
30923096 # && defined $pipe->{FD}
30933097 # && vec( $self->{WOUT}, $pipe->{FD}, 1 )
30943098 # ) {
3095 # _debug_desc_fd( "filtering data to", $pipe ) if _debugging_details ;
3096 # $io_occurred = 1 if $pipe->_do_filters( $self ) ;
3099 # _debug_desc_fd( "filtering data to", $pipe ) if _debugging_details;
3100 # $io_occurred = 1 if $pipe->_do_filters( $self );
30973101 #
3098 # next FILE unless defined $pipe->{FD} ;
3102 # next FILE unless defined $pipe->{FD};
30993103 # }
31003104 #
31013105 # if ( defined $pipe->{FD} && vec( $self->{EOUT}, $pipe->{FD}, 1 ) ) {
31073111 # ## specific) for me to easily map to any automatic action like
31083112 # ## warning or croaking (try running v0.42 if you don't beleive me
31093113 # ## :-).
3110 # warn "Exception on descriptor $pipe->{FD}" ;
3114 # warn "Exception on descriptor $pipe->{FD}";
31113115 # }
31123116 # }
31133117 }
31143118
3115 return ;
3119 return;
31163120 }
31173121
31183122
31193123 sub _cleanup {
3120 my IPC::Run $self = shift ;
3121 _debug "cleaning up" if _debugging_details ;
3124 my IPC::Run $self = shift;
3125 _debug "cleaning up" if _debugging_details;
31223126
31233127 for ( values %{$self->{PTYS}} ) {
3124 next unless ref $_ ;
3128 next unless ref $_;
31253129 eval {
31263130 _debug "closing slave fd ", fileno $_->slave if _debugging_data;
3127 close $_->slave ;
3128 } ;
3129 carp $@ . " while closing ptys" if $@ ;
3131 close $_->slave;
3132 };
3133 carp $@ . " while closing ptys" if $@;
31303134 eval {
31313135 _debug "closing master fd ", fileno $_ if _debugging_data;
3132 close $_ ;
3133 } ;
3134 carp $@ . " closing ptys" if $@ ;
3136 close $_;
3137 };
3138 carp $@ . " closing ptys" if $@;
31353139 }
31363140
3137 _debug "cleaning up pipes" if _debugging_details ;
3141 _debug "cleaning up pipes" if _debugging_details;
31383142 ## _clobber modifies PIPES
3139 $self->_clobber( $self->{PIPES}->[0] ) while @{$self->{PIPES}} ;
3143 $self->_clobber( $self->{PIPES}->[0] ) while @{$self->{PIPES}};
31403144
31413145 for my $kid ( @{$self->{KIDS}} ) {
3142 _debug "cleaning up kid ", $kid->{NUM} if _debugging_details ;
3146 _debug "cleaning up kid ", $kid->{NUM} if _debugging_details;
31433147 if ( ! length $kid->{PID} ) {
31443148 _debug 'never ran child ', $kid->{NUM}, ", can't reap"
31453149 if _debugging;
31513155 elsif ( ! defined $kid->{RESULT} ) {
31523156 _debug 'reaping child ', $kid->{NUM}, ' (pid ', $kid->{PID}, ')'
31533157 if _debugging;
3154 my $pid = waitpid $kid->{PID}, 0 ;
3155 $kid->{RESULT} = $? ;
3158 my $pid = waitpid $kid->{PID}, 0;
3159 $kid->{RESULT} = $?;
31563160 _debug 'reaped ', $pid, ', $?=', $kid->{RESULT}
31573161 if _debugging;
31583162 }
31613165 # die;
31623166 # @{$kid->{OPS}} = grep
31633167 # ! defined $_->{KFD} || $_->{KFD} != $kid->{DEBUG_FD},
3164 # @{$kid->{OPS}} ;
3165 # $kid->{DEBUG_FD} = undef ;
3168 # @{$kid->{OPS}};
3169 # $kid->{DEBUG_FD} = undef;
31663170 # }
31673171
3168 _debug "cleaning up filters" if _debugging_details ;
3172 _debug "cleaning up filters" if _debugging_details;
31693173 for my $op ( @{$kid->{OPS}} ) {
31703174 @{$op->{FILTERS}} = grep {
3171 my $filter = $_ ;
3172 ! grep $filter == $_, @{$self->{TEMP_FILTERS}} ;
3173 } @{$op->{FILTERS}} ;
3175 my $filter = $_;
3176 ! grep $filter == $_, @{$self->{TEMP_FILTERS}};
3177 } @{$op->{FILTERS}};
31743178 }
31753179
31763180 for my $op ( @{$kid->{OPS}} ) {
31773181 $op->_cleanup( $self ) if UNIVERSAL::isa( $op, "IPC::Run::IO" );
31783182 }
31793183 }
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
3184 $self->{STATE} = _finished;
3185 @{$self->{TEMP_FILTERS}} = ();
3186 _debug "done cleaning up" if _debugging_details;
3187
3188 POSIX::close $self->{DEBUG_FD} if defined $self->{DEBUG_FD};
3189 $self->{DEBUG_FD} = undef;
3190 }
3191
3192 =pod
31883193
31893194 =item pump
31903195
3191 pump $h ;
3192 $h->pump ;
3196 pump $h;
3197 $h->pump;
31933198
31943199 Pump accepts a single parameter harness. It blocks until it delivers some
31953200 input or recieves some output. It returns TRUE if there is still input or
32033208 of external applications without having to add lots of error handling code at
32043209 each step of the script:
32053210
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 ;
3211 $h = harness \@smbclient, \$in, \$out, $err;
3212
3213 $in = "cd /foo\n";
3214 $h->pump until $out =~ /^smb.*> \Z/m;
3215 die "error cding to /foo:\n$out" if $out =~ "ERR";
3216 $out = '';
3217
3218 $in = "mget *\n";
3219 $h->pump until $out =~ /^smb.*> \Z/m;
3220 die "error retrieving files:\n$out" if $out =~ "ERR";
3221
3222 $h->finish;
3223
3224 warn $err if $err;
32203225
32213226 =cut
3222
32233227
32243228 sub pump {
32253229 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 ;
3230 unless @_ == 1 && UNIVERSAL::isa( $_[0], __PACKAGE__ );
3231
3232 my IPC::Run $self = shift;
3233
3234 local $cur_self = $self;
32313235
32323236 _debug "** pumping"
32333237 if _debugging;
32343238
32353239 # 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 # } ;
3240 $self->start if $self->{STATE} < _started;
3241 croak "process ended prematurely" unless $self->pumpable;
3242
3243 $self->{auto_close_ins} = 0;
3244 $self->{break_on_io} = 1;
3245 $self->_select_loop;
3246 return $self->pumpable;
3247 # };
32443248 # if ( $@ ) {
3245 # my $x = $@ ;
3246 # _debug $x if _debugging && $x ;
3247 # eval { $self->_cleanup } ;
3248 # warn $@ if $@ ;
3249 # die $x ;
3249 # my $x = $@;
3250 # _debug $x if _debugging && $x;
3251 # eval { $self->_cleanup };
3252 # warn $@ if $@;
3253 # die $x;
32503254 # }
3251 # return $r ;
3252 }
3253
3255 # return $r;
3256 }
3257
3258 =pod
32543259
32553260 =item pump_nb
32563261
3257 pump_nb $h ;
3258 $h->pump_nb ;
3262 pump_nb $h;
3263 $h->pump_nb;
32593264
32603265 "pump() non-blocking", pumps if anything's ready to be pumped, returns
32613266 immediately otherwise. This is useful if you're doing some long-running
32643269 =cut
32653270
32663271 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 }
3272 my IPC::Run $self = shift;
3273
3274 $self->{non_blocking} = 1;
3275 my $r = eval { $self->pump };
3276 $self->{non_blocking} = 0;
3277 die $@ if $@;
3278 return $r;
3279 }
3280
3281 =pod
32753282
32763283 =item pumpable
32773284
32893296 ## open, but we have kids running. This allows the select loop
32903297 ## to poll for child exit.
32913298 sub pumpable {
3292 my IPC::Run $self = shift ;
3299 my IPC::Run $self = shift;
32933300
32943301 ## There's a catch-22 we can get in to if there is only one pipe left
32953302 ## open to the child and it's paused (ie the SCALAR it's tied to
33113318 select undef, undef, undef, 0.0001;
33123319
33133320 ## try again
3314 $self->reap_nb ;
3321 $self->reap_nb;
33153322 return 0 unless $self->_running_kids;
33163323
33173324 return -1; ## There are pipes waiting
33193326
33203327
33213328 sub _running_kids {
3322 my IPC::Run $self = shift ;
3329 my IPC::Run $self = shift;
33233330 return grep
33243331 defined $_->{PID} && ! defined $_->{RESULT},
3325 @{$self->{KIDS}} ;
3326 }
3327
3332 @{$self->{KIDS}};
3333 }
3334
3335 =pod
33283336
33293337 =item reap_nb
33303338
33403348
33413349 =cut
33423350
3343 my $still_runnings ;
3351 my $still_runnings;
33443352
33453353 sub reap_nb {
3346 my IPC::Run $self = shift ;
3347
3348 local $cur_self = $self ;
3354 my IPC::Run $self = shift;
3355
3356 local $cur_self = $self;
33493357
33503358 ## No more pipes, look to see if all the kids yet live, reaping those
33513359 ## that haven't. I'd use $SIG{CHLD}/$SIG{CLD}, but that's broken
33563364 ## may have spawned.
33573365 for my $kid ( @{$self->{KIDS}} ) {
33583366 if ( Win32_MODE ) {
3359 next if ! defined $kid->{PROCESS} || defined $kid->{RESULT} ;
3367 next if ! defined $kid->{PROCESS} || defined $kid->{RESULT};
33603368 unless ( $kid->{PROCESS}->Wait( 0 ) ) {
33613369 _debug "kid $kid->{NUM} ($kid->{PID}) still running"
33623370 if _debugging_details;
3363 next ;
3371 next;
33643372 }
33653373
33663374 _debug "kid $kid->{NUM} ($kid->{PID}) exited"
33673375 if _debugging;
33683376
33693377 $kid->{PROCESS}->GetExitCode( $kid->{RESULT} )
3370 or croak "$! while GetExitCode()ing for Win32 process" ;
3378 or croak "$! while GetExitCode()ing for Win32 process";
33713379
33723380 unless ( defined $kid->{RESULT} ) {
3373 $kid->{RESULT} = "0 but true" ;
3374 $? = $kid->{RESULT} = 0x0F ;
3381 $kid->{RESULT} = "0 but true";
3382 $? = $kid->{RESULT} = 0x0F;
33753383 }
33763384 else {
3377 $? = $kid->{RESULT} << 8 ;
3385 $? = $kid->{RESULT} << 8;
33783386 }
33793387 }
33803388 else {
3381 next if ! defined $kid->{PID} || defined $kid->{RESULT} ;
3382 my $pid = waitpid $kid->{PID}, POSIX::WNOHANG() ;
3389 next if ! defined $kid->{PID} || defined $kid->{RESULT};
3390 my $pid = waitpid $kid->{PID}, POSIX::WNOHANG();
33833391 unless ( $pid ) {
33843392 _debug "$kid->{NUM} ($kid->{PID}) still running"
33853393 if _debugging_details;
3386 next ;
3394 next;
33873395 }
33883396
33893397 if ( $pid < 0 ) {
3390 _debug "No such process: $kid->{PID}\n" if _debugging ;
3391 $kid->{RESULT} = "unknown result, unknown PID" ;
3398 _debug "No such process: $kid->{PID}\n" if _debugging;
3399 $kid->{RESULT} = "unknown result, unknown PID";
33923400 }
33933401 else {
33943402 _debug "kid $kid->{NUM} ($kid->{PID}) exited"
33953403 if _debugging;
33963404
33973405 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} = $? ;
3406 unless $pid = $kid->{PID};
3407 _debug "$kid->{PID} returned $?\n" if _debugging;
3408 $kid->{RESULT} = $?;
34013409 }
34023410 }
34033411 }
34043412 }
34053413
3414 =pod
34063415
34073416 =item finish
34083417
34273436
34283437 =cut
34293438
3430
34313439 sub finish {
3432 my IPC::Run $self = shift ;
3433 my $options = @_ && ref $_[-1] eq 'HASH' ? pop : {} ;
3434
3435 local $cur_self = $self ;
3440 my IPC::Run $self = shift;
3441 my $options = @_ && ref $_[-1] eq 'HASH' ? pop : {};
3442
3443 local $cur_self = $self;
34363444
34373445 _debug "** finishing" if _debugging;
34383446
3439 $self->{non_blocking} = 0 ;
3440 $self->{auto_close_ins} = 1 ;
3441 $self->{break_on_io} = 0 ;
3447 $self->{non_blocking} = 0;
3448 $self->{auto_close_ins} = 1;
3449 $self->{break_on_io} = 0;
34423450 # We don't alter $self->{clear_ins}, start() and run() control it.
34433451
34443452 while ( $self->pumpable ) {
3445 $self->_select_loop( $options ) ;
3446 }
3447 $self->_cleanup ;
3448
3449 return ! $self->full_result ;
3450 }
3451
3452
3453 $self->_select_loop( $options );
3454 }
3455 $self->_cleanup;
3456
3457 return ! $self->full_result;
3458 }
3459
3460 =pod
34533461 =item result
34543462
3455 $h->result ;
3463 $h->result;
34563464
34573465 Returns the first non-zero result code (ie $? >> 8). See L</full_result> to
34583466 get the $? value for a child process.
34593467
34603468 To get the result of a particular child, do:
34613469
3462 $h->result( 0 ) ; # first child's $? >> 8
3463 $h->result( 1 ) ; # second child
3470 $h->result( 0 ); # first child's $? >> 8
3471 $h->result( 1 ); # second child
34643472
34653473 or
34663474
34733481 =cut
34743482
34753483 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 ;
3484 my IPC::Run $self = $_[0];
3485
3486 croak "Harness not run" unless $self->{STATE} >= _finished;
3487 croak "Harness not finished running" unless $self->{STATE} == _finished;
34803488 }
34813489
34823490
34833491 sub result {
3484 &_assert_finished ;
3485 my IPC::Run $self = shift ;
3492 &_assert_finished;
3493 my IPC::Run $self = shift;
34863494
34873495 if ( @_ ) {
3488 my ( $which ) = @_ ;
3496 my ( $which ) = @_;
34893497 croak(
34903498 "Only ",
34913499 scalar( @{$self->{KIDS}} ),
34923500 " child processes, no process $which"
34933501 )
3494 unless $which >= 0 && $which <= $#{$self->{KIDS}} ;
3495 return $self->{KIDS}->[$which]->{RESULT} >> 8 ;
3502 unless $which >= 0 && $which <= $#{$self->{KIDS}};
3503 return $self->{KIDS}->[$which]->{RESULT} >> 8;
34963504 }
34973505 else {
3498 return undef unless @{$self->{KIDS}} ;
3506 return undef unless @{$self->{KIDS}};
34993507 for ( @{$self->{KIDS}} ) {
3500 return $_->{RESULT} >> 8 if $_->{RESULT} >> 8 ;
3501 }
3502 }
3503 }
3504
3508 return $_->{RESULT} >> 8 if $_->{RESULT} >> 8;
3509 }
3510 }
3511 }
3512
3513 =pod
35053514
35063515 =item results
35073516
35133522 =cut
35143523
35153524 sub results {
3516 &_assert_finished ;
3517 my IPC::Run $self = shift ;
3525 &_assert_finished;
3526 my IPC::Run $self = shift;
35183527
35193528 # we add 0 here to stop warnings associated with "unknown result, unknown PID"
3520 return map { (0+$_->{RESULT}) >> 8 } @{$self->{KIDS}} ;
3521 }
3522
3529 return map { (0+$_->{RESULT}) >> 8 } @{$self->{KIDS}};
3530 }
3531
3532 =pod
35233533
35243534 =item full_result
35253535
3526 $h->full_result ;
3536 $h->full_result;
35273537
35283538 Returns the first non-zero $?. See L</result> to get the first $? >> 8
35293539 value for a child process.
35303540
35313541 To get the result of a particular child, do:
35323542
3533 $h->full_result( 0 ) ; # first child's $? >> 8
3534 $h->full_result( 1 ) ; # second child
3543 $h->full_result( 0 ); # first child's $? >> 8
3544 $h->full_result( 1 ); # second child
35353545
35363546 or
35373547
35443554 =cut
35453555
35463556 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}} ;
3557 goto &result if @_ > 1;
3558 &_assert_finished;
3559
3560 my IPC::Run $self = shift;
3561
3562 return undef unless @{$self->{KIDS}};
35533563 for ( @{$self->{KIDS}} ) {
3554 return $_->{RESULT} if $_->{RESULT} ;
3555 }
3556 }
3557
3564 return $_->{RESULT} if $_->{RESULT};
3565 }
3566 }
3567
3568 =pod
35583569
35593570 =item full_results
35603571
35663577 =cut
35673578
35683579 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}} ;
3580 &_assert_finished;
3581 my IPC::Run $self = shift;
3582
3583 croak "Harness not run" unless $self->{STATE} >= _finished;
3584 croak "Harness not finished running" unless $self->{STATE} == _finished;
3585
3586 return map $_->{RESULT}, @{$self->{KIDS}};
35763587 }
35773588
35783589
35823593 use vars (
35833594 '$filter_op', ## The op running a filter chain right now
35843595 '$filter_num', ## Which filter is being run right now.
3585 ) ;
3596 );
35863597
35873598 ##
35883599 ## A few filters and filter constructors
35893600 ##
35903601
3602 =pod
3603
35913604 =back
35923605
35933606 =head1 FILTERS
35993612
36003613 =item binary
36013614
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
3615 run \@cmd, ">", binary, \$out;
3616 run \@cmd, ">", binary, \$out; ## Any TRUE value to enable
3617 run \@cmd, ">", binary 0, \$out; ## Any FALSE value to disable
36053618
36063619 This is a constructor for a "binmode" "filter" that tells IPC::Run to keep
36073620 the carriage returns that would ordinarily be edited out for you (binmode
36143627 =cut
36153628
36163629 sub binary(;$) {
3617 my $enable = @_ ? shift : 1 ;
3618 return bless sub { $enable }, "IPC::Run::binmode_pseudo_filter" ;
3619 }
3630 my $enable = @_ ? shift : 1;
3631 return bless sub { $enable }, "IPC::Run::binmode_pseudo_filter";
3632 }
3633
3634 =pod
36203635
36213636 =item new_chunker
36223637
36243639 scalar or regular expression parameter. The default is the Perl
36253640 input record separator in $/, which is a newline be default.
36263641
3627 run \@cmd, '>', new_chunker, \&lines_handler ;
3628 run \@cmd, '>', new_chunker( "\r\n" ), \&lines_handler ;
3642 run \@cmd, '>', new_chunker, \&lines_handler;
3643 run \@cmd, '>', new_chunker( "\r\n" ), \&lines_handler;
36293644
36303645 Because this uses $/ by default, you should always pass in a parameter
36313646 if you are worried about other code (modules, etc) modifying $/.
36373652 chunker that splits on newlines:
36383653
36393654 sub line_splitter {
3640 my ( $in_ref, $out_ref ) = @_ ;
3641
3642 return 0 if length $$out_ref ;
3655 my ( $in_ref, $out_ref ) = @_;
3656
3657 return 0 if length $$out_ref;
36433658
36443659 return input_avail && do {
36453660 while (1) {
36463661 if ( $$in_ref =~ s/\A(.*?\n)// ) {
3647 $$out_ref .= $1 ;
3648 return 1 ;
3662 $$out_ref .= $1;
3663 return 1;
36493664 }
3650 my $hmm = get_more_input ;
3665 my $hmm = get_more_input;
36513666 unless ( defined $hmm ) {
3652 $$out_ref = $$in_ref ;
3653 $$in_ref = '' ;
3654 return length $$out_ref ? 1 : 0 ;
3667 $$out_ref = $$in_ref;
3668 $$in_ref = '';
3669 return length $$out_ref ? 1 : 0;
36553670 }
3656 return 0 if $hmm eq 0 ;
3671 return 0 if $hmm eq 0;
36573672 }
36583673 }
3659 } ;
3674 };
36603675
36613676 =cut
36623677
36633678 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 ;
3679 my ( $re ) = @_;
3680 $re = $/ if _empty $re;
3681 $re = quotemeta( $re ) unless ref $re eq 'Regexp';
3682 $re = qr/\A(.*?$re)/s;
36683683
36693684 return sub {
3670 my ( $in_ref, $out_ref ) = @_ ;
3671
3672 return 0 if length $$out_ref ;
3685 my ( $in_ref, $out_ref ) = @_;
3686
3687 return 0 if length $$out_ref;
36733688
36743689 return input_avail && do {
36753690 while (1) {
36763691 if ( $$in_ref =~ s/$re// ) {
3677 $$out_ref .= $1 ;
3678 return 1 ;
3692 $$out_ref .= $1;
3693 return 1;
36793694 }
3680 my $hmm = get_more_input ;
3695 my $hmm = get_more_input;
36813696 unless ( defined $hmm ) {
3682 $$out_ref = $$in_ref ;
3683 $$in_ref = '' ;
3684 return length $$out_ref ? 1 : 0 ;
3697 $$out_ref = $$in_ref;
3698 $$in_ref = '';
3699 return length $$out_ref ? 1 : 0;
36853700 }
3686 return 0 if $hmm eq 0 ;
3701 return 0 if $hmm eq 0;
36873702 }
36883703 }
3689 } ;
3690 }
3691
3704 };
3705 }
3706
3707 =pod
36923708
36933709 =item new_appender
36943710
36983714
36993715 run( \@cmd,
37003716 '<', new_appender( "\n" ), \&commands,
3701 ) ;
3717 );
37023718
37033719 Here's a typical filter sub that might be created by new_appender():
37043720
37053721 sub newline_appender {
3706 my ( $in_ref, $out_ref ) = @_ ;
3722 my ( $in_ref, $out_ref ) = @_;
37073723
37083724 return input_avail && do {
3709 $$out_ref = join( '', $$out_ref, $$in_ref, "\n" ) ;
3710 $$in_ref = '' ;
3711 1 ;
3712 }
3713 } ;
3725 $$out_ref = join( '', $$out_ref, $$in_ref, "\n" );
3726 $$in_ref = '';
3727 1;
3728 }
3729 };
37143730
37153731 =cut
37163732
37173733 sub new_appender($) {
3718 my ( $suffix ) = @_ ;
3719 croak "\$suffix undefined" unless defined $suffix ;
3734 my ( $suffix ) = @_;
3735 croak "\$suffix undefined" unless defined $suffix;
37203736
37213737 return sub {
3722 my ( $in_ref, $out_ref ) = @_ ;
3738 my ( $in_ref, $out_ref ) = @_;
37233739
37243740 return input_avail && do {
3725 $$out_ref = join( '', $$out_ref, $$in_ref, $suffix ) ;
3726 $$in_ref = '' ;
3727 1 ;
3728 }
3729 } ;
3741 $$out_ref = join( '', $$out_ref, $$in_ref, $suffix );
3742 $$in_ref = '';
3743 1;
3744 }
3745 };
37303746 }
37313747
37323748
37333749 sub new_string_source {
3734 my $ref ;
3750 my $ref;
37353751 if ( @_ > 1 ) {
37363752 $ref = [ @_ ],
37373753 }
37383754 else {
3739 $ref = shift ;
3755 $ref = shift;
37403756 }
37413757
37423758 return ref $ref eq 'SCALAR'
37433759 ? sub {
3744 my ( $in_ref, $out_ref ) = @_ ;
3760 my ( $in_ref, $out_ref ) = @_;
37453761
37463762 return defined $$ref
37473763 ? do {
3748 $$out_ref .= $$ref ;
3749 my $r = length $$ref ? 1 : 0 ;
3750 $$ref = undef ;
3751 $r ;
3764 $$out_ref .= $$ref;
3765 my $r = length $$ref ? 1 : 0;
3766 $$ref = undef;
3767 $r;
37523768 }
37533769 : undef
37543770 }
37553771 : sub {
3756 my ( $in_ref, $out_ref ) = @_ ;
3772 my ( $in_ref, $out_ref ) = @_;
37573773
37583774 return @$ref
37593775 ? do {
3760 my $s = shift @$ref ;
3761 $$out_ref .= $s ;
3762 length $s ? 1 : 0 ;
3776 my $s = shift @$ref;
3777 $$out_ref .= $s;
3778 length $s ? 1 : 0;
37633779 }
3764 : undef ;
3780 : undef;
37653781 }
37663782 }
37673783
37683784
37693785 sub new_string_sink {
3770 my ( $string_ref ) = @_ ;
3786 my ( $string_ref ) = @_;
37713787
37723788 return sub {
3773 my ( $in_ref, $out_ref ) = @_ ;
3789 my ( $in_ref, $out_ref ) = @_;
37743790
37753791 return input_avail && do {
3776 $$string_ref .= $$in_ref ;
3777 $$in_ref = '' ;
3778 1 ;
3779 }
3780 } ;
3792 $$string_ref .= $$in_ref;
3793 $$in_ref = '';
3794 1;
3795 }
3796 };
37813797 }
37823798
37833799
37923808 #"HH:MM:SS" format (any non-digit other than '.' may be used as
37933809 #spacing and puctuation). This is probably best shown by example:
37943810 #
3795 # $h->timeout( $val ) ;
3811 # $h->timeout( $val );
37963812 #
37973813 # $val Effect
37983814 # ======================== =====================================
38233839 #=cut
38243840 #
38253841 #sub timeout {
3826 # my IPC::Run $self = shift ;
3842 # my IPC::Run $self = shift;
38273843 #
38283844 # if ( @_ ) {
3829 # ( $self->{TIMEOUT} ) = @_ ;
3830 # $self->{TIMEOUT_END} = undef ;
3845 # ( $self->{TIMEOUT} ) = @_;
3846 # $self->{TIMEOUT_END} = undef;
38313847 # if ( defined $self->{TIMEOUT} ) {
38323848 # 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] ;
3849 # my @f = split( /[^\d\.]+/i, $self->{TIMEOUT} );
3850 # unshift @f, 0 while @f < 3;
3851 # $self->{TIMEOUT} = (($f[0]*60)+$f[1])*60+$f[2];
38363852 # }
38373853 # elsif ( $self->{TIMEOUT} =~ /^(\d*)(?:\.(\d*))/ ) {
3838 # $self->{TIMEOUT} = $1 + 1 ;
3854 # $self->{TIMEOUT} = $1 + 1;
38393855 # }
3840 # $self->_calc_timeout_end if $self->{STATE} >= _started ;
3856 # $self->_calc_timeout_end if $self->{STATE} >= _started;
38413857 # }
38423858 # }
3843 # return $self->{TIMEOUT} ;
3859 # return $self->{TIMEOUT};
38443860 #}
38453861 #
38463862 #
38473863 #sub _calc_timeout_end {
3848 # my IPC::Run $self = shift ;
3864 # my IPC::Run $self = shift;
38493865 #
38503866 # $self->{TIMEOUT_END} = defined $self->{TIMEOUT}
38513867 # ? time + $self->{TIMEOUT}
3852 # : undef ;
3868 # : undef;
38533869 #
38543870 # ## We add a second because we might be at the very end of the current
38553871 # ## second, and we want to guarantee that we don't have a timeout even
38563872 # ## one second less then the timeout period.
3857 # ++$self->{TIMEOUT_END} if $self->{TIMEOUT} ;
3873 # ++$self->{TIMEOUT_END} if $self->{TIMEOUT};
38583874 #}
3875
3876 =pod
38593877
38603878 =item io
38613879
38673885 This is shorthand for
38683886
38693887
3870 require IPC::Run::IO ;
3888 require IPC::Run::IO;
38713889
38723890 ... IPC::Run::IO->new(...) ...
38733891
38743892 =cut
38753893
38763894 sub io {
3877 require IPC::Run::IO ;
3878 IPC::Run::IO->new( @_ ) ;
3879 }
3895 require IPC::Run::IO;
3896 IPC::Run::IO->new( @_ );
3897 }
3898
3899 =pod
38803900
38813901 =item timer
38823902
3883 $h = start( \@cmd, \$in, \$out, $t = timer( 5 ) ) ;
3884
3885 pump $h until $out =~ /expected stuff/ || $t->is_expired ;
3903 $h = start( \@cmd, \$in, \$out, $t = timer( 5 ) );
3904
3905 pump $h until $out =~ /expected stuff/ || $t->is_expired;
38863906
38873907 Instantiates a non-fatal timer. pump() returns once each time a timer
38883908 expires. Has no direct effect on run(), but you can pass a subroutine
38963916 =cut
38973917
38983918 # Doing the prototype suppresses 'only used once' on older perls.
3899 sub timer ;
3900 *timer = \&IPC::Run::Timer::timer ;
3901
3919 sub timer;
3920 *timer = \&IPC::Run::Timer::timer;
3921
3922 =pod
39023923
39033924 =item timeout
39043925
3905 $h = start( \@cmd, \$in, \$out, $t = timeout( 5 ) ) ;
3906
3907 pump $h until $out =~ /expected stuff/ ;
3926 $h = start( \@cmd, \$in, \$out, $t = timeout( 5 ) );
3927
3928 pump $h until $out =~ /expected stuff/;
39083929
39093930 Instantiates a timer that throws an exception when it expires.
39103931 If you don't provide an exception, a default exception that matches
39143935 $h = start(
39153936 \@cmd, \$in, \$out,
39163937 $t = timeout( 5, exception => 'slowpoke' ),
3917 ) ;
3938 );
39183939
39193940 or set the name used in debugging message and in the default exception
39203941 string:
39233944 \@cmd, \$in, \$out,
39243945 timeout( 50, name => 'process timer' ),
39253946 $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/ ;
3947 );
3948
3949 pump $h until $out =~ /started/;
3950
3951 $in = 'command 1';
3952 $stall_timer->start;
3953 pump $h until $out =~ /command 1 finished/;
3954
3955 $in = 'command 2';
3956 $stall_timer->start;
3957 pump $h until $out =~ /command 2 finished/;
3958
3959 $in = 'very slow command 3';
3960 $stall_timer->start( 10 );
3961 pump $h until $out =~ /command 3 finished/;
3962
3963 $stall_timer->start( 5 );
3964 $in = 'command 4';
3965 pump $h until $out =~ /command 4 finished/;
39453966
39463967 $stall_timer->reset; # Prevent restarting or expirng
3947 finish $h ;
3968 finish $h;
39483969
39493970 See L</timer> for building non-fatal timers.
39503971
39533974 =cut
39543975
39553976 # Doing the prototype suppresses 'only used once' on older perls.
3956 sub timeout ;
3957 *timeout = \&IPC::Run::Timer::timeout ;
3958
3977 sub timeout;
3978 *timeout = \&IPC::Run::Timer::timeout;
3979
3980 =pod
39593981
39603982 =back
39613983
39784000
39794001 return input_avail && do {
39804002 ## process the input just gotten
3981 1 ;
3982 } ;
4003 1;
4004 };
39834005
39844006 This technique allows input_avail to return the undef or 0 that a
39854007 filter normally returns when there's no input to process. If a filter
39864008 stores intermediate values, however, it will need to react to an
39874009 undef:
39884010
3989 my $got = input_avail ;
4011 my $got = input_avail;
39904012 if ( ! defined $got ) {
39914013 ## No more input ever, flush internal buffers to $out_ref
39924014 }
3993 return $got unless $got ;
4015 return $got unless $got;
39944016 ## Got some input, move as much as need be
3995 return 1 if $added_to_out_ref ;
4017 return 1 if $added_to_out_ref;
39964018
39974019 =cut
39984020
39994021 sub input_avail() {
40004022 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
4023 unless defined $filter_op->{FBUFS}->[$filter_num+1];
4024 length ${$filter_op->{FBUFS}->[$filter_num+1]} || get_more_input;
4025 }
4026
4027 =pod
40054028
40064029 =item get_more_input
40074030
40184041 ## Filter implementation interface
40194042 ##
40204043 sub get_more_input() {
4021 ++$filter_num ;
4044 ++$filter_num;
40224045 my $r = eval {
40234046 confess "get_more_input() called and no more filters in chain"
4024 unless defined $filter_op->{FILTERS}->[$filter_num] ;
4047 unless defined $filter_op->{FILTERS}->[$filter_num];
40254048 $filter_op->{FILTERS}->[$filter_num]->(
40264049 $filter_op->{FBUFS}->[$filter_num+1],
40274050 $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
4051 ); # if defined ${$filter_op->{FBUFS}->[$filter_num+1]};
4052 };
4053 --$filter_num;
4054 die $@ if $@;
4055 return $r;
4056 }
4057
4058 1;
4059
4060 =pod
41914061
41924062 =back
41934063
43654235 my $in = "\n" x ($pipebuf * 2) . "end\n";
43664236 my $out;
43674237
4368 $SIG{ALRM} = sub { die "Never completed!\n" } ;
4238 $SIG{ALRM} = sub { die "Never completed!\n" };
43694239
43704240 print "reading from scalar via pipe...";
4371 alarm( 2 ) ;
4241 alarm( 2 );
43724242 run(makecmd($pipebuf * 2), '<', \$in, '>', \$out);
43734243 alarm( 0 );
43744244 print "done\n";
43754245
43764246 print "reading from code via pipe... ";
4377 alarm( 2 ) ;
4247 alarm( 2 );
43784248 run(makecmd($pipebuf * 3), '<', sub { $t = $in; undef $in; $t}, '>', \$out);
4379 alarm( 0 ) ;
4249 alarm( 0 );
43804250 print "done\n";
43814251
43824252 $pty = IO::Pty->new();
43874257 $in = "\n" x ($ptybuf * 3) . "end\n";
43884258
43894259 print "reading via pty... ";
4390 alarm( 2 ) ;
4260 alarm( 2 );
43914261 run(makecmd($ptybuf * 3), '<pty<', \$in, '>', \$out);
43924262 alarm(0);
43934263 print "done\n";
44034273 \cmd,
44044274 ...
44054275 init => sub {
4406 chdir $dir or die $! ;
4276 chdir $dir or die $!;
44074277 $ENV{FOO}='BAR'
44084278 }
4409 ) ;
4279 );
44104280
44114281 Timeout calculation does not allow absolute times, or specification of
44124282 days, months, etc.
44384308
44394309 =item Allow one harness to "adopt" another:
44404310
4441 $new_h = harness \@cmd2 ;
4442 $h->adopt( $new_h ) ;
4311 $new_h = harness \@cmd2;
4312 $h->adopt( $new_h );
44434313
44444314 =item Close all filehandles not explicitly marked to stay open.
44454315
44664336
44674337 Message ylln51p2b6.fsf@windlord.stanford.edu, on 2000/02/04.
44684338
4469 =head1 AUTHOR
4470
4471 Barrie Slaymaker <barries@slaysys.com>, with numerous suggestions by p5p.
4339 =head1 SUPPORT
4340
4341 Bugs should always be submitted via the CPAN bug tracker
4342
4343 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=IPC-Run>
4344
4345 For other issues, contact the maintainer (the first listed author)
4346
4347 =head1 AUTHORS
4348
4349 Adam Kennedy <adamk@cpan.org>
4350
4351 Barrie Slaymaker <barries@slaysys.com>
4352
4353 =head1 COPYRIGHT
4354
4355 Some parts copyright 2008 Adam Kennedy.
4356
4357 Copyright 1999 Barrie Slaymaker.
4358
4359 You may distribute under the terms of either the GNU General Public
4360 License or the Artistic License, as specified in the README file.
44724361
44734362 =cut
4474
4475 1 ;
+69
-100
t/adopt.t less more
0 #!/usr/bin/perl -w
0 #!/usr/bin/perl
1
2 =pod
13
24 =head1 NAME
35
57
68 =cut
79
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 }
10 use strict;
11 BEGIN {
12 $| = 1;
13 $^W = 1;
14 if( $ENV{PERL_CORE} ) {
15 chdir '../lib/IPC/Run' if -d '../lib/IPC/Run';
16 unshift @INC, 'lib', '../..';
17 $^X = '../../../t/' . $^X;
18 }
1419 }
1520
16
17 use strict ;
18
19 use Test ;
20
21 use IPC::Run qw( start pump finish ) ;
22 use UNIVERSAL qw( isa ) ;
21 use Test::More skip_all => 'adopt not implemented yet';
22 # use Test::More tests => 29;
23 use IPC::Run qw( start pump finish );
2324
2425 ##
2526 ## $^X is the path to the perl binary. This is used run all the subprocesses.
2627 ##
27 my @echoer = ( $^X, '-pe', 'BEGIN { $| = 1 }' ) ;
28 my @echoer = ( $^X, '-pe', 'BEGIN { $| = 1 }' );
2829
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 = (
4230 ##
4331 ## harness, pump, run
4432 ##
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 ) },
33 SCOPE: {
34 my $in = 'SHOULD BE UNCHANGED';
35 my $out = 'REPLACE ME';
36 $? = 99;
37 my $fd_map = IPC::Run::_map_fds();
38 my $h = start( \@echoer, \$in, \$out );
39 ok( $h->isa('IPC::Run') );
40 ok( $?, 99 );
41 ok( $in, 'SHOULD BE UNCHANGED' );
42 ok( $out, '' );
43 ok( $h->pumpable );
44 $in = '';
45 $? = 0;
46 pump_nb $h for ( 1..100 );
47 ok( 1 );
48 ok( $in, '' );
49 ok( $out, '' );
50 ok( $h->pumpable );
51 }
5452
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 ) ;
53 SCOPE: {
54 my $in = 'SHOULD BE UNCHANGED';
55 my $out = 'REPLACE ME';
56 $? = 99;
57 my $fd_map = IPC::Run::_map_fds();
58 my $h = start( \@echoer, \$in, \$out );
59 ok( $h->isa('IPC::Run') );
60 ok( $?, 99 );
61 ok( $in, 'SHOULD BE UNCHANGED' );
62 ok( $out, '' );
63 ok( $h->pumpable );
64 $in = "hello\n";
65 $? = 0;
66 pump $h until $out =~ /hello/;
67 ok( 1 );
68 ok( ! $? );
69 ok( $in, '' );
70 ok( $out, "hello\n" );
71 ok( $h->pumpable );
72 $in = "world\n";
73 $? = 0;
74 pump $h until $out =~ /world/;
75 ok( 1 );
76 ok( ! $? );
77 ok( $in, '' );
78 ok( $out, "hello\nworld\n" );
79 ok( $h->pumpable );
80 warn "hi";
81 ok( $h->finish );
82 ok( ! $? );
83 ok( IPC::Run::_map_fds(), $fd_map );
84 ok( $out, "hello\nworld\n" );
85 ok( ! $h->pumpable );
86 }
+56
-60
t/binmode.t less more
0 #!/usr/bin/perl -w
0 #!/usr/bin/perl
1
2 =pod
13
24 =head1 NAME
35
57
68 =cut
79
10 use strict;
811 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 }
12 $| = 1;
13 $^W = 1;
14 if( $ENV{PERL_CORE} ) {
15 chdir '../lib/IPC/Run' if -d '../lib/IPC/Run';
16 unshift @INC, 'lib', '../..';
17 $^X = '../../../t/' . $^X;
18 }
1419 }
1520
1621 ## Handy to have when our output is intermingled with debugging output sent
1722 ## to the debugging fd.
18 $| = 1 ;
19 select STDERR ; $| = 1 ; select STDOUT ;
23 select STDERR;
24 select STDOUT;
2025
21 use strict ;
26 use Test::More tests => 24;
27 use IPC::Run qw( harness run binary );
2228
23 use Test ;
29 sub Win32_MODE();
30 *Win32_MODE = \&IPC::Run::Win32_MODE;
2431
25 use IPC::Run qw( harness run binary ) ;
32 my $crlf_text = "Hello World\r\n";
2633
27 sub Win32_MODE() ;
28 *Win32_MODE = \&IPC::Run::Win32_MODE ;
34 my $text = $crlf_text;
35 $text =~ s/\r//g if Win32_MODE;
2936
30 my $crlf_text = "Hello World\r\n" ;
37 my $nl_text = $crlf_text;
38 $nl_text =~ s/\r//g;
3139
32 my $text = $crlf_text ;
33 $text =~ s/\r//g if Win32_MODE ;
40 my @perl = ( $^X );
3441
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 my $emitter_script = q{ binmode STDOUT; print "Hello World\r\n" };
43 my @emitter = ( @perl, '-e', $emitter_script );
4244
4345 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 q{ binmode STDIN; $_ = join "", <>; s/([\000-\037])/sprintf "\\\\0x%02x", ord $1/ge; print };
47 my @reporter = ( @perl, '-e', $reporter_script );
4648
47 my $in ;
48 my $out ;
49 my $err ;
49 my $in;
50 my $out;
51 my $err;
5052
5153 sub f($) {
52 my $s = shift ;
53 $s =~ s/([\000-\027])/sprintf "\\0x%02x", ord $1/ge ;
54 my $s = shift;
55 $s =~ s/([\000-\027])/sprintf "\\0x%02x", ord $1/ge;
5456 $s
5557 }
5658
57 my @tests = (
5859 ## 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 },
60 is( eval { harness [], '>', binary, \$out } ? 1 : $@, 1 );
61 is( eval { harness [], '>', binary, "foo" } ? 1 : $@, 1 );
62 is( eval { harness [], '<', binary, \$in } ? 1 : $@, 1 );
63 is( eval { harness [], '<', binary, "foo" } ? 1 : $@, 1 );
6364
6465 ## 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" },
66 ok( run( \@emitter, ">", \$out ) );
67 is( f($out), f($text), "no binary" );
6768
68 sub { ok run \@emitter, ">", binary, \$out },
69 sub { ok f $out, f $crlf_text, "out binary" },
69 ok( run( \@emitter, ">", binary, \$out ) );
70 is( f($out), f($crlf_text), "out binary" );
7071
71 sub { ok run \@emitter, ">", binary( 0 ), \$out },
72 sub { ok f $out, f $text, "out binary 0" },
72 ok( run( \@emitter, ">", binary( 0 ), \$out ) );
73 is( f($out), f($text), "out binary 0" );
7374
74 sub { ok run \@emitter, ">", binary( 1 ), \$out },
75 sub { ok f $out, f $crlf_text, "out binary 1" },
75 ok( run( \@emitter, ">", binary( 1 ), \$out ) );
76 is( f($out), f($crlf_text), "out binary 1" );
7677
7778 ## Test to-kid
78 sub { ok run \@reporter, "<", \$nl_text, ">", \$out },
79 sub { ok $out, "Hello World" . ( Win32_MODE ? "\\0x0d" : "" ) . "\\0x0a", "reporter < \\n" },
79 ok( run( \@reporter, "<", \$nl_text, ">", \$out ) );
80 is( $out, "Hello World" . ( Win32_MODE ? "\\0x0d" : "" ) . "\\0x0a", "reporter < \\n" );
8081
81 sub { ok run \@reporter, "<", binary, \$nl_text, ">", \$out },
82 sub { ok $out, "Hello World\\0x0a", "reporter < binary \\n" },
82 ok( run( \@reporter, "<", binary, \$nl_text, ">", \$out ) );
83 is( $out, "Hello World\\0x0a", "reporter < binary \\n" );
8384
84 sub { ok run \@reporter, "<", binary, \$crlf_text, ">", \$out },
85 sub { ok $out, "Hello World\\0x0d\\0x0a", "reporter < binary \\r\\n" },
85 ok( run( \@reporter, "<", binary, \$crlf_text, ">", \$out ) );
86 is( $out, "Hello World\\0x0d\\0x0a", "reporter < binary \\r\\n" );
8687
87 sub { ok run \@reporter, "<", binary( 0 ), \$nl_text, ">", \$out },
88 sub { ok $out, "Hello World" . ( Win32_MODE ? "\\0x0d" : "" ) . "\\0x0a", "reporter < binary(0) \\n" },
88 ok( run( \@reporter, "<", binary( 0 ), \$nl_text, ">", \$out ) );
89 is( $out, "Hello World" . ( Win32_MODE ? "\\0x0d" : "" ) . "\\0x0a", "reporter < binary(0) \\n" );
8990
90 sub { ok run \@reporter, "<", binary( 1 ), \$nl_text, ">", \$out },
91 sub { ok $out, "Hello World\\0x0a", "reporter < binary(1) \\n" },
91 ok( run( \@reporter, "<", binary( 1 ), \$nl_text, ">", \$out ) );
92 is( $out, "Hello World\\0x0a", "reporter < binary(1) \\n" );
9293
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 ) ;
94 ok( run( \@reporter, "<", binary( 1 ), \$crlf_text, ">", \$out ) );
95 is( $out, "Hello World\\0x0d\\0x0a", "reporter < binary(1) \\r\\n" );
+31
-53
t/bogus.t less more
0 #!/usr/bin/perl -w
0 #!/usr/bin/perl
1
2 =pod
13
24 =head1 NAME
35
57
68 =cut
79
10 use strict;
811 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 }
12 $| = 1;
13 $^W = 1;
14 if( $ENV{PERL_CORE} ) {
15 chdir '../lib/IPC/Run' if -d '../lib/IPC/Run';
16 unshift @INC, 'lib', '../..';
17 $^X = '../../../t/' . $^X;
18 }
1419 }
1520
21 use Test::More tests => 2;
22 use IPC::Run qw( start );
1623
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 ;
24 SCOPE: {
25 ## Older Test.pm's don't grok qr// in $expected.
26 my $expected = 'file not found';
27 eval { start ["./bogus_really_bogus"] };
28 my $got = $@ =~ $expected ? $expected : $@ || "";
29 is( $got, $expected, "starting ./bogus_really_bogus" );
4130 }
4231
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 },
32 SKIP: {
33 if ( IPC::Run::Win32_MODE() ) {
34 skip "Can't really exec() $^O", 1;
35 }
5136
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 ) ;
37 ## Older Test.pm's don't grok qr// in $expected.
38 my $expected = 'exec failed';
39 my $h = eval {
40 start( [$^X, "-e", 1], _simulate_exec_failure => 1 );
41 };
42 my $got = $@ =~ $expected ? $expected : $@ || "";
43 is( $got, $expected, "starting $^X with simulated_exec_failure => 1" );
44 }
+48
-56
t/filter.t less more
0 #!/usr/bin/perl -w
0 #!/usr/bin/perl
1
2 =pod
13
24 =head1 NAME
35
57
68 =cut
79
10 use strict;
811 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 }
12 $| = 1;
13 $^W = 1;
14 if( $ENV{PERL_CORE} ) {
15 chdir '../lib/IPC/Run' if -d '../lib/IPC/Run';
16 unshift @INC, 'lib', '../..';
17 $^X = '../../../t/' . $^X;
18 }
1419 }
1520
16 use strict ;
17
18 use Test ;
19
20 use IPC::Run qw( :filters :filter_imp filter_tests ) ;
21 use Test::More tests => 80;
22 use t::lib::Test;
23 use IPC::Run qw( :filters :filter_imp );
2124
2225 sub uc_filter {
23 my ( $in_ref, $out_ref ) = @_ ;
26 my ( $in_ref, $out_ref ) = @_;
2427
2528 return input_avail && do {
26 $$out_ref .= uc( $$in_ref ) ;
27 $$in_ref = '' ;
28 1 ;
29 $$out_ref .= uc( $$in_ref );
30 $$in_ref = '';
31 1;
2932 }
3033 }
3134
32
33 my $string ;
35 my $string;
3436
3537 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 ;
38 my ( $in_ref, $out_ref ) = @_;
39 return undef unless defined $string;
40 $$out_ref .= $string;
41 $string = undef;
42 return 1;
43 }
44
45 my $accum;
46
47 sub accum {
48 my ( $in_ref, $out_ref ) = @_;
49 return input_avail && do {
50 $accum .= $$in_ref;
51 $$in_ref = '';
52 1;
53 };
4154 }
4255
4356
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 my $op;
5758
5859 ## "import" the things we're testing.
59 *_init_filters = \&IPC::Run::_init_filters ;
60 *_do_filters = \&IPC::Run::_do_filters ;
60 *_init_filters = \&IPC::Run::_init_filters;
61 *_do_filters = \&IPC::Run::_do_filters;
6162
63 filter_tests( "filter_tests", "hello world", "hello world" );
64 filter_tests( "filter_tests []", [qq(hello world)], [qq(hello world)] );
65 filter_tests( "filter_tests [] 2", [qw(hello world)], [qw(hello world)] );
6266
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 ),
67 filter_tests( "uc_filter", "hello world", "HELLO WORLD", \&uc_filter );
7068
7169 filter_tests(
7270 "chunking_filter by lines 1",
7371 "hello 1\nhello 2\nhello 3",
7472 ["hello 1\n", "hello 2\n", "hello 3"],
7573 new_chunker
76 ),
74 );
7775
7876 filter_tests(
7977 "chunking_filter by lines 2",
8078 "hello 1\nhello 2\nhello 3",
8179 ["hello 1\n", "hello 2\n", "hello 3"],
8280 new_chunker
83 ),
81 );
8482
8583 filter_tests(
8684 "chunking_filter by lines 2",
8785 [split( /(\s|\n)/, "hello 1\nhello 2\nhello 3" )],
8886 ["hello 1\n", "hello 2\n", "hello 3"],
8987 new_chunker
90 ),
88 );
9189
9290 filter_tests(
9391 "chunking_filter by an odd separator",
9492 "hello world",
9593 "hello world",
9694 new_chunker( 'odd separator' )
97 ),
95 );
9896
9997 filter_tests(
10098 "chunking_filter 2",
10199 "hello world",
102100 ['hello world' =~ m/(.)/g],
103101 new_chunker( qr/./ )
104 ),
102 );
105103
106104 filter_tests(
107105 "appending_filter",
108106 [qw( 1 2 3 )],
109107 [qw( 1a 2a 3a )],
110108 new_appender("a")
111 ),
112 ) ;
113
114 plan tests => scalar @tests ;
115
116 $_->() for ( @tests ) ;
117
109 );
+111
-125
t/harness.t less more
0 #!/usr/bin/perl -w
0 #!/usr/bin/perl
1
2 =pod
13
24 =head1 NAME
35
57
68 =cut
79
10 use strict;
811 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 }
12 $| = 1;
13 $^W = 1;
14 if( $ENV{PERL_CORE} ) {
15 chdir '../lib/IPC/Run' if -d '../lib/IPC/Run';
16 unshift @INC, 'lib', '../..';
17 $^X = '../../../t/' . $^X;
18 }
1419 }
1520
16 use strict ;
21 use Test::More tests => 120;
22 use IPC::Run qw( harness );
1723
18 use Test ;
19
20 use IPC::Run qw( harness ) ;
21
22 my $f ;
24 my $f;
2325
2426 sub expand_test {
25 my ( $args, $expected ) = @_ ;
27 my ( $args, $expected ) = @_;
28 my $h;
29 my @out;
30 my $i = 0;
31 SCOPE: {
32 $h = IPC::Run::harness( @$args );
33 @out = @{$h->{KIDS}->[0]->{OPS}};
34 is(
35 scalar( @out ),
36 scalar( @$expected ),
37 join( ' ', @$args )
38 )
39 }
2640
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 ) ;
41 foreach my $h ( @$expected ) {
42 my $j = $i++;
43 foreach ( sort keys %$h ) {
44 my ( $key, $value ) = ( $_, $h->{$_} );
45 my $got = $out[$j]->{$key};
46 $got = @$got if ref $got eq 'ARRAY';
47 $got = '<undef>' unless defined $got;
48 is( $got, $value, join( ' ', @$args ) . ": $j, $key" )
49 }
50 }
5451 }
5552
53 expand_test(
54 [ ['a'], qw( <b < c 0<d 0< e 1<f 1< g) ],
55 [
56 { TYPE => '<', SOURCE => 'b', KFD => 0, },
57 { TYPE => '<', SOURCE => 'c', KFD => 0, },
58 { TYPE => '<', SOURCE => 'd', KFD => 0, },
59 { TYPE => '<', SOURCE => 'e', KFD => 0, },
60 { TYPE => '<', SOURCE => 'f', KFD => 1, },
61 { TYPE => '<', SOURCE => 'g', KFD => 1, },
62 ]
63 );
5664
65 expand_test(
66 [ ['a'], qw( >b > c 2>d 2> e >>f >> g 2>>h 2>> i) ],
67 [
68 { TYPE => '>', DEST => 'b', KFD => 1, TRUNC => 1, },
69 { TYPE => '>', DEST => 'c', KFD => 1, TRUNC => 1, },
70 { TYPE => '>', DEST => 'd', KFD => 2, TRUNC => 1, },
71 { TYPE => '>', DEST => 'e', KFD => 2, TRUNC => 1, },
72 { TYPE => '>', DEST => 'f', KFD => 1, TRUNC => '', },
73 { TYPE => '>', DEST => 'g', KFD => 1, TRUNC => '', },
74 { TYPE => '>', DEST => 'h', KFD => 2, TRUNC => '', },
75 { TYPE => '>', DEST => 'i', KFD => 2, TRUNC => '', },
76 ]
77 );
5778
58 my @tests = (
79 expand_test(
80 [ ['a'], qw( >&b >& c &>d &> e ) ],
81 [
82 { TYPE => '>', DEST => 'b', KFD => 1, TRUNC => 1, },
83 { TYPE => 'dup', KFD1 => 1, KFD2 => 2 },
84 { TYPE => '>', DEST => 'c', KFD => 1, TRUNC => 1, },
85 { TYPE => 'dup', KFD1 => 1, KFD2 => 2 },
86 { TYPE => '>', DEST => 'd', KFD => 1, TRUNC => 1, },
87 { TYPE => 'dup', KFD1 => 1, KFD2 => 2 },
88 { TYPE => '>', DEST => 'e', KFD => 1, TRUNC => 1, },
89 { TYPE => 'dup', KFD1 => 1, KFD2 => 2 },
90 ]
91 );
5992
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 ),
93 expand_test(
94 [ ['a'],
95 '>&', sub{}, sub{}, \$f,
96 '>', sub{}, sub{}, \$f,
97 '<', sub{}, sub{}, \$f,
98 ],
99 [
100 { TYPE => '>', DEST => \$f, KFD => 1, TRUNC => 1,
101 FILTERS => 2 },
102 { TYPE => 'dup', KFD1 => 1, KFD2 => 2 },
103 { TYPE => '>', DEST => \$f, KFD => 1, TRUNC => 1,
104 FILTERS => 2 },
105 { TYPE => '<', SOURCE => \$f, KFD => 0,
106 FILTERS => 3 },
107 ]
108 );
71109
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 ),
110 expand_test(
111 [ ['a'], '<', \$f, '>', \$f ],
112 [
113 { TYPE => '<', SOURCE => \$f, KFD => 0, },
114 { TYPE => '>', DEST => \$f, KFD => 1, },
115 ]
116 );
85117
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 ),
118 expand_test(
119 [ ['a'], '<pipe', \$f, '>pipe', \$f ],
120 [
121 { TYPE => '<pipe', SOURCE => \$f, KFD => 0, },
122 { TYPE => '>pipe', DEST => \$f, KFD => 1, },
123 ]
124 );
99125
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
126 expand_test(
127 [ ['a'], '<pipe', \$f, '>', \$f ],
128 [
129 { TYPE => '<pipe', SOURCE => \$f, KFD => 0, },
130 { TYPE => '>', DEST => \$f, KFD => 1, },
131 ]
132 );
+77
-94
t/io.t less more
0 #!/usr/bin/perl -w
0 #!/usr/bin/perl
1
2 =pod
13
24 =head1 NAME
35
57
68 =cut
79
10 use strict;
811 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 }
12 $| = 1;
13 $^W = 1;
14 if( $ENV{PERL_CORE} ) {
15 chdir '../lib/IPC/Run' if -d '../lib/IPC/Run';
16 unshift @INC, 'lib', '../..';
17 $^X = '../../../t/' . $^X;
18 }
1419 }
1520
16 use strict ;
21 use Test::More tests => 14;
22 use IPC::Run qw( :filters run io );
23 use IPC::Run::Debug qw( _map_fds );
1724
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' )} ;
25 my $text = "Hello World\n";
26 my $emitter_script = qq{print '$text'; print STDERR uc( '$text' )};
3627 ##
3728 ## $^X is the path to the perl binary. This is used run all the subprocesses.
3829 ##
39 my @perl = ( $^X ) ;
40 my @emitter = ( @perl, '-e', $emitter_script ) ;
30 my @perl = ( $^X );
31 my @emitter = ( @perl, '-e', $emitter_script );
4132
42 my $recv ;
43 my $send ;
33 my $recv;
34 my $send;
4435
45 my $in_file = 'io.t.in' ;
46 my $out_file = 'io.t.out' ;
47 my $err_file = 'io.t.err' ;
36 my $in_file = 'io.t.in';
37 my $out_file = 'io.t.out';
38 my $err_file = 'io.t.err';
4839
49 my $io ;
50 my $r ;
40 my $io;
41 my $r;
5142
52 my $fd_map ;
43 my $fd_map;
5344
5445 ## TODO: Test filters, etc.
5546
5647 sub slurp($) {
57 my ( $f ) = @_ ;
58 open( S, "<$f" ) or return "$! '$f'" ;
59 my $r = join( '', <S> ) ;
48 my ( $f ) = @_;
49 open( S, "<$f" ) or return "$! '$f'";
50 my $r = join( '', <S> );
6051 close S or warn "$! closing '$f'";
61 return $r ;
52 return $r;
6253 }
6354
64
6555 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'" ;
56 my ( $f, $s ) = @_;
57 open( S, ">$f" ) or die "$! '$f'";
58 print S $s or die "$! '$f'";
59 close S or die "$! '$f'";
7060 }
7161
7262 sub wipe($) {
73 my ( $f ) = @_ ;
74 unlink $f or warn "$! unlinking '$f'" if -f $f ;
63 my ( $f ) = @_;
64 unlink $f or warn "$! unlinking '$f'" if -f $f;
7565 }
7666
67 $io = io( 'foo', '<', \$send );
68 ok $io->isa('IPC::Run::IO');
7769
70 is( io( 'foo', '<', \$send )->mode, 'w' );
71 is( io( 'foo', '<<', \$send )->mode, 'wa' );
72 is( io( 'foo', '>', \$recv )->mode, 'r' );
73 is( io( 'foo', '>>', \$recv )->mode, 'ra' );
7874
79 my @tests = (
80 ##
81 ## Parsing
82 ##
83 sub {
84 $io = io( 'foo', '<', \$send ) ;
85 ok isa $io, 'IPC::Run::IO' ;
86 },
75 SKIP: {
76 if ( IPC::Run::Win32_MODE() ) {
77 skip( "$^O does not allow select() on non-sockets", 9 );
78 }
8779
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' ) },
80 ##
81 ## Input from a file
82 ##
83 SCOPE: {
84 spit $in_file, $text;
85 $recv = 'REPLACE ME';
86 $fd_map = _map_fds;
87 $r = run io( $in_file, '>', \$recv );
88 wipe $in_file;
89 ok( $r );
90 }
9291
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 ) },
92 ok( ! $? );
93 is( _map_fds, $fd_map );
94 is( $recv, $text );
10695
107 skip_unless_select { ok( $recv, $text ) },
96 ##
97 ## Output to a file
98 ##
99 SCOPE: {
100 wipe $out_file;
101 $send = $text;
102 $fd_map = _map_fds;
103 $r = run io( $out_file, '<', \$send );
104 $recv = slurp $out_file;
105 wipe $out_file;
106 ok( $r );
107 }
108108
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 ) ;
109 ok( ! $? );
110 is( _map_fds, $fd_map );
111 is( $send, $text );
112 is( $recv, $text );
113 }
+45
-42
t/kill_kill.t less more
0 #!/usr/bin/perl -w
0 #!/usr/bin/perl
1
2 =pod
13
24 =head1 NAME
35
4 kill_kill.t - Test suite IPC::Run->kill_kill
6 kill_kill.t - Test suite for IPC::Run->kill_kill
57
68 =cut
79
810 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 }
11 $| = 1;
12 $^W = 1;
13 if( $ENV{PERL_CORE} ) {
14 chdir '../lib/IPC/Run' if -d '../lib/IPC/Run';
15 unshift @INC, 'lib', '../..';
16 $^X = '../../../t/' . $^X;
17 }
1418 }
1519
20 use strict;
21 use Test::More;
22 use IPC::Run ();
1623
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 ;
24 # Don't run this test script on Windows at all
25 if ( IPC::Run::Win32_MODE() ) {
26 plan( skip_all => 'Temporarily ignoring test failure on Win32' );
27 exit(0);
28 } else {
29 plan( tests => 2 );
3030 }
3131
32 my @quiter = ( $^X, '-e', 'sleep while 1' ) ;
33 my @zombie00 = ( $^X, '-e', '$SIG{TERM}=sub{};$|=1;print "running\n";sleep while 1');
32 # Test 1
33 SCOPE: {
34 my $h = IPC::Run::start( [
35 $^X,
36 '-e',
37 'sleep while 1',
38 ] );
3439
35 my @tests = (
36 sub {
37 my $h = start \@quiter ;
38 my $needed_kill = $h->kill_kill ; # grace => 2 ) ;
39 ok ! $needed_kill ;
40 },
40 my $needed = $h->kill_kill;
41 ok( ! $needed, 'Did not need kill_kill' );
42 }
4143
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 },
44 # Test 2
45 SKIP: {
46 if ( IPC::Run::Win32_MODE() ) {
47 skip("$^O does not support ignoring the TERM signal", 1);
48 }
4949
50 ## not testing coredumps; some systems don't provide them. #'
51
52 ) ;
53
54 plan tests => scalar @tests ;
55
56 $_->() for ( @tests ) ;
50 my $out;
51 my $h = IPC::Run::start( [
52 $^X,
53 '-e',
54 '$SIG{TERM}=sub{};$|=1;print "running\n";sleep while 1',
55 ], \undef, \$out );
56 pump $h until $out =~ /running/;
57 my $needed = $h->kill_kill( grace => 1 );
58 ok( $needed, 'Did not need kill_kill' );
59 }
+161
-0
t/lib/Test.pm less more
0 package t::lib::Test;
1
2 use strict;
3 use Test::More;
4 use Exporter;
5 use IPC::Run qw{ harness };
6 use IPC::Run::IO;
7
8 use vars qw{@ISA @EXPORT};
9 BEGIN {
10 @ISA = qw{ Exporter };
11 @EXPORT = qw{ filter_tests };
12 }
13
14 ## This is not needed by most users. Should really move to IPC::Run::TestUtils
15 #=item filter_tests
16 #
17 # my @tests = filter_tests( "foo", "in", "out", \&filter );
18 # $_->() for ( @tests );
19 #
20 #This creates a list of test subs that can be used to test most filters
21 #for basic functionality. The first parameter is the name of the
22 #filter to be tested, the second is sample input, the third is the
23 #test(s) to apply to the output(s), and the rest of the parameters are
24 #the filters to be linked and tested.
25 #
26 #If the filter chain is to be fed multiple inputs in sequence, the second
27 #parameter should be a reference to an array of thos inputs:
28 #
29 # my @tests = filter_tests( "foo", [qw(1 2 3)], "123", \&filter );
30 #
31 #If the filter chain should produce a sequence of outputs, then the
32 #thrid parameter should be a reference to an array of those outputs:
33 #
34 # my @tests = filter_tests(
35 # "foo",
36 # "1\n\2\n",
37 # [ qr/^1$/, qr/^2$/ ],
38 # new_chunker
39 # );
40 #
41 #See t/run.t and t/filter.t for an example of this in practice.
42 #
43 #=cut
44
45 ##
46 ## Filter testing routines
47 ##
48 sub filter_tests($;@) {
49 my ( $name, $in, $exp, @filters ) = @_;
50 my @in = ref $in eq 'ARRAY' ? @$in : ( $in );
51 my @exp = ref $exp eq 'ARRAY' ? @$exp : ( $exp );
52 my IPC::Run::IO $op;
53 my $output;
54 my @input;
55 my $in_count = 0;
56 my @out;
57 my $h;
58
59 SCOPE: {
60 $h = harness();
61 $op = IPC::Run::IO->_new_internal( '<', 0, 0, 0, undef,
62 IPC::Run::new_string_sink( \$output ),
63 @filters,
64 IPC::Run::new_string_source( \@input ),
65 );
66 $op->_init_filters;
67 @input = ();
68 $output = '';
69 is(
70 ! defined $op->_do_filters( $h ),
71 1,
72 "$name didn't pass undef (EOF) through"
73 );
74 };
75
76 ## See if correctly does nothing on 0, (please try again)
77 SCOPE: {
78 $op->_init_filters;
79 $output = '';
80 @input = ( '' );
81 is(
82 $op->_do_filters( $h ),
83 0,
84 "$name didn't return 0 (please try again) when given a 0"
85 );
86 };
87
88 SCOPE: {
89 @input = ( '' );
90 is(
91 $op->_do_filters( $h ),
92 0,
93 "$name didn't return 0 (please try again) when given a second 0"
94 );
95 };
96
97 SCOPE: {
98 for (1..100) {
99 last unless defined $op->_do_filters( $h );
100 }
101 is(
102 ! defined $op->_do_filters( $h ),
103 1,
104 "$name didn't return undef (EOF) after two 0s and an undef"
105 );
106 };
107
108 ## See if it can take @in and make @out
109 SCOPE: {
110 $op->_init_filters;
111 $output = '';
112 @input = @in;
113 while ( defined $op->_do_filters( $h ) && @input ) {
114 if ( length $output ) {
115 push @out, $output;
116 $output = '';
117 }
118 }
119 if ( length $output ) {
120 push @out, $output;
121 $output = '';
122 }
123 is(
124 scalar @input,
125 0,
126 "$name didn't consume it's input"
127 );
128 };
129
130 SCOPE: {
131 for (1..100) {
132 last unless defined $op->_do_filters( $h );
133 if ( length $output ) {
134 push @out, $output;
135 $output = '';
136 }
137 }
138 is(
139 ! defined $op->_do_filters( $h ),
140 1,
141 "$name didn't return undef (EOF), tried 100 times"
142 );
143 };
144
145 SCOPE: {
146 is(
147 join( ', ', map "'$_'", @out ),
148 join( ', ', map "'$_'", @exp ),
149 $name
150 )
151 };
152
153 SCOPE: {
154 ## Force the harness to be cleaned up.
155 $h = undef;
156 ok( 1 );
157 };
158 }
159
160 1;
+33
-92
t/parallel.t less more
0 #!/usr/bin/perl -w
0 #!/usr/bin/perl
1
2 =pod
13
24 =head1 NAME
35
57
68 =cut
79
10 use strict;
811 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 }
12 $| = 1;
13 $^W = 1;
14 if( $ENV{PERL_CORE} ) {
15 chdir '../lib/IPC/Run' if -d '../lib/IPC/Run';
16 unshift @INC, 'lib', '../..';
17 $^X = '../../../t/' . $^X;
18 }
1419 }
1520
1621 ## Handy to have when our output is intermingled with debugging output sent
1722 ## to the debugging fd.
18 $| = 1 ;
19 select STDERR ; $| = 1 ; select STDOUT ;
23 select STDERR;
24 select STDOUT;
2025
21 use strict ;
26 use Test::More tests => 6;
27 use IPC::Run qw( start pump finish );
2228
23 use Test ;
29 my $text1 = "Hello world 1\n";
30 my $text2 = "Hello world 2\n";
2431
25 use IPC::Run qw( start pump finish ) ;
26 use UNIVERSAL qw( isa ) ;
32 my @perl = ( $^X );
33 my @catter = ( @perl, '-pe1' );
2734
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 ) ;
35 my ( $h1, $h2 );
36 my ( $out1, $out2 );
37 $h1 = start \@catter, "<", \$text1, ">", \$out1;
38 ok( $h1 );
39 $h2 = start \@catter, "<", \$text2, ">", \$out2;
40 ok( $h2 );
41 pump $h1;
42 ok( 1 );
43 pump $h2;
44 ok( 1 );
45 finish $h1;
46 ok( 1 );
47 finish $h2;
48 ok( 1 );
+141
-205
t/pty.t less more
0 #!/usr/bin/perl -w
0 #!/usr/bin/perl
1
2 =pod
13
24 =head1 NAME
35
2224
2325 =cut
2426
27 use strict;
2528 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 ;
29 $| = 1;
30 $^W = 1;
31 if( $ENV{PERL_CORE} ) {
32 chdir '../lib/IPC/Run' if -d '../lib/IPC/Run';
33 unshift @INC, 'lib', '../..';
34 $^X = '../../../t/' . $^X;
35 }
36 }
37
38 use Test::More;
39 BEGIN {
40 if ( eval { require IO::Pty; } ) {
41 plan tests => 32;
42 } else {
43 plan skip_all => "IO::Pty not installed";
44 }
45 }
3746
3847 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 ;
48 use IPC::Run qw( start pump finish );
49
50 select STDERR;
51 select STDOUT;
4352
4453 sub pty_warn {
4554 warn "\nWARNING: $_[0].\nWARNING: '<pty<', '>pty>' $_[1] not work.\n\n";
4655 }
4756
4857 if ( $^O !~ /Win32/ ) {
49 # my $min = 0.9 ;
50 for ( eval { require IO::Pty ; IO::Pty->VERSION } ) {
51 s/_//g if defined ;
58 # my $min = 0.9;
59 for ( eval { require IO::Pty; IO::Pty->VERSION } ) {
60 s/_//g if defined;
5261 if ( ! defined ) {
53 pty_warn "IO::Pty not found", "will" ;
62 pty_warn "IO::Pty not found", "will";
5463 }
5564 elsif ( $_ == 0.02 ) {
5665 pty_warn "IO::Pty v$_ has spurious warnings, try 0.9 or later", "may"
5766 }
5867 elsif ( $_ < 1.00 ) {
59 pty_warn "IO::Pty 1.00 is strongly recommended", "may" ;
68 pty_warn "IO::Pty 1.00 is strongly recommended", "may";
6069 }
6170 }
6271 }
6372
64
65 my $echoer_script = <<TOHERE ;
66 \$| = 1 ;
67 \$s = select STDERR ; \$| = 1 ; select \$s ;
73 diag( "IO::Tty $IO::Tty::VERSION, IO::Pty $IO::Pty::VERSION" );
74
75 my $echoer_script = <<TOHERE;
76 \$| = 1;
77 \$s = select STDERR; \$| = 1; select \$s;
6878 while (<>) {
69 print STDERR uc \$_ ;
70 print ;
71 last if /quit/ ;
79 print STDERR uc \$_;
80 print;
81 last if /quit/;
7282 }
7383 TOHERE
7484
7585 ##
7686 ## $^X is the path to the perl binary. This is used run all the subprocesses.
7787 ##
78 my @echoer = ( $^X, '-e', $echoer_script ) ;
79
80 my $in ;
81 my $out ;
88 my @echoer = ( $^X, '-e', $echoer_script );
89 my $in;
90 my $out;
8291 my $err;
83
84 my $h ;
85 my $r ;
86
87 my $fd_map ;
88
89 my $text = "hello world\n" ;
92 my $h;
93 my $r;
94 my $fd_map;
95 my $text = "hello world\n";
9096
9197 ## TODO: test lots of mixtures of pty's and pipes & files. Use run().
9298
9399 ## 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 = (
100 my $exp;
101 my $platform_skip = $^O =~ /(?:aix|freebsd|openbsd)/ ? "$^O deadlocks on this test" : "";
102
99103 ##
100104 ## stdin only
101105 ##
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 },
106 SKIP: {
107 if ( $platform_skip ) {
108 skip( $platform_skip, 9 );
109 }
110 $out = 'REPLACE ME';
111 $? = 99;
112 $fd_map = _map_fds;
113 $h = start \@echoer, '<pty<', \$in, '>', \$out, '2>', \$err;
114 $in = "hello\n";
115 $? = 0;
116 pump $h until $out =~ /hello/ && $err =~ /HELLO/;
117 is( $out, "hello\n" );
118 $exp = qr/^HELLO\n(?!\n)$/;
119 $err =~ $exp ? ok( 1 ) : is( $err, $exp );
120 is( $in, '' );
121 $in = "world\n";
122 $? = 0;
123 pump $h until $out =~ /world/ && $err =~ /WORLD/;
124 is( $out, "hello\nworld\n" );
125 $exp = qr/^HELLO\nWORLD\n(?!\n)$/;
126 $err =~ $exp ? ok( 1 ) : is( $err, $exp );
127 is( $in, '' );
128 $in = "quit\n";
129 ok( $h->finish );
130 ok( ! $? );
131 is( _map_fds, $fd_map );
132 }
154133
155134 ##
156135 ## stdout, stderr
157136 ##
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
137 $out = 'REPLACE ME';
138 $? = 99;
139 $fd_map = _map_fds;
140 $h = start \@echoer, \$in, '>pty>', \$out;
141 $in = "hello\n";
142 $? = 0;
143 pump $h until $out =~ /hello/;
144 ## We assume that the slave's write()s are atomic
145 $exp = qr/^(?:hello\r?\n){2}(?!\n)$/i;
146 $out =~ $exp ? ok( 1 ) : is( $out, $exp );
147 is( $in, '' );
148 $in = "world\n";
149 $? = 0;
150 pump $h until $out =~ /world/;
151 $exp = qr/^(?:hello\r?\n){2}(?:world\r?\n){2}(?!\n)$/i;
152 $out =~ $exp ? ok( 1 ) : is( $out, $exp );
153 is( $in, '' );
154 $in = "quit\n";
155 ok( $h->finish );
156 ok( ! $? );
157 is( _map_fds, $fd_map );
188158 ##
189159 ## stdout only
190160 ##
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
161 $out = 'REPLACE ME';
162 $? = 99;
163 $fd_map = _map_fds;
164 $h = start \@echoer, \$in, '>pty>', \$out, '2>', \$err;
165 $in = "hello\n";
166 $? = 0;
167 pump $h until $out =~ /hello/ && $err =~ /HELLO/;
168 $exp = qr/^hello\r?\n(?!\n)$/;
169 $out =~ $exp ? ok( 1 ) : is( $out, $exp );
170 $exp = qr/^HELLO\n(?!\n)$/;
171 $err =~ $exp ? ok( 1 ) : is( $err, $exp );
172 is( $in, '' );
173 $in = "world\n";
174 $? = 0;
175 pump $h until $out =~ /world/ && $err =~ /WORLD/;
176 $exp = qr/^hello\r?\nworld\r?\n(?!\n)$/;
177 $out =~ $exp ? ok( 1 ) : is( $out, $exp );
178 $exp = qr/^HELLO\nWORLD\n(?!\n)$/ ,
179 $err =~ $exp ? ok( 1 ) : is( $err, $exp );
180 is( $in, '' );
181 $in = "quit\n";
182 ok( $h->finish );
183 ok( ! $? );
184 is( _map_fds, $fd_map );
228185 ##
229186 ## stdin, stdout, stderr
230187 ##
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 ) ;
188 $out = 'REPLACE ME';
189 $? = 99;
190 $fd_map = _map_fds;
191 $h = start \@echoer, '<pty<', \$in, '>pty>', \$out;
192 $in = "hello\n";
193 $? = 0;
194 pump $h until $out =~ /hello.*hello.*hello/is;
195 ## We assume that the slave's write()s are atomic
196 $exp = qr/^(?:hello\r?\n){3}(?!\n)$/i;
197 $out =~ $exp ? ok( 1 ) : is( $out, $exp );
198 is( $in, '' );
199 $in = "world\n";
200 $? = 0;
201 pump $h until $out =~ /world.*world.*world/is;
202 $exp = qr/^(?:hello\r?\n){3}(?:world\r?\n){3}(?!\n)$/i;
203 $out =~ $exp ? ok( 1 ) : is( $out, $exp );
204 is( $in, '' );
205 $in = "quit\n";
206 ok( $h->finish );
207 ok( ! $? );
208 is( _map_fds, $fd_map );
+66
-99
t/pump.t less more
0 #!/usr/bin/perl -w
0 #!/usr/bin/perl
1
2 =pod
13
24 =head1 NAME
35
57
68 =cut
79
10 use strict;
811 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 }
12 $| = 1;
13 $^W = 1;
14 if( $ENV{PERL_CORE} ) {
15 chdir '../lib/IPC/Run' if -d '../lib/IPC/Run';
16 unshift @INC, 'lib', '../..';
17 $^X = '../../../t/' . $^X;
18 }
1419 }
1520
16 use strict ;
17
18 use Test ;
19
21 use Test::More tests => 27;
2022 use IPC::Run::Debug qw( _map_fds );
21 use IPC::Run qw( start pump finish timeout ) ;
22 use UNIVERSAL qw( isa ) ;
23 use IPC::Run qw( start pump finish timeout );
2324
2425 ##
2526 ## $^X is the path to the perl binary. This is used run all the subprocesses.
2627 ##
27 my @echoer = ( $^X, '-pe', 'BEGIN { $| = 1 }' ) ;
28 my @echoer = ( $^X, '-pe', 'BEGIN { $| = 1 }' );
29 my $in;
30 my $out;
31 my $h;
32 my $fd_map;
2833
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 ) },
34 $in = 'SHOULD BE UNCHANGED';
35 $out = 'REPLACE ME';
36 $? = 99;
37 $fd_map = _map_fds;
38 $h = start( \@echoer, \$in, \$out, timeout 5 );
39 ok( $h->isa('IPC::Run') );
40 is( $?, 99 );
41 is( $in, 'SHOULD BE UNCHANGED' );
42 is( $out, '' );
43 ok( $h->pumpable );
44 $in = '';
45 $? = 0;
46 pump_nb $h for ( 1..100 );
47 ok( 1 );
48 is( $in, '' );
49 is( $out, '' );
50 ok( $h->pumpable );
51 $in = "hello\n";
52 $? = 0;
53 pump $h until $out =~ /hello/;
54 ok( 1 );
55 ok( ! $? );
56 is( $in, '' );
57 is( $out, "hello\n" );
58 ok( $h->pumpable );
59 $in = "world\n";
60 $? = 0;
61 pump $h until $out =~ /world/;
62 ok( 1 );
63 ok( ! $? );
64 is( $in, '' );
65 is( $out, "hello\nworld\n" );
66 ok( $h->pumpable );
8567
8668 ## 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 ) ;
69 $in = "hello\n";
70 $out = "";
71 $? = 0;
72 pump $h until $out =~ /hello\n/g;
73 ok( 1 );
74 is pos( $out ), 6, "pos\$out";
75 $in = "world\n";
76 $? = 0;
77 pump $h until $out =~ /\Gworld/gc;
78 ok( 1 );
79 ok( $h->finish );
80 ok( ! $? );
81 is( _map_fds, $fd_map );
82 is( $out, "hello\nworld\n" );
83 ok( ! $h->pumpable );
+643
-744
t/run.t less more
0 #!/usr/bin/perl -w
0 #!/usr/bin/perl
1
2 =pod
13
24 =head1 NAME
35
57
68 =cut
79
10 use strict;
811 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
12 $| = 1;
13 $^W = 1;
14 if( $ENV{PERL_CORE} ) {
15 chdir '../lib/IPC/Run' if -d '../lib/IPC/Run';
16 unshift @INC, 'lib', '../..';
17 $^X = '../../../t/' . $^X;
18 }
19 }
1620
1721 ## Handy to have when our output is intermingled with debugging output sent
1822 ## to the debugging fd.
19 $| = 1 ;
20 select STDERR ; $| = 1 ; select STDOUT ;
21
22 use strict ;
23
24 use Test ;
25
23 select STDERR;
24 select STDOUT;
25
26 use Test::More tests => 266;
2627 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 ) ;
28 use IPC::Run qw( :filters :filter_imp start );
29 use t::lib::Test;
30
31 # Must do this this late as plan uses localtime, and localtime on darwin opens
32 # a file descriptor. Quite probably other operating systems do file descriptor
33 # things during the test setup.
34 my $fd_map = _map_fds;
35
36 sub run {
37 IPC::Run::run( ref $_[0] ? ( noinherit => 1 ) : (), @_ );
38 }
3239
3340 ## Test at least some of the win32 PATHEXT logic
3441 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
42 $perl =~ s/\.\w+\z// if IPC::Run::Win32_MODE();
6943
7044 sub _unlink {
7145 my ( $f ) = @_;
8155 }
8256 }
8357
84
85 my $text = "Hello World\n" ;
86
87 my @perl = ( $perl ) ;
88
58 my $text = "Hello World\n";
59 my @perl = ( $perl );
8960 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;
61 qq{print '$text'; print STDERR uc( '$text' ) unless \@ARGV };
62 my @emitter = ( @perl, '-e', $emitter_script );
63
64 my $in;
65 my $out;
66 my $err;
67
68 my $in_file = 'run.t.in';
69 my $out_file = 'run.t.out';
70 my $err_file = 'run.t.err';
71
72 my $h;
10573
10674 sub slurp($) {
107 my ( $f ) = @_ ;
108 open( S, "<$f" ) or return "$! $f" ;
109 my $r = join( '', <S> ) ;
75 my ( $f ) = @_;
76 open( S, "<$f" ) or return "$! $f";
77 my $r = join( '', <S> );
11078 close S or warn "$!: $f";
11179 select 0.1 if $^O =~ /Win32/;
112 return $r ;
113 }
114
80 return $r;
81 }
11582
11683 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" ;
84 my ( $f, $s ) = @_;
85 open( S, ">$f" ) or die "$! $f";
86 print S $s or die "$! $f";
87 close S or die "$! $f";
12188 }
12289
12390 ##
12895 ## are required.
12996 ##
13097 sub alt_casing_filter {
131 my ( $in_ref, $out_ref ) = @_ ;
98 my ( $in_ref, $out_ref ) = @_;
13299 return input_avail && do {
133 $$out_ref .= lc( substr( $$in_ref, 0, 1, '' ) ) ;
134 1 ;
100 $$out_ref .= lc( substr( $$in_ref, 0, 1, '' ) );
101 1;
135102 } && (
136103 ! input_avail || do {
137 $$out_ref .= uc( substr( $$in_ref, 0, 1, '' ) ) ;
138 1 ;
104 $$out_ref .= uc( substr( $$in_ref, 0, 1, '' ) );
105 1;
139106 }
140 ) ;
141 }
142
107 );
108 }
143109
144110 sub case_inverting_filter {
145 my ( $in_ref, $out_ref ) = @_ ;
111 my ( $in_ref, $out_ref ) = @_;
146112 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
113 $$in_ref =~ tr/a-zA-Z/A-Za-z/;
114 $$out_ref .= $$in_ref;
115 $$in_ref = '';
116 1;
117 };
118 }
154119
155120 sub eok {
156121 my ( $got, $exp ) = ( shift, shift );
157122 $got =~ s/([\000-\037])/sprintf "\\0x%02x", ord $1/ge if defined $exp;
158123 $exp =~ s/([\000-\037])/sprintf "\\0x%02x", ord $1/ge if defined $exp;
159124 @_ = ( $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 },
125 goto &is;
126 }
127
128 my $r;
129
130 is( _map_fds, $fd_map ); $fd_map = _map_fds;
170131
171132 ##
172133 ## Internal testing
178139 \&alt_casing_filter
179140 ),
180141
181 sub { ok( _map_fds, $fd_map ) ; $fd_map = _map_fds },
142 is( _map_fds, $fd_map ); $fd_map = _map_fds;
182143
183144 filter_tests(
184145 "case_inverting_filter",
187148 \&case_inverting_filter
188149 ),
189150
190 sub { ok( _map_fds, $fd_map ) ; $fd_map = _map_fds },
151 is( _map_fds, $fd_map ); $fd_map = _map_fds;
191152
192153 ##
193154 ## Calling the local system shell
194155 ##
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 },
156 ok( run qq{$perl -e exit} );
157 is( $?, 0 );
158
159 is( _map_fds, $fd_map ); $fd_map = _map_fds;
160 SKIP: {
161 if ( IPC::Run::Win32_MODE() ) {
162 skip( "$^O's shell returns 0 even if last command doesn't", 3 );
163 }
164
165 ok( ! run(qq{$perl -e 'exit(42)'}) );
166 ok( $? );
167 is( $? >> 8, 42 );
168 }
169 is( _map_fds, $fd_map ); $fd_map = _map_fds;
205170
206171 ##
207172 ## Simple commands, not executed via shell
208173 ##
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 },
174 ok( run $perl, qw{-e exit} );
175 is( $?, 0 );
176
177 is( _map_fds, $fd_map ); $fd_map = _map_fds;
178
179 ok( ! run $perl, qw{-e exit(42)} );
180 ok( $? );
181 is $? >> 8, 42;
182
183 is( _map_fds, $fd_map ); $fd_map = _map_fds;
219184
220185 ##
221186 ## A function
222187 ##
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 },
188 SKIP: {
189 if ( IPC::Run::Win32_MODE() ) {
190 skip( "Can't spawn subroutines on $^O", 5 );
191 }
192
193 ok run sub{} ;
194 is $?, 0 ;
195 ok !run sub{ exit 42 };
196 ok $? ;
197 is $? >> 8, 42 ;
198 }
199 is( _map_fds, $fd_map ); $fd_map = _map_fds;
230200
231201 ##
232202 ## A function, and an init function
233203 ##
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 },
204 SKIP: {
205 if ( IPC::Run::Win32_MODE() ) {
206 skip( "Can't spawn subroutines on $^O", 2 );
207 }
208
209 my $e = 0;
210 ok(
211 ! run(
212 sub{ exit($e) },
213 init => sub { $e = 42 }
214 )
215 );
216 ok( $? );
217 }
218 is( _map_fds, $fd_map ); $fd_map = _map_fds;
246219
247220 ##
248221 ## scalar ref I & O redirection using op tokens
249222 ##
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 ) ) },
223 $out = 'REPLACE ME';
224 $fd_map = _map_fds;
225 $r = run [ @emitter, "nostderr" ], '>', \$out;
226 ok( $r );
227
228 ok( ! $? );
229 is( _map_fds, $fd_map );
230 eok( $out, $text );
231
232
233 $out = 'REPLACE ME';
234 $fd_map = _map_fds;
235 $r = run [ @emitter, "nostderr" ], '<', \undef, '>', \$out;
236 ok( $r );
237
238 ok( ! $? );
239 is( _map_fds, $fd_map );
240 eok( $out, $text );
241
242 $in = $emitter_script;
243 $out = 'REPLACE ME';
244 $err = 'REPLACE ME';
245 $fd_map = _map_fds;
246 $r = run \@perl, '<', \$in, '>', \$out, '2>', \$err,;
247 ok( $r );
248
249 ok( ! $? );
250 is( _map_fds, $fd_map );
251
252 eok( $in, $emitter_script );
253 eok( $out, $text );
254 eok( $err, uc( $text ) );
283255 ##
284256 ## scalar ref I & O redirection, succinct mode.
285257 ##
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 ) ) },
258
259 $in = $emitter_script;
260 $out = 'REPLACE ME';
261 $err = 'REPLACE ME';
262 $fd_map = _map_fds;
263 $r = run \@perl, \$in, \$out, \$err;
264 ok( $r );
265
266 ok( ! $? );
267 is( _map_fds, $fd_map );
268
269 eok( $in, $emitter_script );
270 eok( $out, $text );
271 eok( $err, uc( $text ) );
300272
301273 ##
302274 ## Long output, to test for blocking read.
304276 ## Assume pipe buffer length <= 10000, need to double that to assure enough
305277 ## chars to fill a buffer so. This test adapted from a test submitted by
306278 ## 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 !~ /[^-]/ ) },
279
280 $in = "-" x 20000 . "end\n";
281 $out = 'REPLACE ME';
282 $fd_map = _map_fds;
283 $r = run [ $perl, qw{-e print"-"x20000;<STDIN>;} ], \$in, \$out;
284 ok( $r );
285
286 ok( ! $? );
287 is( _map_fds, $fd_map );
288
289 is( length $out, 20000 );
290 ok( $out !~ /[^-]/ );
319291
320292
321293 ##
323295 ##
324296 ## Adapted from a stress test by Aaron Elkiss <aelkiss@wam.umd.edu>
325297 ##
326 sub {
298
327299 $h = start [$perl, qw( -pe BEGIN{$|=1}1 )], \$in, \$out;
328
329300 $in = "\n";
330301 $out = "";
331302 pump $h until length $out;
332303 ok $out eq "\n";
333 },
334
335 sub {
304
305
306
336307 my $long_string = "x" x 20000 . "DOC2\n";
337308 $in = $long_string;
338309 $out = "";
353324 }
354325 else {
355326 $x =~ s/(x+)/sprintf "...%d \"x\" chars...", length $1/e;
356 ok $x, "";
327 is $x, "";
357328 }
358 },
329
359330
360331 ##
361332 ## child function, scalar ref I & O redirection, succinct mode.
362333 ##
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 ) ) },
334 SKIP: {
335 if ( IPC::Run::Win32_MODE() ) {
336 skip( "Can't spawn subroutines on $^O", 6 );
337 }
338
339 $in = $text;
340 $out = 'REPLACE ME';
341 $err = 'REPLACE ME';
342 $fd_map = _map_fds;
343 $r = run(
344 sub { while (<>) { print; print STDERR uc( $_ ) } },
345 \$in, \$out, \$err
346 );
347 ok( $r );
348 ok ! $?;
349 is( _map_fds, $fd_map );
350 eok( $in, $text );
351 eok( $out, $text );
352 eok( $err, uc( $text ) );
353 }
380354
381355 ##
382356 ## here document as input
383357 ##
384 sub {
385 $out = 'REPLACE ME' ;
386 $err = 'REPLACE ME' ;
387 $fd_map = _map_fds ;
388 $r = run \@perl, \<<TOHERE, \$out, \$err ;
358 $out = 'REPLACE ME';
359 $err = 'REPLACE ME';
360 $fd_map = _map_fds;
361 $r = run \@perl, \<<TOHERE, \$out, \$err;
389362 $emitter_script
390363 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 ) ) },
364 ok( $r );
365
366 ok( ! $? );
367 is( _map_fds, $fd_map );
368
369 eok( $out, $text );
370 eok( $err, uc( $text ) );
398371
399372 ##
400373 ## undef as input
401374 ##
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, '' ) },
375 $out = 'REPLACE ME';
376 $err = 'REPLACE ME';
377 $fd_map = _map_fds;
378 $r = run \@perl, \undef, \$out, \$err;
379 ok( $r );
380
381 ok( ! $? );
382 is( _map_fds, $fd_map );
383
384 eok( $out, '' );
385 eok( $err, '' );
414386
415387 ##
416388 ## filehandle input redirection
417389 ##
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 ) ) },
390 $out = 'REPLACE ME';
391 $err = 'REPLACE ME';
392 $fd_map = _map_fds;
393 spit( $in_file, $emitter_script );
394 open( F, "<$in_file" ) or die "$! $in_file";
395 $r = run \@perl, \*F, \$out, \$err;
396 close F;
397 unlink $in_file or warn "$! $in_file";
398 ok( $r );
399
400 ok( ! $? );
401 is( _map_fds, $fd_map );
402
403 eok( $out, $text );
404 eok( $err, uc( $text ) );
434405
435406 ##
436407 ## input redirection via caller writing directly to a pipe
437408 ##
438 sub {
439 $out = 'REPLACE ME' ;
440 $err = 'REPLACE ME' ;
441 $fd_map = _map_fds ;
442 $h = start \@perl, '<pipe', \*IN, '>', \$out, '2>', \$err ;
409 $out = 'REPLACE ME';
410 $err = 'REPLACE ME';
411 $fd_map = _map_fds;
412 $h = start \@perl, '<pipe', \*IN, '>', \$out, '2>', \$err;
443413 ## 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 ) ) },
414 print IN $emitter_script;
415 close IN or warn $!;
416 $r = $h->finish;
417 ok( $r );
418
419 ok( ! $? );
420 is( _map_fds, $fd_map );
421
422 eok( $out, $text );
423 eok( $err, uc( $text ) );
454424
455425 ##
456426 ## filehandle input redirection, passed via *F{IO}
457427 ##
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 ;
428 $out = 'REPLACE ME';
429 $err = 'REPLACE ME';
430 $fd_map = _map_fds;
431 spit( $in_file, $emitter_script );
432 open( F, "<$in_file" ) or die "$! $in_file";
433 $r = run \@perl, *F{IO}, \$out, \$err;
434 close F;
466435 _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 ) ) },
436 ok( $r );
437
438 ok( ! $? );
439 is( _map_fds, $fd_map );
440
441 eok( $out, $text );
442 eok( $err, uc( $text ) );
474443
475444 ##
476445 ## filehandle output redirection
477446 ##
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 ) ;
447 $fd_map = _map_fds;
448 open( OUT, ">$out_file" ) or die "$! $out_file";
449 open( ERR, ">$err_file" ) or die "$! $err_file";
450 print OUT "out: ";
451 print ERR uc( "err: " );
452 $r = run \@emitter, \undef, \*OUT, \*ERR;
453 print OUT " more out data";
454 print ERR uc( " more err data" );
455 close OUT;
456 close ERR;
457 $out = slurp( $out_file );
458 $err = slurp( $err_file );
491459 _unlink $out_file;
492460 _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" ) ) },
461 ok( $r );
462
463 ok( ! $? );
464 is( _map_fds, $fd_map );
465
466 eok( $out, "out: $text more out data" );
467 eok( $err, uc( "err: $text more err data" ) );
500468
501469 ##
502470 ## filehandle output redirection via a pipe that is returned to the caller
503471 ##
504 sub {
505 $fd_map = _map_fds ;
506 my $r = run \@emitter, \undef, '>pipe', \*OUT, '2>pipe', \*ERR ;
507 $out = '' ;
508 $err = '' ;
472 $fd_map = _map_fds;
473 $r = run \@emitter, \undef, '>pipe', \*OUT, '2>pipe', \*ERR;
474 $out = '';
475 $err = '';
509476 read OUT, $out, 10000 or warn $!;
510477 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 ) ) },
478 close OUT or warn $!;
479 close ERR or warn $!;
480 ok( $r );
481
482 ok( ! $? );
483 is( _map_fds, $fd_map );
484
485 eok( $out, $text );
486 eok( $err, uc( $text ) );
520487
521488 ##
522489 ## sub I & O redirection
523490 ##
524 sub {
525 $in = $emitter_script ;
526 $out = undef ;
527 $err = undef ;
528 $fd_map = _map_fds ;
491 $in = $emitter_script;
492 $out = undef;
493 $err = undef;
494 $fd_map = _map_fds;
529495 $r = run(
530496 \@perl,
531 '<', sub { my $f = $in ; $in = undef ; return $f },
497 '<', sub { my $f = $in; $in = undef; return $f },
532498 '>', sub { $out .= shift },
533499 '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 ) ) },
500 );
501 ok( $r );
502 ok( ! $? );
503 is( _map_fds, $fd_map );
504
505 eok( $out, $text );
506 eok( $err, uc( $text ) );
542507
543508 ##
544509 ## input redirection from a file
545510 ##
546 sub {
547 $out = undef ;
548 $err = undef ;
549 $fd_map = _map_fds ;
550 spit( $in_file, $emitter_script ) ;
511 $out = undef;
512 $err = undef;
513 $fd_map = _map_fds;
514 spit( $in_file, $emitter_script );
551515 $r = run(
552516 \@perl,
553517 "<$in_file",
554518 '>', sub { $out .= shift },
555519 '2>', sub { $err .= shift },
556 ) ;
520 );
557521 _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 ) ) },
522 ok( $r );
523 ok( ! $? );
524 is( _map_fds, $fd_map );
525 eok( $out, $text );
526 eok( $err, uc( $text ) );
565527
566528 ##
567529 ## reading input from a non standard fd
568530 ##
569 skip_unless_high_fds {
570 $out = undef ;
571 $err = undef ;
572 $fd_map = _map_fds ;
531 SKIP: {
532 if ( IPC::Run::Win32_MODE() ) {
533 skip( "$^O does not allow redirection of file descriptors > 2", 11 );
534 }
535
536 $out = undef;
537 $err = undef;
538 $fd_map = _map_fds;
539 $r = run(
540 ## FreeBSD doesn't guarantee that fd 3 or 4 are available, so
541 ## don't assume, go for 5.
542 [ @perl, '-le', 'open( STDIN, "<&5" ) or die $!; print <STDIN>' ],
543 "5<", \"Hello World",
544 '>', \$out,
545 '2>', \$err,
546 );
547 ok( $r );
548 ok( ! $? );
549 is( _map_fds, $fd_map );
550 eok( $out, $text );
551 eok( $err, '' );
552
553 ##
554 ## duping input descriptors and an input descriptor > 0
555 ##
556 $in = $emitter_script;
557 $out = 'REPLACE ME';
558 $err = 'REPLACE ME';
559 $fd_map = _map_fds;
560 $r = run(
561 \@perl,
562 '>', \$out,
563 '2>', \$err,
564 '3<', \$in,
565 '0<&3',
566 );
567 ok( $r );
568 ok( ! $? );
569 is( _map_fds, $fd_map );
570 eok( $in, $emitter_script );
571 eok( $out, $text );
572 eok( $err, uc( $text ) );
573 }
574
575 ##
576 ## closing input descriptors
577 ##
578 $out = 'REPLACE ME';
579 $err = 'REPLACE ME';
580 $fd_map = _map_fds;
581 spit( $in_file, $emitter_script );
573582 $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' ],
583 [ @perl, '-e', '$l = readline *STDIN or die $!; print $l' ],
622584 '>', \$out,
623585 '2>', \$err,
624586 '<', $in_file,
625587 '0<&-',
626 ) ;
588 );
627589 _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" ) },
590 ok( ! $r );
591 ok( $? );
592 is( _map_fds, $fd_map );
593 eok( $out, '' );
594 #ok( $err =~ /file descriptor/i ? "Bad file descriptor error" : $err, "Bad file descriptor error" );
634595 # XXX This should be use Errno; if $!{EBADF}. --rs
635 sub { ok( length $err ? "Bad file descriptor error" : $err, "Bad file descriptor error" ) },
596 is( length $err ? "Bad file descriptor error" : $err, "Bad file descriptor error" );
636597
637598 ##
638599 ## input redirection from a non-existent file
639600 ##
640 sub {
641 $out = 'REPLACE ME' ;
642 $err = 'REPLACE ME' ;
643 $fd_map = _map_fds ;
644 my $bad_file = "$in_file.nonexistant" ;
601 $out = 'REPLACE ME';
602 $err = 'REPLACE ME';
603 $fd_map = _map_fds;
604 my $bad_file = "$in_file.nonexistant";
645605 _unlink $bad_file if -e $bad_file;
646606 eval {
647 $r = run \@perl, ">$out_file", "<$bad_file" ;
648 } ;
607 $r = run \@perl, ">$out_file", "<$bad_file";
608 };
649609 if ( $@ =~ /\Q$bad_file\E/ ) {
650 ok 1 ;
610 ok 1;
651611 }
652612 else {
653 ok $@, "qr/\Q$bad_file\E/" ;
613 is $@, "qr/\Q$bad_file\E/";
654614 }
655 },
656 sub { ok( _map_fds, $fd_map ) },
615 is( _map_fds, $fd_map );
657616
658617 ##
659618 ## output redirection to a file w/ creation or truncation
660619 ##
661 sub {
662 $fd_map = _map_fds ;
620 $fd_map = _map_fds;
663621 _unlink $out_file if -x $out_file;
664622 _unlink $err_file if -x $err_file;
665623 $r = run(
666624 \@emitter,
667625 ">$out_file",
668626 "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 ) ) },
627 );
628 $out = slurp( $out_file );
629 $err = slurp( $err_file );
630 ok( $r );
631 ok( ! $? );
632 is( _map_fds, $fd_map );
633
634 eok( $out, $text );
635 eok( $err, uc( $text ) );
679636
680637 ##
681638 ## output file redirection, w/ truncation
682639 ##
683 sub {
684 $fd_map = _map_fds ;
685 spit( $out_file, 'out: ' ) ;
686 spit( $err_file, 'ERR: ' ) ;
640 $fd_map = _map_fds;
641 spit( $out_file, 'out: ' );
642 spit( $err_file, 'ERR: ' );
687643 $r = run(
688644 \@emitter,
689645 ">$out_file",
690646 "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 ) ) },
647 );
648 $out = slurp( $out_file ); _unlink $out_file;
649 $err = slurp( $err_file ); _unlink $err_file;
650 ok( $r );
651 ok( ! $? );
652 is( _map_fds, $fd_map );
653
654 eok( $out, $text );
655 eok( $err, uc( $text ) );
701656
702657 ##
703658 ## output file redirection w/ append
704659 ##
705 sub {
706 spit( $out_file, 'out: ' ) ;
707 spit( $err_file, 'ERR: ' ) ;
708 $fd_map = _map_fds ;
660 spit( $out_file, 'out: ' );
661 spit( $err_file, 'ERR: ' );
662 $fd_map = _map_fds;
709663 $r = run(
710664 \@emitter,
711665 ">>$out_file",
712666 "2>>$err_file",
713 ) ;
714 $out = slurp( $out_file ) ;
667 );
668 $out = slurp( $out_file );
715669 _unlink $out_file;
716 $err = slurp( $err_file ) ;
670 $err = slurp( $err_file );
717671 _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" ) ) },
672 ok( $r );
673 ok( ! $? );
674 is( _map_fds, $fd_map );
675
676 eok( $out, "out: $text" );
677 eok( $err, uc( "err: $text" ) );
725678 ##
726679 ## dup()ing output descriptors
727680 ##
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, '' ) },
681 $out = 'REPLACE ME';
682 $err = 'REPLACE ME';
683 $fd_map = _map_fds;
684 $r = run \@emitter, '>', \$out, '2>', \$err, '2>&1';
685 ok( $r );
686 ok( ! $? );
687 is( _map_fds, $fd_map );
688 $out =~ /(?:$text){2}/i ? ok 1 : is $out, "qr/($text){2}/i";
689 eok( $err, '' );
739690
740691 ##
741692 ## stderr & stdout redirection to the same file via >&word
742693 ##
743 sub {
744 $fd_map = _map_fds ;
694 $fd_map = _map_fds;
745695 _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 ) },
696 $r = run \@emitter, ">&$out_file";
697 $out = slurp( $out_file );
698 ok( $r );
699 ok( ! $? );
700 is( _map_fds, $fd_map );
701
702 ok( $out =~ qr/(?:$text){2}/i );
754703
755704 ##
756705 ## Non-zero exit value, command with args, no redirects.
757706 ##
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 ) },
707 $fd_map = _map_fds;
708 $r = run [ @perl, '-e', 'exit(42)' ];
709 ok( !$r );
710 is( $?, 42 << 8 );
711 is( _map_fds, $fd_map );
765712
766713 ##
767714 ## Zero exit value, command with args, no redirects.
768715 ##
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 ) },
716 $fd_map = _map_fds;
717 $r = run [ @perl, qw{ -e exit }];
718 ok( $r );
719 ok( ! $? );
720 is( _map_fds, $fd_map );
776721
777722 ##
778723 ## dup()ing output descriptors that collide.
780725 ## This test assumes that our caller doesn't leave a lot of fds opened,
781726 ## and assumes that $out_file will be opened on fd 3, 4 or 5.
782727 ##
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 ;
728 SKIP: {
729 if ( IPC::Run::Win32_MODE() ) {
730 skip( "$^O does not allow redirection of file descriptors > 2", 5 );
731 }
732
733 $out = 'REPLACE ME';
734 $err = 'REPLACE ME';
735 _unlink $out_file if -x $out_file;
736 $fd_map = _map_fds;
737 $r = run(
738 \@emitter,
739 "<", \"",
740 "3>&1", "4>&1", "5>&1",
741 ">$out_file",
742 '2>', \$err,
743 );
744 $out = slurp( $out_file );
745 _unlink $out_file;
746 ok( $r );
747 ok( ! $? );
748 is( _map_fds, $fd_map );
749 eok( $out, $text );
750 eok( $err, uc( $text ) );
751 }
752
753 ##
754 ## Pipelining
755 ##
756 $out = 'REPLACE ME';
757 $err = 'REPLACE ME';
758 $fd_map = _map_fds;
788759 $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]'],
760 [ @perl, '-lane', 'print STDERR "1:$_"; print uc($F[0])," ",$F[1]'],
813761 \"Hello World",
814 '|',[ @perl, '-lane', 'print STDERR "2:$_" ; print $F[0]," ",lc($F[1])'],
762 '|',[ @perl, '-lane', 'print STDERR "2:$_"; print $F[0]," ",lc($F[1])'],
815763 \$out,
816764 \$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" ) },
765 );
766 ok( $r );
767 ok( ! $? );
768 is( _map_fds, $fd_map );
769 eok( $out, "HELLO world\n" );
770 eok( $err, "1:Hello World\n2:HELLO World\n" );
824771
825772 ##
826773 ## Parallel (unpiplined) processes
827774 ##
828 sub {
829 $out = 'REPLACE ME' ;
830 $err = 'REPLACE ME' ;
831 $fd_map = _map_fds ;
775 $out = 'REPLACE ME';
776 $err = 'REPLACE ME';
777 $fd_map = _map_fds;
832778 $r = run(
833 [ @perl, '-lane', 'print STDERR "1:$_" ; print uc($F[0])," ",$F[1]' ],
779 [ @perl, '-lane', 'print STDERR "1:$_"; print uc($F[0])," ",$F[1]' ],
834780 \"Hello World",
835 '&', [ @perl, '-lane', 'print STDERR "2:$_" ; print $F[0]," ",lc( $F[1] )' ],
781 '&', [ @perl, '-lane', 'print STDERR "2:$_"; print $F[0]," ",lc( $F[1] )' ],
836782 \"Hello World",
837783 \$out,
838784 \$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 ) },
785 );
786 ok( $r );
787 ok( ! $? );
788 is( _map_fds, $fd_map );
789 ok( $out =~ qr/^(?:HELLO World\n|Hello world\n){2}$/s );
790 ok( $err =~ qr/^(?:[12]:Hello World.*){2}$/s );
846791
847792 ##
848793 ## A few error cases...
849794 ##
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 ;
795 eval { $r = run \@perl, '<', [], [] };
796 ok( $@ =~ qr/not allowed/ );
797 eval { $r = run \@perl, '>', [], [] };
798 ok( $@ =~ qr/not allowed/ );
799 foreach my $foo ( qw( | & < > >& 1>&2 >file <file 2<&1 <&- 3<&- ) ) {
800 eval { $r = run $foo, [] };
801 ok( $@ =~ qr/command/ );
802 }
803 $out = 'REPLACE ME';
804 $err = 'REPLACE ME';
805 $fd_map = _map_fds;
873806 eval {
874807 $r = run( \@emitter, '>', \$out, '2>', \$err,
875808 _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 ;
809 );
810 };
811 ok( $@ );
812 ok( ! $? );
813 is( _map_fds, $fd_map );
814
815 eok( $out, '' );
816 eok( $err, '' );
817
818 $fd_map = _map_fds;
888819 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 ;
820 $r = run \@perl, '<file', _simulate_open_failure => 1;
821 };
822 ok( $@ );
823 ok( ! $? );
824 is( _map_fds, $fd_map );
825
826 $fd_map = _map_fds;
898827 eval {
899 $r = run \@perl, '>file', _simulate_open_failure => 1 ;
900 } ;
901 ok( $@ ) ;
902 },
903 sub { ok( ! $? ) },
904 sub { ok( _map_fds, $fd_map ) },
828 $r = run \@perl, '>file', _simulate_open_failure => 1;
829 };
830 ok( $@ );
831 ok( ! $? );
832 is( _map_fds, $fd_map );
905833
906834 ##
907835 ## harness, pump, run
908836 ##
909 sub {
910 $in = 'SHOULD BE UNCHANGED' ;
911 $out = 'REPLACE ME' ;
912 $err = 'REPLACE ME' ;
913 $? = 99 ;
914 $fd_map = _map_fds ;
837 $in = 'SHOULD BE UNCHANGED';
838 $out = 'REPLACE ME';
839 $err = 'REPLACE ME';
840 $? = 99;
841 $fd_map = _map_fds;
915842 $h = start(
916843 [ @perl, '-pe', 'BEGIN { $| = 1 } print STDERR uc($_)' ],
917844 \$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 ) },
845 );
846 ok( $h->isa('IPC::Run') );
847 is( $?, 99 );
848
849 eok( $in, 'SHOULD BE UNCHANGED' );
850 eok( $out, '' );
851 eok( $err, '' );
852 ok( $h->pumpable );
853
854 $in = '';
855 $? = 0;
856 pump_nb $h for ( 1..100 );
857 ok( 1 );
858 eok( $in, '' );
859 eok( $out, '' );
860 eok( $err, '' );
861 ok( $h->pumpable );
862
863 $in = $text;
864 $? = 0;
865 pump $h until $out =~ /Hello World/;
866 ok( 1 );
867 ok( ! $? );
868 eok( $in, '' );
869 eok( $out, $text );
870 ok( $h->pumpable );
871
872 ok( $h->finish );
873 ok( ! $? );
874 is( _map_fds, $fd_map );
875 eok( $out, $text );
876 eok( $err, uc( $text ) );
877 ok( ! $h->pumpable );
956878
957879 ##
958880 ## start, run, run, run. See Tom run. A do-run-run, a-do-run-run.
959881 ##
960 sub {
961 $in = 'SHOULD BE UNCHANGED' ;
962 $out = 'REPLACE ME' ;
963 $err = 'REPLACE ME' ;
964 $fd_map = _map_fds ;
882 $in = 'SHOULD BE UNCHANGED';
883 $out = 'REPLACE ME';
884 $err = 'REPLACE ME';
885 $fd_map = _map_fds;
965886 $h = start(
966 [ @perl, '-pe', 'binmode STDOUT ; binmode STDERR ; BEGIN { $| = 1 } print STDERR uc($_)' ],
887 [ @perl, '-pe', 'binmode STDOUT; binmode STDERR; BEGIN { $| = 1 } print STDERR uc($_)' ],
967888 \$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 ) },
889 );
890 ok( $h->isa('IPC::Run') );
891
892 eok( $in, 'SHOULD BE UNCHANGED' );
893 eok( $out, '' );
894 eok( $err, '' );
895 ok( $h->pumpable );
896
897 $in = $text;
898 ok( $h->finish );
899 ok( ! $? );
900 is( _map_fds, $fd_map );
901 eok( $in, '' );
902 eok( $out, $text );
903 eok( $err, uc( $text ) );
904 ok( ! $h->pumpable );
905
906 $in = $text;
907 $out = 'REPLACE ME';
908 $err = 'REPLACE ME';
909 ok( $h->run );
910 ok( ! $? );
911 is( _map_fds, $fd_map );
912 eok( $in, $text );
913 eok( $out, $text );
914 eok( $err, uc( $text ) );
915 ok( ! $h->pumpable );
916
917 $in = $text;
918 $out = 'REPLACE ME';
919 $err = 'REPLACE ME';
920 ok( $h->run );
921 ok( ! $? );
922 is( _map_fds, $fd_map );
923 eok( $in, $text );
924 eok( $out, $text );
925 eok( $err, uc( $text ) );
926 ok( ! $h->pumpable );
1013927
1014928 ##
1015929 ## Output filters
1016930 ##
1017 sub {
1018 $out = 'REPLACE ME' ;
1019 $err = 'REPLACE ME' ;
1020 $fd_map = _map_fds ;
931 $out = 'REPLACE ME';
932 $err = 'REPLACE ME';
933 $fd_map = _map_fds;
1021934 $r = run(
1022935 \@emitter,
1023936 '>',
1025938 \&case_inverting_filter,
1026939 \$out,
1027940 '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 ) ) },
941 );
942 ok( $r );
943 ok( ! $? );
944 is( _map_fds, $fd_map );
945
946 eok( $out, "HeLlO WoRlD\n" );
947 eok( $err, uc( $text ) );
1036948
1037949 ##
1038950 ## Input filters
1039951 ##
1040 sub {
1041 $out = 'REPLACE ME' ;
1042 $err = 'REPLACE ME' ;
1043 $fd_map = _map_fds ;
1044 $in = $text ;
952 $out = 'REPLACE ME';
953 $err = 'REPLACE ME';
954 $fd_map = _map_fds;
955 $in = $text;
1045956 $r = run(
1046 [ @perl, '-pe', 'binmode STDOUT ; binmode STDERR ; print STDERR uc $_' ],
957 [ @perl, '-pe', 'binmode STDOUT; binmode STDERR; print STDERR uc $_' ],
1047958 '0<',
1048959 \&case_inverting_filter,
1049960 \&alt_casing_filter,
1050961 \$in,
1051962 '1>', \$out,
1052963 '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 ) ;
964 );
965 ok( $r );
966 ok( ! $? );
967 is( _map_fds, $fd_map );
968
969 eok( $in, $text );
970 eok( $out, "HeLlO WoRlD\n" );
971 eok( $err, uc( $text ) );
+43
-67
t/signal.t less more
0 #!/usr/bin/perl -w
0 #!/usr/bin/perl
1
2 =pod
13
24 =head1 NAME
35
57
68 =cut
79
10 use strict;
811 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 }
12 $| = 1;
13 $^W = 1;
14 if( $ENV{PERL_CORE} ) {
15 chdir '../lib/IPC/Run' if -d '../lib/IPC/Run';
16 unshift @INC, 'lib', '../..';
17 $^X = '../../../t/' . $^X;
18 }
1419 }
1520
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 ;
21 use Test::More;
22 use IPC::Run qw( :filters :filter_imp start run );
23 use t::lib::Test;
24 BEGIN {
25 if ( IPC::Run::Win32_MODE() ) {
26 plan skip_all => 'Skipping on Win32';
27 } else {
28 plan tests => 3;
29 }
3830 }
39
40 use IPC::Run qw( start ) ;
4131
4232 my @receiver = (
4333 $^X,
4434 '-e',
4535 <<'END_RECEIVER',
46 my $which = " " ;
47 sub s{ $which = $_[0] } ;
36 my $which = " ";
37 sub s{ $which = $_[0] };
4838 $SIG{$_}=\&s for (qw(USR1 USR2));
49 $| = 1 ;
39 $| = 1;
5040 print "Ok\n";
51 for (1..10) { sleep 1 ; print $which, "\n" }
41 for (1..10) { sleep 1; print $which, "\n" }
5242 END_RECEIVER
53 ) ;
43 );
5444
55 my $h ;
56 my $out ;
45 my $h;
46 my $out;
5747
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 ) ;
48 $h = start \@receiver, \undef, \$out;
49 pump $h until $out =~ /Ok/;
50 ok 1;
51 $out = "";
52 $h->signal( "USR2" );
53 pump $h;
54 $h->signal( "USR1" );
55 pump $h;
56 $h->signal( "USR2" );
57 pump $h;
58 $h->signal( "USR1" );
59 pump $h;
60 ok $out, "USR2\nUSR1\nUSR2\nUSR1\n";
61 $h->signal( "TERM" );
62 finish $h;
63 ok( 1 );
+71
-99
t/timeout.t less more
0 #!/usr/bin/perl -w
0 #!/usr/bin/perl
1
2 =pod
13
24 =head1 NAME
35
57
68 =cut
79
10 use strict;
811 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 }
12 $| = 1;
13 $^W = 1;
14 if( $ENV{PERL_CORE} ) {
15 chdir '../lib/IPC/Run' if -d '../lib/IPC/Run';
16 unshift @INC, 'lib', '../..';
17 $^X = '../../../t/' . $^X;
18 }
1419 }
1520
21 ## Separate from run.t so run.t is not too slow.
22 use Test::More tests => 25;
23 use IPC::Run qw( harness timeout );
1624
17 ## Separate from run.t so run.t is not too slow.
25 my $h;
26 my $t;
27 my $in;
28 my $out;
29 my $started;
1830
19 use strict ;
31 $h = harness( [ $^X ], \$in, \$out, $t = timeout( 1 ) );
32 ok( $h->isa('IPC::Run') );
33 ok( !! $t->is_reset );
34 ok( ! $t->is_running );
35 ok( ! $t->is_expired );
36 $started = time;
37 $h->start;
38 ok( 1 );
39 ok( ! $t->is_reset );
40 ok( !! $t->is_running );
41 ok( ! $t->is_expired );
42 $in = '';
43 eval { $h->pump };
44 # Older perls' Test.pms don't know what to do with qr//s
45 $@ =~ /IPC::Run: timeout/ ? ok( 1 ) : is( $@, qr/IPC::Run: timeout/ );
2046
21 use Test ;
47 SCOPE: {
48 my $elapsed = time - $started;
49 $elapsed >= 1 ? ok( 1 ) : is( $elapsed, ">= 1" );
50 is( $t->interval, 1 );
51 ok( ! $t->is_reset );
52 ok( ! $t->is_running );
53 ok( !! $t->is_expired );
2254
23 use IPC::Run qw( harness timeout ) ;
24 use UNIVERSAL qw( isa ) ;
55 ##
56 ## Starting from an expired state
57 ##
58 $started = time;
59 $h->start;
60 ok( 1 );
61 ok( ! $t->is_reset );
62 ok( !! $t->is_running );
63 ok( ! $t->is_expired );
64 $in = '';
65 eval { $h->pump };
66 $@ =~ /IPC::Run: timeout/ ? ok( 1 ) : is( $@, qr/IPC::Run: timeout/ );
67 ok( ! $t->is_reset );
68 ok( ! $t->is_running );
69 ok( !! $t->is_expired );
70 }
2571
26 my $h ;
27 my $t ;
28 my $in ;
29 my $out ;
30 my $started ;
72 SCOPE: {
73 my $elapsed = time - $started;
74 $elapsed >= 1 ? ok( 1 ) : is( $elapsed, ">= 1" );
75 $h = harness( [ $^X ], \$in, \$out, timeout( 1 ) );
76 $started = time;
77 $h->start;
78 $in = '';
79 eval { $h->pump };
80 $@ =~ /IPC::Run: timeout/ ? ok( 1 ) : is( $@, qr/IPC::Run: timeout/ );
81 }
3182
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
83 SCOPE: {
84 my $elapsed = time - $started;
85 $elapsed >= 1 ? ok( 1 ) : is( $elapsed, ">= 1" );
86 }
+104
-125
t/timer.t less more
0 #!/usr/bin/perl -w
0 #!/usr/bin/perl
1
2 =pod
13
24 =head1 NAME
35
57
68 =cut
79
10 use strict;
811 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 }
12 $| = 1;
13 $^W = 1;
14 if( $ENV{PERL_CORE} ) {
15 chdir '../lib/IPC/Run' if -d '../lib/IPC/Run';
16 unshift @INC, 'lib', '../..';
17 $^X = '../../../t/' . $^X;
18 }
1419 }
1520
16 use strict ;
21 use Test::More tests => 72;
22 use IPC::Run qw( run );
23 use IPC::Run::Timer qw( :all );
1724
18 use Test ;
25 my $t;
26 my $started;
1927
20 use IPC::Run qw( run ) ;
21 use IPC::Run::Timer qw( :all ) ;
22 use UNIVERSAL qw( isa ) ;
28 $t = timer(
29 # debug => 1,
30 1,
31 );
32 is( ref $t, 'IPC::Run::Timer' );
2333
24 my $t ;
25 my $started ;
34 is( $t->interval, 1 );
2635
27 my @tests = (
36 $t->interval( 0 ); is( $t->interval, 0 );
37 $t->interval( 0.1 ); ok( $t->interval > 0 );
38 $t->interval( 1 ); ok( $t->interval >= 1 );
39 $t->interval( 30 ); ok( $t->interval >= 30 );
40 $t->interval( 30.1 ); ok( $t->interval > 30 );
41 $t->interval( 30.1 ); ok( $t->interval <= 31 );
2842
29 sub {
30 $t = timer(
31 # debug => 1,
32 1,
33 ) ;
34 ok( ref $t, 'IPC::Run::Timer' ) ;
35 },
43 $t->interval( "1:0" ); is( $t->interval, 60 );
44 $t->interval( "1:0:0" ); is( $t->interval, 3600 );
45 $t->interval( "1:1:1" ); is( $t->interval, 3661 );
46 $t->interval( "1:1:1.1" ); ok( $t->interval > 3661 );
47 $t->interval( "1:1:1.1" ); ok( $t->interval <= 3662 );
48 $t->interval( "1:1:1:1" ); is( $t->interval, 90061 );
3649
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 ) },
50 $t->reset;
51 $t->interval( 5 );
52 $t->start( 1, 0 );
53 ok( ! $t->is_expired );
54 ok( !! $t->is_running );
55 ok( ! $t->is_reset );
56 ok( !! $t->check( 0 ) );
57 ok( ! $t->is_expired );
58 ok( !! $t->is_running );
59 ok( ! $t->is_reset );
60 ok( !! $t->check( 1 ) );
61 ok( ! $t->is_expired );
62 ok( !! $t->is_running );
63 ok( ! $t->is_reset );
64 ok( ! $t->check( 2 ) );
65 ok( !! $t->is_expired );
66 ok( ! $t->is_running );
67 ok( ! $t->is_reset );
68 ok( ! $t->check( 3 ) );
69 ok( !! $t->is_expired );
70 ok( ! $t->is_running );
71 ok( ! $t->is_reset );
7872
7973 ## 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 ) },
8674
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 ) },
75 $t->start( undef, 0 );
76 ok( ! $t->is_expired );
77 ok( !! $t->is_running );
78 ok( ! $t->is_reset );
79 ok( !! $t->check( 0 ) );
80 ok( ! $t->is_expired );
81 ok( !! $t->is_running );
82 ok( ! $t->is_reset );
83 ok( !! $t->check( 1 ) );
84 ok( ! $t->is_expired );
85 ok( !! $t->is_running );
86 ok( ! $t->is_reset );
87 ok( ! $t->check( 2 ) );
88 ok( !! $t->is_expired );
89 ok( ! $t->is_running );
90 ok( ! $t->is_reset );
91 ok( ! $t->check( 3 ) );
92 ok( !! $t->is_expired );
93 ok( ! $t->is_running );
94 ok( ! $t->is_reset );
10395
10496 ## 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 ) },
11297
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 ) },
98 $t->start( 1, 0 );
99 $t->start( undef, 0 );
100 ok( ! $t->is_expired );
101 ok( !! $t->is_running );
102 ok( ! $t->is_reset );
103 ok( !! $t->check( 0 ) );
104 ok( ! $t->is_expired );
105 ok( !! $t->is_running );
106 ok( ! $t->is_reset );
107 ok( !! $t->check( 1 ) );
108 ok( ! $t->is_expired );
109 ok( !! $t->is_running );
110 ok( ! $t->is_reset );
111 ok( ! $t->check( 2 ) );
112 ok( !! $t->is_expired );
113 ok( ! $t->is_running );
114 ok( ! $t->is_reset );
115 ok( ! $t->check( 3 ) );
116 ok( !! $t->is_expired );
117 ok( ! $t->is_running );
118 ok( ! $t->is_reset );
129119
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
120 my $got;
121 eval {
122 $got = "timeout fired";
123 run [$^X, '-e', 'sleep 3'], timeout 1;
124 $got = "timeout didn't fire";
125 };
126 is $got, "timeout fired", "timer firing in run()";
+31
-32
t/win32_compile.t less more
0 #!/usr/bin/perl -w
0 #!/usr/bin/perl
1
2 =pod
13
24 =head1 NAME
35
57
68 =cut
79
10 use strict;
811 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 }
12 $| = 1;
13 $^W = 1;
14 if( $ENV{PERL_CORE} ) {
15 chdir '../lib/IPC/Run' if -d '../lib/IPC/Run';
16 unshift @INC, 'lib', '../..';
17 $^X = '../../../t/' . $^X;
18 }
1419 }
1520
16 use strict ;
17
18 use Test ;
21 use Test::More;
1922
2023 BEGIN {
2124 unless ( eval "require 5.006" ) {
2225 ## NOTE: I'm working around this here because I don't want this
2326 ## test to fail on non-Win32 systems with older Perls. Makefile.PL
2427 ## 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 plan( skip_all => "perl5.00503's Socket.pm does not export IPPROTO_TCP" );
2829 }
2930
31 $INC{$_} = 1 for qw( Win32/Process.pm Win32API/File.pm );
3032
31 $INC{$_} = 1 for qw( Win32/Process.pm Win32API/File.pm ) ;
33 package Win32API::File;
3234
33 package Win32API::File ;
35 use vars qw( @ISA @EXPORT );
3436
35 use vars qw( @ISA @EXPORT ) ;
36
37 @ISA = qw( Exporter ) ;
37 @ISA = qw( Exporter );
3838 @EXPORT = qw(
3939 GetOsFHandle
4040 OsFHandleOpen
5656 FILE_FLAG_WRITE_THROUGH
5757
5858 FILE_BEGIN
59 ) ;
59 );
6060
61 eval "sub $_ { 1 }" for @EXPORT ;
61 eval "sub $_ { 1 }" for @EXPORT;
6262
63 use Exporter ;
63 use Exporter;
6464
65 package Win32::Process ;
65 package Win32::Process;
6666
67 use vars qw( @ISA @EXPORT ) ;
67 use vars qw( @ISA @EXPORT );
6868
69 @ISA = qw( Exporter ) ;
69 @ISA = qw( Exporter );
7070 @EXPORT = qw(
7171 NORMAL_PRIORITY_CLASS
72 ) ;
72 );
7373
74 eval "sub $_ {}" for @EXPORT ;
74 eval "sub $_ {}" for @EXPORT;
7575
76 use Exporter ;
76 use Exporter;
7777 }
7878
7979 sub Socket::IPPROTO_TCP() { undef }
8080
81 package main ;
81 package main;
8282
83 use IPC::Run::Win32Helper ;
84 use IPC::Run::Win32IO ;
83 use IPC::Run::Win32Helper;
84 use IPC::Run::Win32IO;
8585
86 plan tests => 1 ;
86 plan( tests => 1 );
8787
88 ok 1 ;
89
88 ok( 1 );