IPC-Run-0.92/000750 000765 000024 00000000000 12017702723 012712 5ustar00toddstaff000000 000000 IPC-Run-0.92/abuse/000750 000765 000024 00000000000 12017702723 014011 5ustar00toddstaff000000 000000 IPC-Run-0.92/Changes000644 000765 000024 00000044326 12017702564 014226 0ustar00toddstaff000000 000000 Revision history for Perl extension IPC::Run 0.92 Thu Aug 30 2012 - Tests are good in dev version. Releasing to stable. 0.92_01 Wed 22 Aug 2012 - RT 59775 - Catching a signal during select() can lock up IPC::Run 0.91 Tue 14 Feb 2012 - Tests are good in dev version. Releasing to stable. 0.91_01 Mon 16 Jan 2012 - RT 57277 - Apply suggested 1 line fix for dev release to public. 0.90 Wed 29 Jun 2011 - RT 57277 - Add breaking test. No solution at present. - RT 68623 - disable parallel tests on windows - RT 43072 - Skip dragonfly platform on t/pty.t (hangs) - RT 14078 - run() miscalculates length of UTF-8 strings - RT 49693 - security patch for lib/IPC/Run/Win32IO.pm s/INADDR_ANY// - RT 38193 - Fix error detection on non-English operating systems - Add a blank doc entry for IPC::Run::Win32IO::poll to quiet windows pod parser errors - RT 57190 - handle PATH environment variable not being defined. WILL NOT default to '.' since UNIX would not do this and the program has been behaving the UNIX way to date. 0.89 Wed 31 Mar 2010 - Revert extended tests to require "oslo consensus" variables - http://use.perl.org/~Alias/journal/36128 - Add IO::Pty to META.yml requirement This has been inconsistently depended on over the years in META.yml 0.88 Tue 30 Mar 2010 - Missed dangling isa in IPC::Run::Debug - Fix retry for read of fh when I get "Resource temporarily unavailable." It was previously pounding on the file handle with no rest 200 times then giving up. On fast systems this wasn't long enough. I'm implementing select(undef, undef, 0.01) to provide a more consistent retry among hardware and os. - Fix POD indentation in IO.pm 0.87 Mon 29 Mar 2010 - Add doc type fixes - RT 56030 from carnil (Debian) - Remove reccommends for AUTHOR only modules - add pod_coverage and simplify pod test. - document undocumented public subs with TODO and best guess as to what they do. - Explicity recommend IO::Pty version number 1.08 0.86 Wed 24 Mar 2010 - Add all files to subversion for easier releases - bump version on ALL files to 86 0.85 Mon 22 Mar 2010 - Remove use UNIVERSAL. - RT 51509 - fix pod for Win32Helper - RT 51695 - Better PATHEXT logic bug if cmd_name contains periods - RT 50739 - Enhance tests for run.t for better diagnostics - RT 47630 0.84 Mon 13 Jul 2009 - Add darwin to the list of known-bad platforms 0.83 Fri 10 Jul 2009 - Switch from command.com to cmd.exe so we work on 2008 or newer. 0.82 Thu 18 Dec 2008 - Moving changes in 0.81_01 to a production release 0.81_01 Wed 15 Oct 2008 - This is the first in a series of refactoring test releases. - Removed Makefile.PL message noisily asking users to do CPAN Testers dirty work. - Simplfied the Makefile.PL code a little. - Upgraded all tests to Test::More - Added a $VERSION for all modules - Adding some missing POD sections - Various other clean ups 0.80 (missing) - IPC::Run::IO now retries on certain "temporarily unavailable" errors. This should fix several reported issues with t/run.t, test 69. Many thanks to < Eric (at) Scratch Computing (.com) > for the patch! - Applied documentation patch from RT. - Fixed documentation to work with '<' redirect 0.79 Wed Jan 19 15:39:00 PST 2005 - New maintainer: Richard Soderberg - Resolved several RT tickets (4934, 8263, 8060, 8400, 8624, 5870, 4658, 8940, 1474, 4311) - Skip certain tests on AIX and OpenBSD as they deadlock otherwise - Applied AIX patch from ActiveState (#8263) - Fixed t/run.t on OS X (#8940) - Add check for EINTR to _read (#5870) - FreeBSD uses fds up to 4 by default, fixed tests to start at 5 (#8060) 0.78 Tue Mar 9 01:49:25 EST 2004 - Removed all psuedohashes - Require Win32::Process when on Win32 () - Retry the select() instead of croaking when EINTR occurs (Ilya Martynov, ilya a t iponweb.net) - This needs further testing and analysis, but works for the submitter. 0.77 Fri Sep 26 15:36:56 EDT 2003 - Non-binmoded pipes are now s/\r//g on Win32 - Passes all tests on WinXPPro and WinNT - Deadlocks somewhere shortly after process creation on Win2K in some cases 0.76 (missing) - Does not use pseudohashes for perls >= 5.9.0 (reported by several users, patch by Nicholas Clark ) - pumpable() is now exported (reported by fetko@slaysys.com) - pumpable() now more thorough in checking for a dead child (reported by fetko@slaysys.com) - it checks for reapable processes when all pipes to the process are paused - pumpable() now yields the processor when all pipes to - Distro layout improved: Run.pm and Run/... are now under lib/IPC/... 0.75 Tue Jan 28 11:33:40 EST 2003 - Fix a bug that was causing _pipe() to seem to fail when feeding 0.74 Thu May 23 09:24:57 EDT 2002 - Skip a set of pty tests that deadlock on freebsd. Reported and investigated by Rocco Caputo . perldoc t/pty.t for details. 0.73 Wed May 22 09:03:26 EDT 2002 - Improved Win32 PATH and PATHEXT search; original patch by Ron Savage 0.72 Thu May 9 10:25:55 EDT 2002 - Doc patch from daniel@danielgardner.org - Backport Win32Helper to 5.00503 (compilation of this is tested on Unix or it would not have been spotted, not even by Matt Sergeant matts@sergeant.org). 0.71 Mon May 6 09:04:18 EDT 2002 - Fix the pesky run/t check for specific error string (test 134 at the moment, bad file descriptor test) that keeps tripping up cpantesters 0.70 Fri Apr 26 10:15:13 EDT 2002 - Massive performance improvements on Win32 See IPC::Run::Win32Helper's optimize() documentation. - moved data pump routine to IPC::Run::Win32Pump, now it loads much faster. - Where reasonably safe to do so, temporary files are used instead of pipes+pumps. - Setting $ENV{IPCRUNDEBUG}="notopt" can help find opportunities for optimizing. See IPC::Run::Debug for details. - Added 'noinherit => 1' option (parsed like 'debug => "basic") to allow stdin, stdout, and stderr to not be inherited by the child. - Factored debugging out in to IPC::Run::Debug so Win32Pump.pm need not load IPC::Run to get it. - Debugging code can be compile-time optimized away by setting $ENV{IPCRUNDEBUG} = "none" (or 0) before IPC::Run::Debug is first loaded causes all _debug... code to be optimized away before runtime. - Moved some functionality from IPC::Run in to IPC::Run::IO to allow IPC::Run::Win32IO to alter IPC::Run's behavior. More of this should happen; IPC::Run has grown too bloaty. - All the hokey hacky "manual imports" of IPC::Run's old _debug...() functions has been replaced by "use IPC::Run::Debug". - All the hokey hacky "manual imports" of IPC::Run's Win32_MODE() constant has been replaced by importing it from IPC::Run. - Cleaned up IPC::Run::Win32*'s debugging levels a bit to unclutter "basic" and "data" debugging level output. - exception handling in _open_pipes no longer silently eats exceptions. 0.67 Fri Apr 19 12:14:02 EDT 2002 - remove _q from the examples in the POD - it was inconsistent (the examples had bugs) and didn't help readability. Spotted by B.Rowlingson@lancaster.ac.uk. 0.66 Wed Mar 27 07:42:27 EST 2002 - Really dumb down that bad file descriptor test last tweaked in 0.64; the CLI does not script well under internationalization. 0.65 (unreleased) - Mostly focused on Win32 - pass filehandles to pumpers by number on the command line to avoid - use 2 arg binmode to force socket handles into/out of binmode - improve t/binmode.t - TODO: test ^Z and \000 pass-through. 0.64 Wed Mar 13 11:04:23 EST 2002 - Fix a test that fails on AIX because it uses a different message for "Bad file descriptor". Reported by "Dave Gomboc" - If IO::Pty is loadable, require IO::Pty 1.00 or later. 0.63 Wed Feb 27 12:25:22 EST 2002 - the select loop will now poll (with logarithmic fallback) when all I/O is closed but we have children running. Problem report by "William R. Pearson" . 0.62 Tue Jan 1 16:40:54 EST 2002 - Have all children close all file descriptors opened by the parent harness, otherwise children of different harnesses can unwittingly keep open fds the parent closes, thus preventing other children from seeing them close. Reported by Blair Zajac . 0.61 Fri Dec 7 05:21:28 EST 2001 - Fix up signal.t to not fail due to printing not working quite right in signal handlers. Spotted in the wild by Blair Zajac . 0.6 Thu Dec 6 04:36:57 EST 2001 - Get binmode--(">", binary) and ("<", binary)--working on Win32. 0.56 Sun Dec 2 09:18:19 EST 2001 - IPC::Run now throws exceptions from the post-fork, pre-exec child process back to the parent process using an additional pipe. This pipe also is used to pause the parent until the child performs the exec(), so that (when a new version of IO::Pty implements it) pty creation can be completed before the parent tries to write to it. 0.55 Sat Dec 1 17:15:02 EST 2001 - Fixups to Win32 code to get it compiling ok (added t/win32_compile.t to ensure that Win32Helper.pm at least compiles Ok). - Minor tweak to deal with "_" in $IO::Pty::VERSION, which is "0.92_04", including quotes, in the current version. 0.54 Fri Nov 30 11:46:05 EST 2001 - Win32 SUPPORT!!!!! - Added support for env. var. IPCRUNDEBUG=1 (or 2, 3, 4) to make it easier for users to debug the test suite. - Adapt to IO::Pty 0.91, which creates slave fds in new(), forcing us to close them in the parent after the fork(). We don't check for IO::Pty's version number, perhaps we should (waiting for a response from Roland Giersig about what he intends, since this could affect all users of older IO::Ptys that upgrade). - Add a sleep(1) to allow the slave pty to be initted, otherwise a premature write() to the slave's input can be lost. This is a bogus hack, but IO::Pty 0.9x should fix it when it's released. - removed spurious use Errno qw( EAGAIN ), since this causes warnings with perl5.00505. Reported by Christian Jaeger (pflanze). - IPC::Run::start() now does a kill_kill() if called on an already started harness. This is needed on Win32 to pass the test suite, but it's also a nice thing. - The debug file descriptor is built by dup()ing STDERR in the parent and passing it to the kids. This keeps us from needing to worry about debugging info in the select() loop and removes unnecessary complications. Still needs a bit of work: it should be dup()ed in _open_pipes and it's value should be stored in the harness, not a global. - child processes are now a little more clearly identified in debug output. - Some debugging messages are now clearer. - debugging is now almost ready to be compile-time optimized away. - "time since script start" is now shown when debugging. We should check to see if Time::HiRes is loaded and make this more accurate. - pipe opens are now down in Run::IO::open_pipe(). - map_fds won't complain about no open fds unnecessarily (which was rare, but still). - the debug fd is now determined per-harness, not globally. This requires a bit of a hack (since I don't want to require $harness->_debug everywhere _debug might be called), but it seems worthwhile. 0.5 Sat Nov 10 21:32:58 EST 2001 - confess() when undef passed to _exec() - Cleaned up some POD and code comments. - Added patch to make the write side of pipes & ptys that IPC::Run must write to be non-blocking. Added a test for pipes, but Boris reports that Solaris 8 something seems to still block in the pty case, though Linux does not, so I did not add a test for that case. Probably should add one and complain bitterly if it fails (rather than actually failing the tests) and ptys are used. Patch from Borislav Deianov . - Added a patch to invalidate the search path cache if the file is no longer executable, also from Borislav Deianov - Started implementation of an adopt() external call that would let you aggregate harnesses, and a t/adopt.t, but different children need to properly close all FDs: they're inheriting each other's FDs and not properly closing them. - Close $debug_fd in &sub coprocesses. - Document the problems with &sub coprocesses. - Fixed fork error return detection to actually work, spotted by Dave Mitchell . - Give errors if a path with a directory separator is passed in if the indicated filename does not exist, is not a file, or is not executable. They're unixish errors, but hey... - Allowed harness \@cmd, '>', $foo, timeout 10 ; to parse (it was mistakenly thinking I wanted to send output to the IPC::Run::Timer created by timeout(). - pumpable() now returns true if there are any kids left alive, so that timers may continue to run. - A timeout of 1 second is forced if there are no I/O pipes left open, so that the select loop won't hang in select() if there is no I/O to do. Perhaps should only do that if there are timers. - Added a signal() to send specified signals to processes. Chose this over the more traditional Unix kill() to avoid people thinking that kill() should kill off processes. - Added kill_kill() which does kill off processes and clean up the harness. Sends TERM then (if need be) waits and sends KILL. - timeouts now work. - Removed eval{}s from a few subs, we were being over protective. - Preserve pos() across updates to scalars we append to, so m//g matches will work. - Cleaned up the examples/ - Added abuse/ for (mostly user contributed) scripts that I can use as a manual regression test. Most/all are reflected in t/*.t, but not verbatim, so it's good to have to originals around in case they happen to trigger something t/*.t miss. - Cleaned up SYNOPSIS a bit: it was too scary. Still is, but less so. 0.44 Mon Oct 2 17:20:29 EDT 2000 - Commented out all code dealing with select()'s exception file descriptor mask. Exceptions are vaguely defined and until somebody asks for them I don't want to do anything automatic with them. Croaking on them was certainly a bad idea: FreeBSD and some other platforms raise an exception when a pipe is closed, even if there's data in the pipe. IPC::Run closes a pipe filehandle if it sees sysread() return an error or 0 bytes read. 0.43 Thu Aug 17 23:26:34 EDT 2000 - Added flushing of STDOUT and STDERR before fork()/spawn() so that the children won't inherit bufferloads of unflushed output. This seems to be automatic in 5.6.0, but can cause loads of grief in 5.00503. I wish there were a way to flush all open filehandles, like stdio's fflush( NULL ) ; 0.42 Thu Aug 17 23:26:34 EDT 2000 - Worked around psuedo-hash features not implemented in perl5.00503 - Deprecated passing hashes of options in favor of just passing name-vlaue pairs. 0.41 (missing) - Added result, results, full_result, full_results. I added so many variations because I expect that result and full_result are the most likely to get a lot of use, but I wanted to be able to return a list as well, without misusing wantarray. 0.4 Thu Jun 15 14:59:22 EDT 2000 - Added IPC::Run::IO and IPC::Run::Timer, bunches of tests. IPC::Run can now do more than just run child processes. - Scribbled more documentation. Needs a good edit. - Fixed some minor bugs here and there. 0.34 Thu Jun 8 06:39:23 EDT 2000 - Fixed bug in t/pty.t that prevented it from noticing IO::Pty - Converted IPC::Run to use fields. 0.32 Thu Jun 8 06:15:17 EDT 2000 - Added warning about missing IO::Pty in MakeMaker.PL. Thought about making it a prerequisite, but it's not: IPC::Run can do pipes, etc, if it's not found, and IO::Pty is more unix-specific than IPC::Run is. What I'd really like is an 'ENABLERS' section to MakeMaker.PL that tells CPAN.pm to try to install it but not to stress if it can't. - t/pty.t skips all tests if require IO::Pty fails. 0.31 Tue Jun 6 01:54:59 EDT 2000 - t/pty.t should now report what was received when checking it against a regex. This is because 0.3's failing a few tests on ppc-linux and the ok( $out =~ /.../ ) ; wasn't giving me enough info. I chose the 1 arg form due to older perl dists' Test.pm not grokking ok( $out, qr// ) ;. I should really do this to t/*.t, but I'm tired. - Removed the misfired Run/Pty.pm from the dist. 0.3 Sat Jun 3 08:33:17 EDT 2000 - Changed spelling of '<|<' and '>|>' to 'pipe'. This is to make it less confusing (I hope), since '>|' is a valid construct in some shells with totally unrelated semantics, and I plan on adding it to IPC::Run if a noclobber option ever makes it in. - Added 'pty>' operators. 0.21 Fri Jun 2 12:49:08 EDT 2000 - Added some advice for dealing with obstinate children - Converted many methods to plain subs for simplicity & performance - Converted to using local $debug to control debugging status for simplicity's sake. Don't know about performance effects, since dynamic scope lookups can be slow. 0.2 Thu Jun 1 01:48:29 EDT 2000 - Undid the creation of a pipe when passing a \*FOO or an IO::Handle ref and added '<|<', \*IN and '>|>', \*OUT syntax instead. This was because some very subtle bugs might have occured if \*FOO was left in the wrong opened/closed state before calling run(), start() or harness(). Now, \*FOO must be open before the start() call, and '<|<' and '>|>' will close \*IN or \*OUT (or whatever) and open a pipe on it. This is analagous to IPC/Open{2,3}.pm behaviors. - Added eg/factorial_scalar and eg/runsh. Rewrote eg/factorial_pipe. - Fixed bug that was preventing input scalar refs (ie input for the child process) from ever being read from a second time. This caused pump() to hang. - Cleaned up calculation and use of timeout values so that when select() times out, it isn't called again. It's now adding one second to the timeout value because time() resolution is 1 second and we want to guarantee a minimum timeout even when we sample the start time at the end of a second - minor name changes to some field names to make the code marginally less obscure. - Fixed the MakeMaker settings and the directory layout so "make install" actually works. 0.1 Tue Apr 25 22:10:07 2000 - Initial release IPC-Run-0.92/eg/000750 000765 000024 00000000000 12017702723 013305 5ustar00toddstaff000000 000000 IPC-Run-0.92/lib/000750 000765 000024 00000000000 12017702723 013460 5ustar00toddstaff000000 000000 IPC-Run-0.92/LICENSE000644 000765 000024 00000047371 11355012631 013734 0ustar00toddstaff000000 000000 Terms of Perl itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" ---------------------------------------------------------------------------- The General Public License (GPL) Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 675 Mass Ave, Cambridge, MA 02139, USA. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS ---------------------------------------------------------------------------- The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End IPC-Run-0.92/Makefile.PL000644 000765 000024 00000004515 12017702357 014701 0ustar00toddstaff000000 000000 use ExtUtils::MakeMaker; # Calculate the dependencies my %PREREQ_PM; if ( $^O ne 'MSWin32' ) { foreach ( eval { require IO::Pty; IO::Pty->VERSION } ) { s/_//g if defined $_; unless ( defined $_ ) { warn("WARNING: \"IO::Pty not found\".\nWARNING: 'pty>' will not work.\n\n"); last; } $PREREQ_PM{'IO::Pty'} = '1.08'; } } else { $PREREQ_PM{'Win32::Process'} = '0.14'; if ( ! eval "use Socket qw( IPPROTO_TCP TCP_NODELAY ); 1" ) { warn <<"TOHERE"; $@ IPC::Run on Win32 requires a recent Sockets.pm in order to handle more complex interactions with subprocesses. They are not needed for most casual uses of run(), but it is impossible to tell whether all uses of IPC::Run in your installed modules meet the requirements, so IPC::Run should not be installed on Win32 machines with older perls. TOHERE ## Die nicely in case some install manager cares about the canonical ## error message for this. Not that I've ever seen one, but those ## wacky CPANPLUSers might just do something cool in this case. ## Older perls' Socket.pm don't export IPPROTO_TCP require 5.006; ## Most of the time it's not needed (since IPC::Run tries not to ## use sockets), but the user is not likely to know what the hell ## went wrong running sb. else's program. ## If something really odd is happening... exit 1; } } WriteMakefile( NAME => 'IPC::Run', ABSTRACT => 'system() and background procs w/ piping, redirs, ptys (Unix, Win32)', AUTHOR => 'Barrie Slaymaker ', VERSION_FROM => 'lib/IPC/Run.pm', ($ExtUtils::MakeMaker::VERSION >= 6.3002 ? ('LICENSE' => 'perl', ) : ()), PREREQ_PM => { Test::More => '0.47', %PREREQ_PM, }, dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, clean => { FILES => 'IPC-Run-*' }, META_MERGE => { recommends => { 'IO::Pty' => '1.08', }, build_requires => { 'Test::More' => 0, # For testing }, resources => { license => 'http://dev.perl.org/licenses/', bugtracker => 'https://rt.cpan.org/NoAuth/Bugs.html?Dist=IPC-Run', repository => 'https://github.com/toddr/IPC-Run', } }); sub MY::libscan { package MY; my $self = shift; my ($path) = @_; return '' if $path =~ m/\.sw[a-z]\z/msx; return '' unless length $self->SUPER::libscan($path); return $path; } IPC-Run-0.92/MANIFEST000644 000765 000024 00000001556 12017702723 014057 0ustar00toddstaff000000 000000 abuse/blocking_debug_with_sub_coprocess abuse/blocking_writes abuse/broken_pipe_on_bad_executable_name abuse/timers Changes eg/factorial eg/factorial_pipe eg/factorial_scalar eg/run_daemon eg/runsh eg/runsu eg/synopsis_scripting lib/IPC/Run.pm lib/IPC/Run/Debug.pm lib/IPC/Run/IO.pm lib/IPC/Run/Timer.pm lib/IPC/Run/Win32Helper.pm lib/IPC/Run/Win32IO.pm lib/IPC/Run/Win32Pump.pm LICENSE Makefile.PL MANIFEST This list of files README t/97_meta.t t/98_pod.t t/98_pod_coverage.t t/99_perl_minimum_version.t t/adopt.t t/binmode.t t/bogus.t t/filter.t t/harness.t t/io.t t/kill_kill.t t/lib/Test.pm t/parallel.t t/pty.t t/pump.t t/run.t t/signal.t t/timeout.t t/timer.t t/windows_search_path.t t/win32_compile.t TODO META.yml Module meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) IPC-Run-0.92/META.json000640 000765 000024 00000002463 12017702723 014341 0ustar00toddstaff000000 000000 { "abstract" : "system() and background procs w/ piping, redirs, ptys (Unix, Win32)", "author" : [ "Barrie Slaymaker " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.62, CPAN::Meta::Converter version 2.120351", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "IPC-Run", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0", "Test::More" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "recommends" : { "IO::Pty" : "1.08" }, "requires" : { "IO::Pty" : "1.08", "Test::More" : "0.47" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://rt.cpan.org/NoAuth/Bugs.html?Dist=IPC-Run" }, "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "https://github.com/toddr/IPC-Run" } }, "version" : "0.92" } IPC-Run-0.92/META.yml000640 000765 000024 00000001362 12017702723 014166 0ustar00toddstaff000000 000000 --- abstract: 'system() and background procs w/ piping, redirs, ptys (Unix, Win32)' author: - 'Barrie Slaymaker ' build_requires: ExtUtils::MakeMaker: 0 Test::More: 0 configure_requires: ExtUtils::MakeMaker: 0 dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.62, CPAN::Meta::Converter version 2.120351' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: IPC-Run no_index: directory: - t - inc recommends: IO::Pty: 1.08 requires: IO::Pty: 1.08 Test::More: 0.47 resources: bugtracker: https://rt.cpan.org/NoAuth/Bugs.html?Dist=IPC-Run license: http://dev.perl.org/licenses/ repository: https://github.com/toddr/IPC-Run version: 0.92 IPC-Run-0.92/README000644 000765 000024 00000204117 11355012631 013600 0ustar00toddstaff000000 000000 NAME IPC::Run - system() and background procs w/ piping, redirs, ptys (Unix, Win32) SYNOPSIS ## First,a command to run: my @cat = qw( cat ); ## Using run() instead of system(): use IPC::Run qw( run timeout ); run \@cmd, \$in, \$out, \$err, timeout( 10 ) or die "cat: $?" # Can do I/O to sub refs and filenames, too: run \@cmd, '<', "in.txt", \&out, \&err or die "cat: $?" run \@cat, '<', "in.txt", '>>', "out.txt", '2>>', "err.txt"; # Redirecting using psuedo-terminals instad of pipes. run \@cat, 'pty>', \$out_and_err; ## Scripting subprocesses (like Expect): use IPC::Run qw( start pump finish timeout ); # Incrementally read from / write to scalars. # $in is drained as it is fed to cat's stdin, # $out accumulates cat's stdout # $err accumulates cat's stderr # $h is for "harness". my $h = start \@cat, \$in, \$out, \$err, timeout( 10 ); $in .= "some input\n"; pump $h until $out =~ /input\n/g; $in .= "some more input\n"; pump $h until $out =~ /\G.*more input\n/; $in .= "some final input\n"; finish $h or die "cat returned $?"; warn $err if $err; print $out; ## All of cat's output # Piping between children run \@cat, '|', \@gzip; # Multiple children simultaneously (run() blocks until all # children exit, use start() for background execution): run \@foo1, '&', \@foo2; # Calling \&set_up_child in the child before it executes the # command (only works on systems with true fork() & exec()) # exceptions thrown in set_up_child() will be propagated back # to the parent and thrown from run(). run \@cat, \$in, \$out, init => \&set_up_child; # Read from / write to file handles you open and close open IN, 'out.txt' or die $!; print OUT "preamble\n"; run \@cat, \*IN, \*OUT or die "cat returned $?"; print OUT "postamble\n"; close IN; close OUT; # Create pipes for you to read / write (like IPC::Open2 & 3). $h = start \@cat, 'pipe', \*OUT, '2>pipe', \*ERR or die "cat returned $?"; print IN "some input\n"; close IN; print , ; finish $h; # Mixing input and output modes run \@cat, 'in.txt', \&catch_some_out, \*ERR_LOG ); # Other redirection constructs run \@cat, '>&', \$out_and_err; run \@cat, '2>&1'; run \@cat, '0<&3'; run \@cat, '<&-'; run \@cat, '3<', \$in3; run \@cat, '4>', \$out4; # etc. # Passing options: run \@cat, 'in.txt', debug => 1; # Call this system's shell, returns TRUE on 0 exit code # THIS IS THE OPPOSITE SENSE OF system()'s RETURN VALUE run "cat a b c" or die "cat returned $?"; # Launch a sub process directly, no shell. Can't do redirection # with this form, it's here to behave like system() with an # inverted result. $r = run "cat a b c"; # Read from a file in to a scalar run io( "filename", 'r', \$recv ); run io( \*HANDLE, 'r', \$recv ); DESCRIPTION IPC::Run allows you run and interact with child processes using files, pipes, and pseudo-ttys. Both system()-style and scripted usages are supported and may be mixed. Likewise, functional and OO API styles are both supported and may be mixed. Various redirection operators reminiscent of those seen on common Unix and DOS command lines are provided. Before digging in to the details a few LIMITATIONS are important enough to be mentioned right up front: Win32 Support Win32 support is working but EXPERIMENTAL, but does pass all relevant tests on NT 4.0. See "Win32 LIMITATIONS". pty Support If you need pty support, IPC::Run should work well enough most of the time, but IO::Pty is being improved, and IPC::Run will be improved to use IO::Pty's new features when it is release. The basic problem is that the pty needs to initialize itself before the parent writes to the master pty, or the data written gets lost. So IPC::Run does a sleep(1) in the parent after forking to (hopefully) give the child a chance to run. This is a kludge that works well on non heavily loaded systems :(. ptys are not supported yet under Win32, but will be emulated... Debugging Tip You may use the environment variable "IPCRUNDEBUG" to see what's going on under the hood: $ IPCRUNDEBUG=basic myscript # prints minimal debugging $ IPCRUNDEBUG=data myscript # prints all data reads/writes $ IPCRUNDEBUG=details myscript # prints lots of low-level details $ IPCRUNDEBUG=gory myscript # (Win32 only) prints data moving through # the helper processes. We now return you to your regularly scheduled documentation. Harnesses Child processes and I/O handles are gathered in to a harness, then started and run until the processing is finished or aborted. run() vs. start(); pump(); finish(); There are two modes you can run harnesses in: run() functions as an enhanced system(), and start()/pump()/finish() allow for background processes and scripted interactions with them. When using run(), all data to be sent to the harness is set up in advance (though one can feed subprocesses input from subroutine refs to get around this limitation). The harness is run and all output is collected from it, then any child processes are waited for: run \@cmd, \<pump until $out =~ /^smb.*> \Z/m; die "error cding to /src:\n$out" if $out =~ "ERR"; $out = ''; $in = "mget *\n"; $h->pump until $out =~ /^smb.*> \Z/m; die "error retrieving files:\n$out" if $out =~ "ERR"; $in = "quit\n"; $h->finish; Notice that we carefully clear $out after the first command/response cycle? That's because IPC::Run does not delete $out when we continue, and we don't want to trip over the old output in the second command/response cycle. Say you want to accumulate all the output in $out and analyze it afterwards. Perl offers incremental regular expression matching using the "m//gc" and pattern matching idiom and the "\G" assertion. IPC::Run is careful not to disturb the current "pos()" value for scalars it appends data to, so we could modify the above so as not to destroy $out by adding a couple of "/gc" modifiers. The "/g" keeps us from tripping over the previous prompt and the "/c" keeps us from resetting the prior match position if the expected prompt doesn't materialize immediately: $h = harness \@smbclient, \$in, \$out; $in = "cd /src\n"; $h->pump until $out =~ /^smb.*> \Z/mgc; die "error cding to /src:\n$out" if $out =~ "ERR"; $in = "mget *\n"; $h->pump until $out =~ /^smb.*> \Z/mgc; die "error retrieving files:\n$out" if $out =~ "ERR"; $in = "quit\n"; $h->finish; analyze( $out ); When using this technique, you may want to preallocate $out to have plenty of memory or you may find that the act of growing $out each time new input arrives causes an "O(length($out)^2)" slowdown as $out grows. Say we expect no more than 10,000 characters of input at the most. To preallocate memory to $out, do something like: my $out = "x" x 10_000; $out = ""; "perl" will allocate at least 10,000 characters' worth of space, then mark the $out as having 0 length without freeing all that yummy RAM. Timeouts and Timers More than likely, you don't want your subprocesses to run forever, and sometimes it's nice to know that they're going a little slowly. Timeouts throw exceptions after a some time has elapsed, timers merely cause pump() to return after some time has elapsed. Neither is reset/restarted automatically. Timeout objects are created by calling timeout( $interval ) and passing the result to run(), start() or harness(). The timeout period starts ticking just after all the child processes have been fork()ed or spawn()ed, and are polled for expiration in run(), pump() and finish(). If/when they expire, an exception is thrown. This is typically useful to keep a subprocess from taking too long. If a timeout occurs in run(), all child processes will be terminated and all file/pipe/ptty descriptors opened by run() will be closed. File descriptors opened by the parent process and passed in to run() are not closed in this event. If a timeout occurs in pump(), pump_nb(), or finish(), it's up to you to decide whether to kill_kill() all the children or to implement some more graceful fallback. No I/O will be closed in pump(), pump_nb() or finish() by such an exception (though I/O is often closed down in those routines during the natural course of events). Often an exception is too harsh. timer( $interval ) creates timer objects that merely prevent pump() from blocking forever. This can be useful for detecting stalled I/O or printing a soothing message or "." to pacify an anxious user. Timeouts and timers can both be restarted at any time using the timer's start() method (this is not the start() that launches subprocesses). To restart a timer, you need to keep a reference to the timer: ## Start with a nice long timeout to let smbclient connect. If ## pump or finish take too long, an exception will be thrown. my $h; eval { $h = harness \@smbclient, \$in, \$out, \$err, ( my $t = timeout 30 ); sleep 11; # No effect: timer not running yet start $h; $in = "cd /src\n"; pump $h until ! length $in; $in = "ls\n"; ## Now use a short timeout, since this should be faster $t->start( 5 ); pump $h until ! length $in; $t->start( 10 ); ## Give smbclient a little while to shut down. $h->finish; }; if ( $@ ) { my $x = $@; ## Preserve $@ in case another exception occurs $h->kill_kill; ## kill it gently, then brutally if need be, or just ## brutally on Win32. die $x; } Timeouts and timers are *not* checked once the subprocesses are shut down; they will not expire in the interval between the last valid process and when IPC::Run scoops up the processes' result codes, for instance. Spawning synchronization, child exception propagation start() pauses the parent until the child executes the command or CODE reference and propagates any exceptions thrown (including exec() failure) back to the parent. This has several pleasant effects: any exceptions thrown in the child, including exec() failure, come flying out of start() or run() as though they had ocurred in the parent. This includes exceptions your code thrown from init subs. In this example: eval { run \@cmd, init => sub { die "blast it! foiled again!" }; }; print $@; the exception "blast it! foiled again" will be thrown from the child process (preventing the exec()) and printed by the parent. In situations like run \@cmd1, "|", \@cmd2, "|", \@cmd3; @cmd1 will be initted and exec()ed before @cmd2, and @cmd2 before @cmd3. This can save time and prevent oddball errors emitted by later commands when earlier commands fail to execute. Note that IPC::Run doesn't start any commands unless it can find the executables referenced by all commands. These executables must pass both the "-f" and "-x" tests described in perlfunc. Another nice effect is that init() subs can take their time doing things and there will be no problems caused by a parent continuing to execute before a child's init() routine is complete. Say the init() routine needs to open a socket or a temp file that the parent wants to connect to; without this synchronization, the parent will need to implement a retry loop to wait for the child to run, since often, the parent gets a lot of things done before the child's first timeslice is allocated. This is also quite necessary for pseudo-tty initialization, which needs to take place before the parent writes to the child via pty. Writes that occur before the pty is set up can get lost. A final, minor, nicety is that debugging output from the child will be emitted before the parent continues on, making for much clearer debugging output in complex situations. The only drawback I can conceive of is that the parent can't continue to operate while the child is being initted. If this ever becomes a problem in the field, we can implement an option to avoid this behavior, but I don't expect it to. Win32: executing CODE references isn't supported on Win32, see "Win32 LIMITATIONS" for details. Syntax run(), start(), and harness() can all take a harness specification as input. A harness specification is either a single string to be passed to the systems' shell: run "echo 'hi there'"; or a list of commands, io operations, and/or timers/timeouts to execute. Consecutive commands must be separated by a pipe operator '|' or an '&'. External commands are passed in as array references, and, on systems supporting fork(), Perl code may be passed in as subs: run \@cmd; run \@cmd1, '|', \@cmd2; run \@cmd1, '&', \@cmd2; run \&sub1; run \&sub1, '|', \&sub2; run \&sub1, '&', \&sub2; '|' pipes the stdout of \@cmd1 the stdin of \@cmd2, just like a shell pipe. '&' does not. Child processes to the right of a '&' will have their stdin closed unless it's redirected-to. IPC::Run::IO objects may be passed in as well, whether or not child processes are also specified: run io( "infile", ">", \$in ), io( "outfile", "<", \$in ); as can IPC::Run::Timer objects: run \@cmd, io( "outfile", "<", \$in ), timeout( 10 ); Commands may be followed by scalar, sub, or i/o handle references for redirecting child process input & output: run \@cmd, \undef, \$out; run \@cmd, \$in, \$out; run \@cmd1, \&in, '|', \@cmd2, \*OUT; run \@cmd1, \*IN, '|', \@cmd2, \&out; This is known as succinct redirection syntax, since run(), start() and harness(), figure out which file descriptor to redirect and how. File descriptor 0 is presumed to be an input for the child process, all others are outputs. The assumed file descriptor always starts at 0, unless the command is being piped to, in which case it starts at 1. To be explicit about your redirects, or if you need to do more complex things, there's also a redirection operator syntax: run \@cmd, '<', \undef, '>', \$out; run \@cmd, '<', \undef, '>&', \$out_and_err; run( \@cmd1, '<', \$in, '|', \@cmd2, \$out ); Operator syntax is required if you need to do something other than simple redirection to/from scalars or subs, like duping or closing file descriptors or redirecting to/from a named file. The operators are covered in detail below. After each \@cmd (or \&foo), parsing begins in succinct mode and toggles to operator syntax mode when an operator (ie plain scalar, not a ref) is seen. Once in operator syntax mode, parsing only reverts to succinct mode when a '|' or '&' is seen. In succinct mode, each parameter after the \@cmd specifies what to do with the next highest file descriptor. These File descriptor start with 0 (stdin) unless stdin is being piped to ("'|', \@cmd"), in which case they start with 1 (stdout). Currently, being on the left of a pipe ("\@cmd, \$out, \$err, '|'") does *not* cause stdout to be skipped, though this may change since it's not as DWIMerly as it could be. Only stdin is assumed to be an input in succinct mode, all others are assumed to be outputs. If no piping or redirection is specified for a child, it will inherit the parent's open file handles as dictated by your system's close-on-exec behavior and the $^F flag, except that processes after a '&' will not inherit the parent's stdin. Also note that $^F does not affect file desciptors obtained via POSIX, since it only applies to full-fledged Perl file handles. Such processes will have their stdin closed unless it has been redirected-to. If you want to close a child processes stdin, you may do any of: run \@cmd, \undef; run \@cmd, \""; run \@cmd, '<&-'; run \@cmd, '0<&-'; Redirection is done by placing redirection specifications immediately after a command or child subroutine: run \@cmd1, \$in, '|', \@cmd2, \$out; run \@cmd1, '<', \$in, '|', \@cmd2, '>', \$out; If you omit the redirection operators, descriptors are counted starting at 0. Descriptor 0 is assumed to be input, all others are outputs. A leading '|' consumes descriptor 0, so this works as expected. run \@cmd1, \$in, '|', \@cmd2, \$out; The parameter following a redirection operator can be a scalar ref, a subroutine ref, a file name, an open filehandle, or a closed filehandle. If it's a scalar ref, the child reads input from or sends output to that variable: $in = "Hello World.\n"; run \@cat, \$in, \$out; print $out; Scalars used in incremental (start()/pump()/finish()) applications are treated as queues: input is removed from input scalers, resulting in them dwindling to '', and output is appended to output scalars. This is not true of harnesses run() in batch mode. It's usually wise to append new input to be sent to the child to the input queue, and you'll often want to zap output queues to '' before pumping. $h = start \@cat, \$in; $in = "line 1\n"; pump $h; $in .= "line 2\n"; pump $h; $in .= "line 3\n"; finish $h; The final call to finish() must be there: it allows the child process(es) to run to completion and waits for their exit values. OBSTINATE CHILDREN Interactive applications are usually optimized for human use. This can help or hinder trying to interact with them through modules like IPC::Run. Frequently, programs alter their behavior when they detect that stdin, stdout, or stderr are not connected to a tty, assuming that they are being run in batch mode. Whether this helps or hurts depends on which optimizations change. And there's often no way of telling what a program does in these areas other than trial and error and, occasionally, reading the source. This includes different versions and implementations of the same program. All hope is not lost, however. Most programs behave in reasonably tractable manners, once you figure out what it's trying to do. Here are some of the issues you might need to be aware of. * fflush()ing stdout and stderr This lets the user see stdout and stderr immediately. Many programs undo this optimization if stdout is not a tty, making them harder to manage by things like IPC::Run. Many programs decline to fflush stdout or stderr if they do not detect a tty there. Some ftp commands do this, for instance. If this happens to you, look for a way to force interactive behavior, like a command line switch or command. If you can't, you will need to use a pseudo terminal ('pty>'). * false prompts Interactive programs generally do not guarantee that output from user commands won't contain a prompt string. For example, your shell prompt might be a '$', and a file named '$' might be the only file in a directory listing. This can make it hard to guarantee that your output parser won't be fooled into early termination of results. To help work around this, you can see if the program can alter it's prompt, and use something you feel is never going to occur in actual practice. You should also look for your prompt to be the only thing on a line: pump $h until $out =~ /^\s?\z/m; (use "(?!\n)\Z" in place of "\z" on older perls). You can also take the approach that IPC::ChildSafe takes and emit a command with known output after each 'real' command you issue, then look for this known output. See new_appender() and new_chunker() for filters that can help with this task. If it's not convenient or possibly to alter a prompt or use a known command/response pair, you might need to autodetect the prompt in case the local version of the child program is different then the one you tested with, or if the user has control over the look & feel of the prompt. * Refusing to accept input unless stdin is a tty. Some programs, for security reasons, will only accept certain types of input from a tty. su, notable, will not prompt for a password unless it's connected to a tty. If this is your situation, use a pseudo terminal ('pty>'). * Not prompting unless connected to a tty. Some programs don't prompt unless stdin or stdout is a tty. See if you can turn prompting back on. If not, see if you can come up with a command that you can issue after every real command and look for it's output, as IPC::ChildSafe does. There are two filters included with IPC::Run that can help with doing this: appender and chunker (see new_appender() and new_chunker()). * Different output format when not connected to a tty. Some commands alter their formats to ease machine parsability when they aren't connected to a pipe. This is actually good, but can be surprising. PSEUDO TERMINALS On systems providing pseudo terminals under /dev, IPC::Run can use IO::Pty (available on CPAN) to provide a terminal environment to subprocesses. This is necessary when the subprocess really wants to think it's connected to a real terminal. CAVEATS Psuedo-terminals are not pipes, though they are similar. Here are some differences to watch out for. Echoing Sending to stdin will cause an echo on stdout, which occurs before each line is passed to the child program. There is currently no way to disable this, although the child process can and should disable it for things like passwords. Shutdown IPC::Run cannot close a pty until all output has been collected. This means that it is not possible to send an EOF to stdin by half-closing the pty, as we can when using a pipe to stdin. This means that you need to send the child process an exit command or signal, or run() / finish() will time out. Be careful not to expect a prompt after sending the exit command. Command line editing Some subprocesses, notable shells that depend on the user's prompt settings, will reissue the prompt plus the command line input so far once for each character. '>pty>' means '&>pty>', not '1>pty>' The pseudo terminal redirects both stdout and stderr unless you specify a file descriptor. If you want to grab stderr separately, do this: start \@cmd, 'pty>', \$out, '2>', \$err; stdin, stdout, and stderr not inherited Child processes harnessed to a pseudo terminal have their stdin, stdout, and stderr completely closed before any redirection operators take effect. This casts of the bonds of the controlling terminal. This is not done when using pipes. Right now, this affects all children in a harness that has a pty in use, even if that pty would not affect a particular child. That's a bug and will be fixed. Until it is, it's best not to mix-and-match children. Redirection Operators Operator SHNP Description ======== ==== =========== <, N< SHN Redirects input to a child's fd N (0 assumed) >, N> SHN Redirects output from a child's fd N (1 assumed) >>, N>> SHN Like '>', but appends to scalars or named files >&, &> SHN Redirects stdout & stderr from a child process pty, N>pty S Like '>', but uses a pseudo-tty instead of a pipe N<&M Dups input fd N to input fd M M>&N Dups output fd N to input fd M N<&- Closes fd N pipe, N>pipe P Pipe opens H for caller to read, write, close. 'N' and 'M' are placeholders for integer file descriptor numbers. The terms 'input' and 'output' are from the child process's perspective. The SHNP field indicates what parameters an operator can take: S: \$scalar or \&function references. Filters may be used with these operators (and only these). H: \*HANDLE or IO::Handle for caller to open, and close N: "file name". P: \*HANDLE opened by IPC::Run as the parent end of a pipe, but read and written to and closed by the caller (like IPC::Open3). Redirecting input: [n]<, [n], [n]>>, [n]>&[m], [n]>pipe You can redirect any output the child emits to a scalar variable, subroutine, file handle, or file name. You can have &run truncate or append to named files or scalars. If you are redirecting stdin as well, or if the command is on the receiving end of a pipeline ('|'), you can omit the redirection operator: @ls = ( 'ls' ); run \@ls, \undef, \$out or die "ls returned $?"; run \@ls, \undef, \&out; ## Calls &out each time some output ## is received from the child's ## when undef is returned. run \@ls, \undef, '2>ls.err'; run \@ls, '2>', 'ls.err'; The two parameter form guarantees that the filename will not be interpreted as a redirection operator: run \@ls, '>', "&more"; run \@ls, '2>', ">foo\n"; You can pass file handles you've opened for writing: open( *OUT, ">out.txt" ); open( *ERR, ">err.txt" ); run \@cat, \*OUT, \*ERR; Passing a scalar reference and a code reference requires a little more work, but allows you to capture all of the output in a scalar or each piece of output by a callback: These two do the same things: run( [ 'ls' ], '2>', sub { $err_out .= $_[0] } ); does the same basic thing as: run( [ 'ls' ], '2>', \$err_out ); The subroutine will be called each time some data is read from the child. The >pipe operator is different in concept than the other '>' operators, although it's syntax is similar: $h = start \@cat, $in, '>pipe', \*OUT, '2>pipe', \*ERR; $in = "hello world\n"; finish $h; print ; print ; close OUT; close ERR; causes two pipe to be created, with one end attached to cat's stdout and stderr, respectively, and the other left open on OUT and ERR, so that the script can manually read(), select(), etc. on them. This is like the behavior of IPC::Open2 and IPC::Open3. Win32: The handle returned is actually a socket handle, so you can use select() on it. Duplicating output descriptors: >&m, n>&m This duplicates output descriptor number n (default is 1 if n is omitted) from descriptor number m. Duplicating input descriptors: <&m, n<&m This duplicates input descriptor number n (default is 0 if n is omitted) from descriptor number m Closing descriptors: <&-, 3<&- This closes descriptor number n (default is 0 if n is omitted). The following commands are equivalent: run \@cmd, \undef; run \@cmd, '<&-'; run \@cmd, ', >&, &>pipe, >pipe& The following pairs of commands are equivalent: run \@cmd, '>&', \$out; run \@cmd, '>', \$out, '2>&1'; run \@cmd, '>&', 'out.txt'; run \@cmd, '>', 'out.txt', '2>&1'; etc. File descriptor numbers are not permitted to the left or the right of these operators, and the '&' may occur on either end of the operator. The '&>pipe' and '>pipe&' variants behave like the '>pipe' operator, except that both stdout and stderr write to the created pipe. Redirection Filters Both input redirections and output redirections that use scalars or subs as endpoints may have an arbitrary number of filter subs placed between them and the child process. This is useful if you want to receive output in chunks, or if you want to massage each chunk of data sent to the child. To use this feature, you must use operator syntax: run( \@cmd '<', \&in_filter_2, \&in_filter_1, $in, '>', \&out_filter_1, \&in_filter_2, $out, ); This capability is not provided for IO handles or named files. Two filters are provided by IPC::Run: appender and chunker. Because these may take an argument, you need to use the constructor functions new_appender() and new_chunker() rather than using \& syntax: run( \@cmd '<', new_appender( "\n" ), $in, '>', new_chunker, $out, ); Just doing I/O If you just want to do I/O to a handle or file you open yourself, you may specify a filehandle or filename instead of a command in the harness specification: run io( "filename", '>', \$recv ); $h = start io( $io, '>', \$recv ); $h = harness \@cmd, '&', io( "file", '<', \$send ); Options Options are passed in as name/value pairs: run \@cat, \$in, debug => 1; If you pass the debug option, you may want to pass it in first, so you can see what parsing is going on: run debug => 1, \@cat, \$in; debug Enables debugging output in parent and child. Debugging info is emitted to the STDERR that was present when IPC::Run was first "use()"ed (it's "dup()"ed out of the way so that it can be redirected in children without having debugging output emitted on it). RETURN VALUES harness() and start() return a reference to an IPC::Run harness. This is blessed in to the IPC::Run package, so you may make later calls to functions as members if you like: $h = harness( ... ); $h->start; $h->pump; $h->finish; $h = start( .... ); $h->pump; ... Of course, using method call syntax lets you deal with any IPC::Run subclasses that might crop up, but don't hold your breath waiting for any. run() and finish() return TRUE when all subcommands exit with a 0 result code. This is the opposite of perl's system() command. All routines raise exceptions (via die()) when error conditions are recognized. A non-zero command result is not treated as an error condition, since some commands are tests whose results are reported in their exit codes. ROUTINES run Run takes a harness or harness specification and runs it, pumping all input to the child(ren), closing the input pipes when no more input is available, collecting all output that arrives, until the pipes delivering output are closed, then waiting for the children to exit and reaping their result codes. You may think of "run( ... )" as being like start( ... )->finish(); , though there is one subtle difference: run() does not set \$input_scalars to '' like finish() does. If an exception is thrown from run(), all children will be killed off "gently", and then "annihilated" if they do not go gently (in to that dark night. sorry). If any exceptions are thrown, this does a "kill_kill" before propogating them. signal ## To send it a specific signal by name ("USR1"): signal $h, "USR1"; $h->signal ( "USR1" ); If $signal is provided and defined, sends a signal to all child processes. Try not to send numeric signals, use "KILL" instead of 9, for instance. Numeric signals aren't portable. Throws an exception if $signal is undef. This will *not* clean up the harness, "finish" it if you kill it. Normally TERM kills a process gracefully (this is what the command line utility "kill" does by default), INT is sent by one of the keys "^C", "Backspace" or "", and "QUIT" is used to kill a process and make it coredump. The "HUP" signal is often used to get a process to "restart", rereading config files, and "USR1" and "USR2" for really application-specific things. Often, running "kill -l" (that's a lower case "L") on the command line will list the signals present on your operating system. WARNING: The signal subsystem is not at all portable. We *may* offer to simulate "TERM" and "KILL" on some operating systems, submit code to me if you want this. WARNING 2: Up to and including perl v5.6.1, doing almost anything in a signal handler could be dangerous. The most safe code avoids all mallocs and system calls, usually by preallocating a flag before entering the signal handler, altering the flag's value in the handler, and responding to the changed value in the main system: my $got_usr1 = 0; sub usr1_handler { ++$got_signal } $SIG{USR1} = \&usr1_handler; while () { sleep 1; print "GOT IT" while $got_usr1--; } Even this approach is perilous if ++ and -- aren't atomic on your system (I've never heard of this on any modern CPU large enough to run perl). kill_kill ## To kill off a process: $h->kill_kill; kill_kill $h; ## To specify the grace period other than 30 seconds: kill_kill $h, grace => 5; ## To send QUIT instead of KILL if a process refuses to die: kill_kill $h, coup_d_grace => "QUIT"; Sends a "TERM", waits for all children to exit for up to 30 seconds, then sends a "KILL" to any that survived the "TERM". Will wait for up to 30 more seconds for the OS to sucessfully "KILL" the processes. The 30 seconds may be overriden by setting the "grace" option, this overrides both timers. The harness is then cleaned up. The doubled name indicates that this function may kill again and avoids colliding with the core Perl "kill" function. Returns a 1 if the "TERM" was sufficient, or a 0 if "KILL" was required. Throws an exception if "KILL" did not permit the children to be reaped. NOTE: The grace period is actually up to 1 second longer than that given. This is because the granularity of "time" is 1 second. Let me know if you need finer granularity, we can leverage Time::HiRes here. Win32: Win32 does not know how to send real signals, so "TERM" is a full-force kill on Win32. Thus all talk of grace periods, etc. do not apply to Win32. harness Takes a harness specification and returns a harness. This harness is blessed in to IPC::Run, allowing you to use method call syntax for run(), start(), et al if you like. harness() is provided so that you can pre-build harnesses if you would like to, but it's not required.. You may proceed to run(), start() or pump() after calling harness() (pump() calls start() if need be). Alternatively, you may pass your harness specification to run() or start() and let them harness() for you. You can't pass harness specifications to pump(), though. close_terminal This is used as (or in) an init sub to cast off the bonds of a controlling terminal. It must precede all other redirection ops that affect STDIN, STDOUT, or STDERR to be guaranteed effective. start $h = start( \@cmd, \$in, \$out, ..., timeout( 30, name => "process timeout" ), $stall_timeout = timeout( 10, name => "stall timeout" ), ); $h = start \@cmd, '<', \$in, '|', \@cmd2, ...; start() accepts a harness or harness specification and returns a harness after building all of the pipes and launching (via fork()/exec(), or, maybe someday, spawn()) all the child processes. It does not send or receive any data on the pipes, see pump() and finish() for that. You may call harness() and then pass it's result to start() if you like, but you only need to if it helps you structure or tune your application. If you do call harness(), you may skip start() and proceed directly to pump. start() also starts all timers in the harness. See IPC::Run::Timer for more information. start() flushes STDOUT and STDERR to help you avoid duplicate output. It has no way of asking Perl to flush all your open filehandles, so you are going to need to flush any others you have open. Sorry. Here's how if you don't want to alter the state of $| for your filehandle: $ofh = select HANDLE; $of = $|; $| = 1; $| = $of; select $ofh; If you don't mind leaving output unbuffered on HANDLE, you can do the slightly shorter $ofh = select HANDLE; $| = 1; select $ofh; Or, you can use IO::Handle's flush() method: use IO::Handle; flush HANDLE; Perl needs the equivalent of C's fflush( (FILE *)NULL ). pump pump $h; $h->pump; Pump accepts a single parameter harness. It blocks until it delivers some input or recieves some output. It returns TRUE if there is still input or output to be done, FALSE otherwise. pump() will automatically call start() if need be, so you may call harness() then proceed to pump() if that helps you structure your application. If pump() is called after all harnessed activities have completed, a "process ended prematurely" exception to be thrown. This allows for simple scripting of external applications without having to add lots of error handling code at each step of the script: $h = harness \@smbclient, \$in, \$out, $err; $in = "cd /foo\n"; $h->pump until $out =~ /^smb.*> \Z/m; die "error cding to /foo:\n$out" if $out =~ "ERR"; $out = ''; $in = "mget *\n"; $h->pump until $out =~ /^smb.*> \Z/m; die "error retrieving files:\n$out" if $out =~ "ERR"; $h->finish; warn $err if $err; pump_nb pump_nb $h; $h->pump_nb; "pump() non-blocking", pumps if anything's ready to be pumped, returns immediately otherwise. This is useful if you're doing some long-running task in the foreground, but don't want to starve any child processes. pumpable Returns TRUE if calling pump() won't throw an immediate "process ended prematurely" exception. This means that there are open I/O channels or active processes. May yield the parent processes' time slice for 0.01 second if all pipes are to the child and all are paused. In this case we can't tell if the child is dead, so we yield the processor and then attempt to reap the child in a nonblocking way. reap_nb Attempts to reap child processes, but does not block. Does not currently take any parameters, one day it will allow specific children to be reaped. Only call this from a signal handler if your "perl" is recent enough to have safe signal handling (5.6.1 did not, IIRC, but it was beign discussed on perl5-porters). Calling this (or doing any significant work) in a signal handler on older "perl"s is asking for seg faults. finish This must be called after the last start() or pump() call for a harness, or your system will accumulate defunct processes and you may "leak" file descriptors. finish() returns TRUE if all children returned 0 (and were not signaled and did not coredump, ie ! $?), and FALSE otherwise (this is like run(), and the opposite of system()). Once a harness has been finished, it may be run() or start()ed again, including by pump()s auto-start. If this throws an exception rather than a normal exit, the harness may be left in an unstable state, it's best to kill the harness to get rid of all the child processes, etc. Specifically, if a timeout expires in finish(), finish() will not kill all the children. Call "<$h-"kill_kill>> in this case if you care. This differs from the behavior of "run". result $h->result; Returns the first non-zero result code (ie $? >> 8). See "full_result" to get the $? value for a child process. To get the result of a particular child, do: $h->result( 0 ); # first child's $? >> 8 $h->result( 1 ); # second child or ($h->results)[0] ($h->results)[1] Returns undef if no child processes were spawned and no child number was specified. Throws an exception if an out-of-range child number is passed. results Returns a list of child exit values. See "full_results" if you want to know if a signal killed the child. Throws an exception if the harness is not in a finished state. full_result $h->full_result; Returns the first non-zero $?. See "result" to get the first $? >> 8 value for a child process. To get the result of a particular child, do: $h->full_result( 0 ); # first child's $? >> 8 $h->full_result( 1 ); # second child or ($h->full_results)[0] ($h->full_results)[1] Returns undef if no child processes were spawned and no child number was specified. Throws an exception if an out-of-range child number is passed. full_results Returns a list of child exit values as returned by "wait". See "results" if you don't care about coredumps or signals. Throws an exception if the harness is not in a finished state. FILTERS These filters are used to modify input our output between a child process and a scalar or subroutine endpoint. binary run \@cmd, ">", binary, \$out; run \@cmd, ">", binary, \$out; ## Any TRUE value to enable run \@cmd, ">", binary 0, \$out; ## Any FALSE value to disable This is a constructor for a "binmode" "filter" that tells IPC::Run to keep the carriage returns that would ordinarily be edited out for you (binmode is usually off). This is not a real filter, but an option masquerading as a filter. It's not named "binmode" because you're likely to want to call Perl's binmode in programs that are piping binary data around. new_chunker This breaks a stream of data in to chunks, based on an optional scalar or regular expression parameter. The default is the Perl input record separator in $/, which is a newline be default. run \@cmd, '>', new_chunker, \&lines_handler; run \@cmd, '>', new_chunker( "\r\n" ), \&lines_handler; Because this uses $/ by default, you should always pass in a parameter if you are worried about other code (modules, etc) modifying $/. If this filter is last in a filter chain that dumps in to a scalar, the scalar must be set to '' before a new chunk will be written to it. As an example of how a filter like this can be written, here's a chunker that splits on newlines: sub line_splitter { my ( $in_ref, $out_ref ) = @_; return 0 if length $$out_ref; return input_avail && do { while (1) { if ( $$in_ref =~ s/\A(.*?\n)// ) { $$out_ref .= $1; return 1; } my $hmm = get_more_input; unless ( defined $hmm ) { $$out_ref = $$in_ref; $$in_ref = ''; return length $$out_ref ? 1 : 0; } return 0 if $hmm eq 0; } } }; new_appender This appends a fixed string to each chunk of data read from the source scalar or sub. This might be useful if you're writing commands to a child process that always must end in a fixed string, like "\n": run( \@cmd, '<', new_appender( "\n" ), \&commands, ); Here's a typical filter sub that might be created by new_appender(): sub newline_appender { my ( $in_ref, $out_ref ) = @_; return input_avail && do { $$out_ref = join( '', $$out_ref, $$in_ref, "\n" ); $$in_ref = ''; 1; } }; io Takes a filename or filehandle, a redirection operator, optional filters, and a source or destination (depends on the redirection operator). Returns an IPC::Run::IO object suitable for harness()ing (including via start() or run()). This is shorthand for require IPC::Run::IO; ... IPC::Run::IO->new(...) ... timer $h = start( \@cmd, \$in, \$out, $t = timer( 5 ) ); pump $h until $out =~ /expected stuff/ || $t->is_expired; Instantiates a non-fatal timer. pump() returns once each time a timer expires. Has no direct effect on run(), but you can pass a subroutine to fire when the timer expires. See "timeout" for building timers that throw exceptions on expiration. See "timer" in IPC::Run::Timer for details. timeout $h = start( \@cmd, \$in, \$out, $t = timeout( 5 ) ); pump $h until $out =~ /expected stuff/; Instantiates a timer that throws an exception when it expires. If you don't provide an exception, a default exception that matches /^IPC::Run: .*timed out/ is thrown by default. You can pass in your own exception scalar or reference: $h = start( \@cmd, \$in, \$out, $t = timeout( 5, exception => 'slowpoke' ), ); or set the name used in debugging message and in the default exception string: $h = start( \@cmd, \$in, \$out, timeout( 50, name => 'process timer' ), $stall_timer = timeout( 5, name => 'stall timer' ), ); pump $h until $out =~ /started/; $in = 'command 1'; $stall_timer->start; pump $h until $out =~ /command 1 finished/; $in = 'command 2'; $stall_timer->start; pump $h until $out =~ /command 2 finished/; $in = 'very slow command 3'; $stall_timer->start( 10 ); pump $h until $out =~ /command 3 finished/; $stall_timer->start( 5 ); $in = 'command 4'; pump $h until $out =~ /command 4 finished/; $stall_timer->reset; # Prevent restarting or expirng finish $h; See "timer" for building non-fatal timers. See "timer" in IPC::Run::Timer for details. FILTER IMPLEMENTATION FUNCTIONS These functions are for use from within filters. input_avail Returns TRUE if input is available. If none is available, then &get_more_input is called and its result is returned. This is usually used in preference to &get_more_input so that the calling filter removes all data from the $in_ref before more data gets read in to $in_ref. "input_avail" is usually used as part of a return expression: return input_avail && do { ## process the input just gotten 1; }; This technique allows input_avail to return the undef or 0 that a filter normally returns when there's no input to process. If a filter stores intermediate values, however, it will need to react to an undef: my $got = input_avail; if ( ! defined $got ) { ## No more input ever, flush internal buffers to $out_ref } return $got unless $got; ## Got some input, move as much as need be return 1 if $added_to_out_ref; get_more_input This is used to fetch more input in to the input variable. It returns undef if there will never be any more input, 0 if there is none now, but there might be in the future, and TRUE if more input was gotten. "get_more_input" is usually used as part of a return expression, see "input_avail" for more information. TODO These will be addressed as needed and as time allows. Stall timeout. Expose a list of child process objects. When I do this, each child process is likely to be blessed into IPC::Run::Proc. $kid->abort(), $kid->kill(), $kid->signal( $num_or_name ). Write tests for /(full_)?results?/ subs. Currently, pump() and run() only work on systems where select() works on the filehandles returned by pipe(). This does *not* include ActiveState on Win32, although it does work on cygwin under Win32 (thought the tests whine a bit). I'd like to rectify that, suggestions and patches welcome. Likewise start() only fully works on fork()/exec() machines (well, just fork() if you only ever pass perl subs as subprocesses). There's some scaffolding for calling Open3::spawn_with_handles(), but that's untested, and not that useful with limited select(). Support for "\@sub_cmd" as an argument to a command which gets replaced with /dev/fd or the name of a temporary file containing foo's output. This is like <(sub_cmd ...) found in bash and csh (IIRC). Allow multiple harnesses to be combined as independant sets of processes in to one 'meta-harness'. Allow a harness to be passed in place of an \@cmd. This would allow multiple harnesses to be aggregated. Ability to add external file descriptors w/ filter chains and endpoints. Ability to add timeouts and timing generators (i.e. repeating timeouts). High resolution timeouts. Win32 LIMITATIONS Fails on Win9X If you want Win9X support, you'll have to debug it or fund me because I don't use that system any more. The Win32 subsysem has been extended to use temporary files in simple run() invocations and these may actually work on Win9X too, but I don't have time to work on it. May deadlock on Win2K (but not WinNT4 or WinXPPro) Spawning more than one subprocess on Win2K causes a deadlock I haven't figured out yet, but simple uses of run() often work. Passes all tests on WinXPPro and WinNT. no support yet for pty> These are likely to be implemented as "<" and ">" with binmode on, not sure. no support for file descriptors higher than 2 (stderr) Win32 only allows passing explicit fds 0, 1, and 2. If you really, really need to pass file handles, us Win32API:: GetOsFHandle() or ::FdGetOsFHandle() to get the integer handle and pass it to the child process using the command line, environment, stdin, intermediary file, or other IPC mechnism. Then use that handle in the child (Win32API.pm provides ways to reconstitute Perl file handles from Win32 file handles). no support for subroutine subprocesses (CODE refs) Can't fork(), so the subroutines would have no context, and closures certainly have no meaning Perhaps with Win32 fork() emulation, this can be supported in a limited fashion, but there are other very serious problems with that: all parent fds get dup()ed in to the thread emulating the forked process, and that keeps the parent from being able to close all of the appropriate fds. no support for init => sub {} routines. Win32 processes are created from scratch, there is no way to do an init routine that will affect the running child. Some limited support might be implemented one day, do chdir() and %ENV changes can be made. signals Win32 does not fully support signals. signal() is likely to cause errors unless sending a signal that Perl emulates, and "kill_kill()" is immediately fatal (there is no grace period). helper processes IPC::Run uses helper processes, one per redirected file, to adapt between the anonymous pipe connected to the child and the TCP socket connected to the parent. This is a waste of resources and will change in the future to either use threads (instead of helper processes) or a WaitForMultipleObjects call (instead of select). Please contact me if you can help with the WaitForMultipleObjects() approach; I haven't figured out how to get at it without C code. shutdown pause There seems to be a pause of up to 1 second between when a child program exits and the corresponding sockets indicate that they are closed in the parent. Not sure why. binmode binmode is not supported yet. The underpinnings are implemented, just ask if you need it. IPC::Run::IO IPC::Run::IO objects can be used on Unix to read or write arbitrary files. On Win32, they will need to use the same helper processes to adapt from non-select()able filehandles to select()able ones (or perhaps WaitForMultipleObjects() will work with them, not sure). startup race conditions There seems to be an occasional race condition between child process startup and pipe closings. It seems like if the child is not fully created by the time CreateProcess returns and we close the TCP socket being handed to it, the parent socket can also get closed. This is seen with the Win32 pumper applications, not the "real" child process being spawned. I assume this is because the kernel hasn't gotten around to incrementing the reference count on the child's end (since the child was slow in starting), so the parent's closing of the child end causes the socket to be closed, thus closing the parent socket. Being a race condition, it's hard to reproduce, but I encountered it while testing this code on a drive share to a samba box. In this case, it takes t/run.t a long time to spawn it's chile processes (the parent hangs in the first select for several seconds until the child emits any debugging output). I have not seen it on local drives, and can't reproduce it at will, unfortunately. The symptom is a "bad file descriptor in select()" error, and, by turning on debugging, it's possible to see that select() is being called on a no longer open file descriptor that was returned from the _socket() routine in Win32Helper. There's a new confess() that checks for this ("PARENT_HANDLE no longer open"), but I haven't been able to reproduce it (typically). LIMITATIONS On Unix, requires a system that supports "waitpid( $pid, WNOHANG )" so it can tell if a child process is still running. PTYs don't seem to be non-blocking on some versions of Solaris. Here's a test script contributed by Borislav Deianov to see if you have the problem. If it dies, you have the problem. #!/usr/bin/perl use IPC::Run qw(run); use Fcntl; use IO::Pty; sub makecmd { return ['perl', '-e', ', print "\n" x '.$_[0].'; while(){last if /end/}']; } #pipe R, W; #fcntl(W, F_SETFL, O_NONBLOCK); #while (syswrite(W, "\n", 1)) { $pipebuf++ }; #print "pipe buffer size is $pipebuf\n"; my $pipebuf=4096; my $in = "\n" x ($pipebuf * 2) . "end\n"; my $out; $SIG{ALRM} = sub { die "Never completed!\n" }; print "reading from scalar via pipe..."; alarm( 2 ); run(makecmd($pipebuf * 2), '<', \$in, '>', \$out); alarm( 0 ); print "done\n"; print "reading from code via pipe... "; alarm( 2 ); run(makecmd($pipebuf * 3), '<', sub { $t = $in; undef $in; $t}, '>', \$out); alarm( 0 ); print "done\n"; $pty = IO::Pty->new(); $pty->blocking(0); $slave = $pty->slave(); while ($pty->syswrite("\n", 1)) { $ptybuf++ }; print "pty buffer size is $ptybuf\n"; $in = "\n" x ($ptybuf * 3) . "end\n"; print "reading via pty... "; alarm( 2 ); run(makecmd($ptybuf * 3), '', \$out); alarm(0); print "done\n"; No support for ';', '&&', '||', '{ ... }', etc: use perl's, since run() returns TRUE when the command exits with a 0 result code. Does not provide shell-like string interpolation. No support for "cd", "setenv", or "export": do these in an init() sub run( \cmd, ... init => sub { chdir $dir or die $!; $ENV{FOO}='BAR' } ); Timeout calculation does not allow absolute times, or specification of days, months, etc. WARNING: Function coprocesses ("run \&foo, ...") suffer from two limitations. The first is that it is difficult to close all filehandles the child inherits from the parent, since there is no way to scan all open FILEHANDLEs in Perl and it both painful and a bit dangerous to close all open file descriptors with "POSIX::close()". Painful because we can't tell which fds are open at the POSIX level, either, so we'd have to scan all possible fds and close any that we don't want open (normally "exec()" closes any non-inheritable but we don't "exec()" for &sub processes. The second problem is that Perl's DESTROY subs and other on-exit cleanup gets run in the child process. If objects are instantiated in the parent before the child is forked, the the DESTROY will get run once in the parent and once in the child. When coprocess subs exit, POSIX::exit is called to work around this, but it means that objects that are still referred to at that time are not cleaned up. So setting package vars or closure vars to point to objects that rely on DESTROY to affect things outside the process (files, etc), will lead to bugs. I goofed on the syntax: "filename" are both oddities. TODO Allow one harness to "adopt" another: $new_h = harness \@cmd2; $h->adopt( $new_h ); Close all filehandles not explicitly marked to stay open. The problem with this one is that there's no good way to scan all open FILEHANDLEs in Perl, yet you don't want child processes inheriting handles willy-nilly. INSPIRATION Well, select() and waitpid() badly needed wrapping, and open3() isn't open-minded enough for me. The shell-like API inspired by a message Russ Allbery sent to perl5-porters, which included: I've thought for some time that it would be nice to have a module that could handle full Bourne shell pipe syntax internally, with fork and exec, without ever invoking a shell. Something that you could give things like: pipeopen (PIPE, [ qw/cat file/ ], '|', [ 'analyze', @args ], '>&3'); Message ylln51p2b6.fsf@windlord.stanford.edu, on 2000/02/04. SUPPORT Bugs should always be submitted via the CPAN bug tracker For other issues, contact the maintainer (the first listed author) AUTHORS Adam Kennedy Barrie Slaymaker COPYRIGHT Some parts copyright 2008 - 2009 Adam Kennedy. Copyright 1999 Barrie Slaymaker. You may distribute under the terms of either the GNU General Public License or the Artistic License, as specified in the README file. IPC-Run-0.92/t/000750 000765 000024 00000000000 12017702723 013155 5ustar00toddstaff000000 000000 IPC-Run-0.92/TODO000644 000765 000024 00000000124 11355012627 013405 0ustar00toddstaff000000 000000 TODO for IPC::Run - Debug Win2K deadlock - Debug t\run.t's resource problem on rh8 IPC-Run-0.92/t/97_meta.t000644 000765 000024 00000001073 11355012630 014610 0ustar00toddstaff000000 000000 #!/usr/bin/perl # Test that our META.yml file matches the current specification. use strict; BEGIN { $| = 1; $^W = 1; } my $MODULE = 'Test::CPAN::Meta 0.12'; # Don't run tests for installs use Test::More; unless ( $ENV{AUTOMATED_TESTING} or $ENV{RELEASE_TESTING} ) { plan( skip_all => "Author tests not required for installation" ); } # Load the testing module eval "use $MODULE"; if ( $@ ) { $ENV{RELEASE_TESTING} ? die( "Failed to load required release-testing module $MODULE" ) : plan( skip_all => "$MODULE not available for testing" ); } meta_yaml_ok(); IPC-Run-0.92/t/98_pod.t000644 000765 000024 00000001206 11355017072 014450 0ustar00toddstaff000000 000000 #!/usr/bin/perl # Test that the syntax of our POD documentation is valid use strict; BEGIN { $| = 1; $^W = 1; } my @MODULES = ( 'Pod::Simple 3.07', 'Test::Pod 1.26', ); # Don't run tests during end-user installs use Test::More; unless ( $ENV{AUTOMATED_TESTING} or $ENV{RELEASE_TESTING} ) { plan( skip_all => "Author tests not required for installation" ); } # Load the testing modules foreach my $MODULE ( @MODULES ) { eval "use $MODULE"; if ( $@ ) { $ENV{RELEASE_TESTING} ? die( "Failed to load required release-testing module $MODULE" ) : plan( skip_all => "$MODULE not available for testing" ); } } all_pod_files_ok(); 1; IPC-Run-0.92/t/98_pod_coverage.t000644 000765 000024 00000003030 11355017321 016315 0ustar00toddstaff000000 000000 #!/usr/bin/perl # Test that the syntax of our POD documentation is valid use strict; BEGIN { $| = 1; $^W = 1; } my @MODULES = ( 'Test::Pod::Coverage 1.04', ); # Don't run tests during end-user installs use Test::More; unless ( $ENV{AUTOMATED_TESTING} or $ENV{RELEASE_TESTING} ) { plan( skip_all => "Author tests not required for installation" ); } # Load the testing modules foreach my $MODULE ( @MODULES ) { eval "use $MODULE"; if ( $@ ) { $ENV{RELEASE_TESTING} ? die( "Failed to load required release-testing module $MODULE" ) : plan( skip_all => "$MODULE not available for testing" ); } } plan tests => 7; #my $private_subs = { private => [qr/foo_fizz/]}; #pod_coverage_ok('IPC::Run', $private_subs, "Test IPC::Run that all modules are documented."); pod_coverage_ok('IPC::Run' , "Test IPC::Run that all modules are documented."); pod_coverage_ok('IPC::Run::Debug' , "Test IPC::Run::Debug that all modules are documented."); pod_coverage_ok('IPC::Run::IO' , "Test IPC::Run::IO that all modules are documented."); pod_coverage_ok('IPC::Run::Timer' , "Test IPC::Run::Timer that all modules are documented."); pod_coverage_ok('IPC::Run::Win32Helper', "Test IPC::Run::Win32Helper that all modules are documented."); pod_coverage_ok('IPC::Run::Win32IO' , "Test IPC::Run::Win32IO that all modules are documented."); pod_coverage_ok('IPC::Run::Win32Pump' , "Test IPC::Run::Win32Pump that all modules are documented."); IPC-Run-0.92/t/99_perl_minimum_version.t000644 000765 000024 00000001266 11355017072 020137 0ustar00toddstaff000000 000000 #!/usr/bin/perl # Test that our declared minimum Perl version matches our syntax use strict; BEGIN { $| = 1; $^W = 1; } my @MODULES = ( 'Perl::MinimumVersion 1.20', 'Test::MinimumVersion 0.008', ); # Don't run tests during end-user installs use Test::More; unless ( $ENV{AUTOMATED_TESTING} or $ENV{RELEASE_TESTING} ) { plan( skip_all => "Author tests not required for installation" ); } # Load the testing modules foreach my $MODULE ( @MODULES ) { eval "use $MODULE"; if ( $@ ) { $ENV{RELEASE_TESTING} ? die( "Failed to load required release-testing module $MODULE" ) : plan( skip_all => "$MODULE not available for testing" ); } } all_minimum_version_from_metayml_ok(); 1; IPC-Run-0.92/t/adopt.t000644 000765 000024 00000003176 11355012630 014460 0ustar00toddstaff000000 000000 #!/usr/bin/perl =pod =head1 NAME adopt.t - Test suite for IPC::Run::adopt =cut use strict; BEGIN { $| = 1; $^W = 1; if( $ENV{PERL_CORE} ) { chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; unshift @INC, 'lib', '../..'; $^X = '../../../t/' . $^X; } } use Test::More skip_all => 'adopt not implemented yet'; # use Test::More tests => 29; use IPC::Run qw( start pump finish ); ## ## $^X is the path to the perl binary. This is used run all the subprocesses. ## my @echoer = ( $^X, '-pe', 'BEGIN { $| = 1 }' ); ## ## harness, pump, run ## SCOPE: { my $in = 'SHOULD BE UNCHANGED'; my $out = 'REPLACE ME'; $? = 99; my $fd_map = IPC::Run::_map_fds(); my $h = start( \@echoer, \$in, \$out ); ok( $h->isa('IPC::Run') ); ok( $?, 99 ); ok( $in, 'SHOULD BE UNCHANGED' ); ok( $out, '' ); ok( $h->pumpable ); $in = ''; $? = 0; pump_nb $h for ( 1..100 ); ok( 1 ); ok( $in, '' ); ok( $out, '' ); ok( $h->pumpable ); } SCOPE: { my $in = 'SHOULD BE UNCHANGED'; my $out = 'REPLACE ME'; $? = 99; my $fd_map = IPC::Run::_map_fds(); my $h = start( \@echoer, \$in, \$out ); ok( $h->isa('IPC::Run') ); ok( $?, 99 ); ok( $in, 'SHOULD BE UNCHANGED' ); ok( $out, '' ); ok( $h->pumpable ); $in = "hello\n"; $? = 0; pump $h until $out =~ /hello/; ok( 1 ); ok( ! $? ); ok( $in, '' ); ok( $out, "hello\n" ); ok( $h->pumpable ); $in = "world\n"; $? = 0; pump $h until $out =~ /world/; ok( 1 ); ok( ! $? ); ok( $in, '' ); ok( $out, "hello\nworld\n" ); ok( $h->pumpable ); warn "hi"; ok( $h->finish ); ok( ! $? ); ok( IPC::Run::_map_fds(), $fd_map ); ok( $out, "hello\nworld\n" ); ok( ! $h->pumpable ); } IPC-Run-0.92/t/binmode.t000644 000765 000024 00000005074 11355012630 014765 0ustar00toddstaff000000 000000 #!/usr/bin/perl =pod =head1 NAME binary.t - Test suite for IPC::Run binary functionality =cut use strict; BEGIN { $| = 1; $^W = 1; if( $ENV{PERL_CORE} ) { chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; unshift @INC, 'lib', '../..'; $^X = '../../../t/' . $^X; } } ## Handy to have when our output is intermingled with debugging output sent ## to the debugging fd. select STDERR; select STDOUT; use Test::More tests => 24; use IPC::Run qw( harness run binary ); sub Win32_MODE(); *Win32_MODE = \&IPC::Run::Win32_MODE; my $crlf_text = "Hello World\r\n"; my $text = $crlf_text; $text =~ s/\r//g if Win32_MODE; my $nl_text = $crlf_text; $nl_text =~ s/\r//g; my @perl = ( $^X ); my $emitter_script = q{ binmode STDOUT; print "Hello World\r\n" }; my @emitter = ( @perl, '-e', $emitter_script ); my $reporter_script = q{ binmode STDIN; $_ = join "", <>; s/([\000-\037])/sprintf "\\\\0x%02x", ord $1/ge; print }; my @reporter = ( @perl, '-e', $reporter_script ); my $in; my $out; my $err; sub f($) { my $s = shift; $s =~ s/([\000-\027])/sprintf "\\0x%02x", ord $1/ge; $s } ## Parsing tests is( eval { harness [], '>', binary, \$out } ? 1 : $@, 1 ); is( eval { harness [], '>', binary, "foo" } ? 1 : $@, 1 ); is( eval { harness [], '<', binary, \$in } ? 1 : $@, 1 ); is( eval { harness [], '<', binary, "foo" } ? 1 : $@, 1 ); ## Testing from-kid now so we can use it to test stdin later ok( run( \@emitter, ">", \$out ) ); is( f($out), f($text), "no binary" ); ok( run( \@emitter, ">", binary, \$out ) ); is( f($out), f($crlf_text), "out binary" ); ok( run( \@emitter, ">", binary( 0 ), \$out ) ); is( f($out), f($text), "out binary 0" ); ok( run( \@emitter, ">", binary( 1 ), \$out ) ); is( f($out), f($crlf_text), "out binary 1" ); ## Test to-kid ok( run( \@reporter, "<", \$nl_text, ">", \$out ) ); is( $out, "Hello World" . ( Win32_MODE ? "\\0x0d" : "" ) . "\\0x0a", "reporter < \\n" ); ok( run( \@reporter, "<", binary, \$nl_text, ">", \$out ) ); is( $out, "Hello World\\0x0a", "reporter < binary \\n" ); ok( run( \@reporter, "<", binary, \$crlf_text, ">", \$out ) ); is( $out, "Hello World\\0x0d\\0x0a", "reporter < binary \\r\\n" ); ok( run( \@reporter, "<", binary( 0 ), \$nl_text, ">", \$out ) ); is( $out, "Hello World" . ( Win32_MODE ? "\\0x0d" : "" ) . "\\0x0a", "reporter < binary(0) \\n" ); ok( run( \@reporter, "<", binary( 1 ), \$nl_text, ">", \$out ) ); is( $out, "Hello World\\0x0a", "reporter < binary(1) \\n" ); ok( run( \@reporter, "<", binary( 1 ), \$crlf_text, ">", \$out ) ); is( $out, "Hello World\\0x0d\\0x0a", "reporter < binary(1) \\r\\n" ); IPC-Run-0.92/t/bogus.t000644 000765 000024 00000001633 11355012630 014464 0ustar00toddstaff000000 000000 #!/usr/bin/perl =pod =head1 NAME bogus.t - test bogus file cases. =cut use strict; BEGIN { $| = 1; $^W = 1; if( $ENV{PERL_CORE} ) { chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; unshift @INC, 'lib', '../..'; $^X = '../../../t/' . $^X; } } use Test::More tests => 2; use IPC::Run qw( start ); SCOPE: { ## Older Test.pm's don't grok qr// in $expected. my $expected = 'file not found'; eval { start ["./bogus_really_bogus"] }; my $got = $@ =~ $expected ? $expected : $@ || ""; is( $got, $expected, "starting ./bogus_really_bogus" ); } SKIP: { if ( IPC::Run::Win32_MODE() ) { skip "Can't really exec() $^O", 1; } ## Older Test.pm's don't grok qr// in $expected. my $expected = 'exec failed'; my $h = eval { start( [$^X, "-e", 1], _simulate_exec_failure => 1 ); }; my $got = $@ =~ $expected ? $expected : $@ || ""; is( $got, $expected, "starting $^X with simulated_exec_failure => 1" ); } IPC-Run-0.92/t/filter.t000644 000765 000024 00000004000 11355012630 014621 0ustar00toddstaff000000 000000 #!/usr/bin/perl =pod =head1 NAME filter.t - Test suite for IPC::Run filter scaffolding =cut use strict; BEGIN { $| = 1; $^W = 1; if( $ENV{PERL_CORE} ) { chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; unshift @INC, 'lib', '../..'; $^X = '../../../t/' . $^X; } } use Test::More tests => 80; use t::lib::Test; use IPC::Run qw( :filters :filter_imp ); sub uc_filter { my ( $in_ref, $out_ref ) = @_; return input_avail && do { $$out_ref .= uc( $$in_ref ); $$in_ref = ''; 1; } } my $string; sub string_source { my ( $in_ref, $out_ref ) = @_; return undef unless defined $string; $$out_ref .= $string; $string = undef; return 1; } my $accum; sub accum { my ( $in_ref, $out_ref ) = @_; return input_avail && do { $accum .= $$in_ref; $$in_ref = ''; 1; }; } my $op; ## "import" the things we're testing. *_init_filters = \&IPC::Run::_init_filters; *_do_filters = \&IPC::Run::_do_filters; filter_tests( "filter_tests", "hello world", "hello world" ); filter_tests( "filter_tests []", [qq(hello world)], [qq(hello world)] ); filter_tests( "filter_tests [] 2", [qw(hello world)], [qw(hello world)] ); filter_tests( "uc_filter", "hello world", "HELLO WORLD", \&uc_filter ); filter_tests( "chunking_filter by lines 1", "hello 1\nhello 2\nhello 3", ["hello 1\n", "hello 2\n", "hello 3"], new_chunker ); filter_tests( "chunking_filter by lines 2", "hello 1\nhello 2\nhello 3", ["hello 1\n", "hello 2\n", "hello 3"], new_chunker ); filter_tests( "chunking_filter by lines 2", [split( /(\s|\n)/, "hello 1\nhello 2\nhello 3" )], ["hello 1\n", "hello 2\n", "hello 3"], new_chunker ); filter_tests( "chunking_filter by an odd separator", "hello world", "hello world", new_chunker( 'odd separator' ) ); filter_tests( "chunking_filter 2", "hello world", ['hello world' =~ m/(.)/g], new_chunker( qr/./ ) ); filter_tests( "appending_filter", [qw( 1 2 3 )], [qw( 1a 2a 3a )], new_appender("a") ); IPC-Run-0.92/t/harness.t000644 000765 000024 00000005757 11355012630 015023 0ustar00toddstaff000000 000000 #!/usr/bin/perl =pod =head1 NAME harness.t - Test suite for IPC::Run::harness =cut use strict; BEGIN { $| = 1; $^W = 1; if( $ENV{PERL_CORE} ) { chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; unshift @INC, 'lib', '../..'; $^X = '../../../t/' . $^X; } } use Test::More tests => 120; use IPC::Run qw( harness ); my $f; sub expand_test { my ( $args, $expected ) = @_; my $h; my @out; my $i = 0; SCOPE: { $h = IPC::Run::harness( @$args ); @out = @{$h->{KIDS}->[0]->{OPS}}; is( scalar( @out ), scalar( @$expected ), join( ' ', @$args ) ) } foreach my $h ( @$expected ) { my $j = $i++; foreach ( sort keys %$h ) { my ( $key, $value ) = ( $_, $h->{$_} ); my $got = $out[$j]->{$key}; $got = @$got if ref $got eq 'ARRAY'; $got = '' unless defined $got; is( $got, $value, join( ' ', @$args ) . ": $j, $key" ) } } } expand_test( [ ['a'], qw( '<', SOURCE => 'b', KFD => 0, }, { TYPE => '<', SOURCE => 'c', KFD => 0, }, { TYPE => '<', SOURCE => 'd', KFD => 0, }, { TYPE => '<', SOURCE => 'e', KFD => 0, }, { TYPE => '<', SOURCE => 'f', KFD => 1, }, { TYPE => '<', SOURCE => 'g', KFD => 1, }, ] ); expand_test( [ ['a'], qw( >b > c 2>d 2> e >>f >> g 2>>h 2>> i) ], [ { TYPE => '>', DEST => 'b', KFD => 1, TRUNC => 1, }, { TYPE => '>', DEST => 'c', KFD => 1, TRUNC => 1, }, { TYPE => '>', DEST => 'd', KFD => 2, TRUNC => 1, }, { TYPE => '>', DEST => 'e', KFD => 2, TRUNC => 1, }, { TYPE => '>', DEST => 'f', KFD => 1, TRUNC => '', }, { TYPE => '>', DEST => 'g', KFD => 1, TRUNC => '', }, { TYPE => '>', DEST => 'h', KFD => 2, TRUNC => '', }, { TYPE => '>', DEST => 'i', KFD => 2, TRUNC => '', }, ] ); expand_test( [ ['a'], qw( >&b >& c &>d &> e ) ], [ { TYPE => '>', DEST => 'b', KFD => 1, TRUNC => 1, }, { TYPE => 'dup', KFD1 => 1, KFD2 => 2 }, { TYPE => '>', DEST => 'c', KFD => 1, TRUNC => 1, }, { TYPE => 'dup', KFD1 => 1, KFD2 => 2 }, { TYPE => '>', DEST => 'd', KFD => 1, TRUNC => 1, }, { TYPE => 'dup', KFD1 => 1, KFD2 => 2 }, { TYPE => '>', DEST => 'e', KFD => 1, TRUNC => 1, }, { TYPE => 'dup', KFD1 => 1, KFD2 => 2 }, ] ); expand_test( [ ['a'], '>&', sub{}, sub{}, \$f, '>', sub{}, sub{}, \$f, '<', sub{}, sub{}, \$f, ], [ { TYPE => '>', DEST => \$f, KFD => 1, TRUNC => 1, FILTERS => 2 }, { TYPE => 'dup', KFD1 => 1, KFD2 => 2 }, { TYPE => '>', DEST => \$f, KFD => 1, TRUNC => 1, FILTERS => 2 }, { TYPE => '<', SOURCE => \$f, KFD => 0, FILTERS => 3 }, ] ); expand_test( [ ['a'], '<', \$f, '>', \$f ], [ { TYPE => '<', SOURCE => \$f, KFD => 0, }, { TYPE => '>', DEST => \$f, KFD => 1, }, ] ); expand_test( [ ['a'], 'pipe', \$f ], [ { TYPE => ' \$f, KFD => 0, }, { TYPE => '>pipe', DEST => \$f, KFD => 1, }, ] ); expand_test( [ ['a'], '', \$f ], [ { TYPE => ' \$f, KFD => 0, }, { TYPE => '>', DEST => \$f, KFD => 1, }, ] ); IPC-Run-0.92/t/io.t000644 000765 000024 00000004041 11355012630 013750 0ustar00toddstaff000000 000000 #!/usr/bin/perl =pod =head1 NAME io.t - Test suite excercising IPC::Run::IO with IPC::Run::run. =cut use strict; BEGIN { $| = 1; $^W = 1; if( $ENV{PERL_CORE} ) { chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; unshift @INC, 'lib', '../..'; $^X = '../../../t/' . $^X; } } use Test::More tests => 14; use IPC::Run qw( :filters run io ); use IPC::Run::Debug qw( _map_fds ); my $text = "Hello World\n"; my $emitter_script = qq{print '$text'; print STDERR uc( '$text' )}; ## ## $^X is the path to the perl binary. This is used run all the subprocesses. ## my @perl = ( $^X ); my @emitter = ( @perl, '-e', $emitter_script ); my $recv; my $send; my $in_file = 'io.t.in'; my $out_file = 'io.t.out'; my $err_file = 'io.t.err'; my $io; my $r; my $fd_map; ## TODO: Test filters, etc. sub slurp($) { my ( $f ) = @_; open( S, "<$f" ) or return "$! '$f'"; my $r = join( '', ); close S or warn "$! closing '$f'"; return $r; } sub spit($$) { my ( $f, $s ) = @_; open( S, ">$f" ) or die "$! '$f'"; print S $s or die "$! '$f'"; close S or die "$! '$f'"; } sub wipe($) { my ( $f ) = @_; unlink $f or warn "$! unlinking '$f'" if -f $f; } $io = io( 'foo', '<', \$send ); ok $io->isa('IPC::Run::IO'); is( io( 'foo', '<', \$send )->mode, 'w' ); is( io( 'foo', '<<', \$send )->mode, 'wa' ); is( io( 'foo', '>', \$recv )->mode, 'r' ); is( io( 'foo', '>>', \$recv )->mode, 'ra' ); SKIP: { if ( IPC::Run::Win32_MODE() ) { skip( "$^O does not allow select() on non-sockets", 9 ); } ## ## Input from a file ## SCOPE: { spit $in_file, $text; $recv = 'REPLACE ME'; $fd_map = _map_fds; $r = run io( $in_file, '>', \$recv ); wipe $in_file; ok( $r ); } ok( ! $? ); is( _map_fds, $fd_map ); is( $recv, $text ); ## ## Output to a file ## SCOPE: { wipe $out_file; $send = $text; $fd_map = _map_fds; $r = run io( $out_file, '<', \$send ); $recv = slurp $out_file; wipe $out_file; ok( $r ); } ok( ! $? ); is( _map_fds, $fd_map ); is( $send, $text ); is( $recv, $text ); } IPC-Run-0.92/t/kill_kill.t000644 000765 000024 00000002007 11355012630 015307 0ustar00toddstaff000000 000000 #!/usr/bin/perl =pod =head1 NAME kill_kill.t - Test suite for IPC::Run->kill_kill =cut BEGIN { $| = 1; $^W = 1; if( $ENV{PERL_CORE} ) { chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; unshift @INC, 'lib', '../..'; $^X = '../../../t/' . $^X; } } use strict; use Test::More; use IPC::Run (); # Don't run this test script on Windows at all if ( IPC::Run::Win32_MODE() ) { plan( skip_all => 'Temporarily ignoring test failure on Win32' ); exit(0); } else { plan( tests => 2 ); } # Test 1 SCOPE: { my $h = IPC::Run::start( [ $^X, '-e', 'sleep while 1', ] ); my $needed = $h->kill_kill; ok( ! $needed, 'Did not need kill_kill' ); } # Test 2 SKIP: { if ( IPC::Run::Win32_MODE() ) { skip("$^O does not support ignoring the TERM signal", 1); } my $out; my $h = IPC::Run::start( [ $^X, '-e', '$SIG{TERM}=sub{};$|=1;print "running\n";sleep while 1', ], \undef, \$out ); pump $h until $out =~ /running/; my $needed = $h->kill_kill( grace => 1 ); ok( $needed, 'Did not need kill_kill' ); } IPC-Run-0.92/t/lib/000750 000765 000024 00000000000 12017702723 013723 5ustar00toddstaff000000 000000 IPC-Run-0.92/t/parallel.t000644 000765 000024 00000001720 11572061415 015144 0ustar00toddstaff000000 000000 #!/usr/bin/perl =pod =head1 NAME parallel.t - Test suite for running multiple processes in parallel. =cut use strict; BEGIN { $| = 1; $^W = 1; if( $ENV{PERL_CORE} ) { chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; unshift @INC, 'lib', '../..'; $^X = '../../../t/' . $^X; } } ## Handy to have when our output is intermingled with debugging output sent ## to the debugging fd. select STDERR; select STDOUT; BEGIN { use Test::More; if($^O eq 'MSWin32') { plan skip_all => 'Parallel tests are dangerous on MSWin32'; } else { plan tests => 6; } } use IPC::Run qw( start pump finish ); my $text1 = "Hello world 1\n"; my $text2 = "Hello world 2\n"; my @perl = ( $^X ); my @catter = ( @perl, '-pe1' ); my ( $h1, $h2 ); my ( $out1, $out2 ); $h1 = start \@catter, "<", \$text1, ">", \$out1; ok( $h1 ); $h2 = start \@catter, "<", \$text2, ">", \$out2; ok( $h2 ); pump $h1; ok( 1 ); pump $h2; ok( 1 ); finish $h1; ok( 1 ); finish $h2; ok( 1 ); IPC-Run-0.92/t/pty.t000644 000765 000024 00000011615 11704750444 014174 0ustar00toddstaff000000 000000 #!/usr/bin/perl =pod =head1 NAME pty.t - Test suite for IPC::Run's pty (psuedo-terminal) support =head1 DESCRIPTION This test suite starts off with a test that seems to cause a deadlock on freebsd: \@cmd, '', ..., '2>'... This seems to cause the child process entry in the process table to hang around after the child exits. Both output pipes are closed, but the PID is still valid so IPC::Run::finish() thinks it's still alive and the whole shebang deadlocks waiting for the child to exit. This is a very rare corner condition, so I'm not patching in a fix yet. One fix might be to hack IPC::Run to close the master pty when all outputs from the child are closed. That's a hack, not sure what to do about it. This problem needs to be reproduced in a standalone script and investigated further, but I have not the time. =cut use strict; BEGIN { $| = 1; $^W = 1; if( $ENV{PERL_CORE} ) { chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; unshift @INC, 'lib', '../..'; $^X = '../../../t/' . $^X; } } use Test::More; BEGIN { if ( eval { require IO::Pty; } ) { plan tests => 32; } else { plan skip_all => "IO::Pty not installed"; } } use IPC::Run::Debug qw( _map_fds ); use IPC::Run qw( start pump finish ); select STDERR; select STDOUT; sub pty_warn { warn "\nWARNING: $_[0].\nWARNING: 'pty>' $_[1] not work.\n\n"; } if ( $^O !~ /Win32/ ) { # my $min = 0.9; for ( eval { require IO::Pty; IO::Pty->VERSION } ) { s/_//g if defined; if ( ! defined ) { pty_warn "IO::Pty not found", "will"; } elsif ( $_ == 0.02 ) { pty_warn "IO::Pty v$_ has spurious warnings, try 0.9 or later", "may" } elsif ( $_ < 1.00 ) { pty_warn "IO::Pty 1.00 is strongly recommended", "may"; } } } diag( "IO::Tty $IO::Tty::VERSION, IO::Pty $IO::Pty::VERSION" ); my $echoer_script = <) { print STDERR uc \$_; print; last if /quit/; } TOHERE ## ## $^X is the path to the perl binary. This is used run all the subprocesses. ## my @echoer = ( $^X, '-e', $echoer_script ); my $in; my $out; my $err; my $h; my $r; my $fd_map; my $text = "hello world\n"; ## TODO: test lots of mixtures of pty's and pipes & files. Use run(). ## Older Perls can't ok( a, qr// ), so I manually do that here. my $exp; my $platform_skip = $^O =~ /(?:dragonfly|aix|freebsd|openbsd|darwin)/ ? "$^O deadlocks on this test" : ""; ## ## stdin only ## SKIP: { if ( $platform_skip ) { skip( $platform_skip, 9 ); } $out = 'REPLACE ME'; $? = 99; $fd_map = _map_fds; $h = start \@echoer, '', \$out, '2>', \$err; $in = "hello\n"; $? = 0; pump $h until $out =~ /hello/ && $err =~ /HELLO/; is( $out, "hello\n" ); $exp = qr/^HELLO\n(?!\n)$/; $err =~ $exp ? ok( 1 ) : is( $err, $exp ); is( $in, '' ); $in = "world\n"; $? = 0; pump $h until $out =~ /world/ && $err =~ /WORLD/; is( $out, "hello\nworld\n" ); $exp = qr/^HELLO\nWORLD\n(?!\n)$/; $err =~ $exp ? ok( 1 ) : is( $err, $exp ); is( $in, '' ); $in = "quit\n"; ok( $h->finish ); ok( ! $? ); is( _map_fds, $fd_map ); } ## ## stdout, stderr ## $out = 'REPLACE ME'; $? = 99; $fd_map = _map_fds; $h = start \@echoer, \$in, '>pty>', \$out; $in = "hello\n"; $? = 0; pump $h until $out =~ /hello/; ## We assume that the slave's write()s are atomic $exp = qr/^(?:hello\r?\n){2}(?!\n)$/i; $out =~ $exp ? ok( 1 ) : is( $out, $exp ); is( $in, '' ); $in = "world\n"; $? = 0; pump $h until $out =~ /world/; $exp = qr/^(?:hello\r?\n){2}(?:world\r?\n){2}(?!\n)$/i; $out =~ $exp ? ok( 1 ) : is( $out, $exp ); is( $in, '' ); $in = "quit\n"; ok( $h->finish ); ok( ! $? ); is( _map_fds, $fd_map ); ## ## stdout only ## $out = 'REPLACE ME'; $? = 99; $fd_map = _map_fds; $h = start \@echoer, \$in, '>pty>', \$out, '2>', \$err; $in = "hello\n"; $? = 0; pump $h until $out =~ /hello/ && $err =~ /HELLO/; $exp = qr/^hello\r?\n(?!\n)$/; $out =~ $exp ? ok( 1 ) : is( $out, $exp ); $exp = qr/^HELLO\n(?!\n)$/; $err =~ $exp ? ok( 1 ) : is( $err, $exp ); is( $in, '' ); $in = "world\n"; $? = 0; pump $h until $out =~ /world/ && $err =~ /WORLD/; $exp = qr/^hello\r?\nworld\r?\n(?!\n)$/; $out =~ $exp ? ok( 1 ) : is( $out, $exp ); $exp = qr/^HELLO\nWORLD\n(?!\n)$/ , $err =~ $exp ? ok( 1 ) : is( $err, $exp ); is( $in, '' ); $in = "quit\n"; ok( $h->finish ); ok( ! $? ); is( _map_fds, $fd_map ); ## ## stdin, stdout, stderr ## $out = 'REPLACE ME'; $? = 99; $fd_map = _map_fds; $h = start \@echoer, 'pty>', \$out; $in = "hello\n"; $? = 0; pump $h until $out =~ /hello.*hello.*hello/is; ## We assume that the slave's write()s are atomic $exp = qr/^(?:hello\r?\n){3}(?!\n)$/i; $out =~ $exp ? ok( 1 ) : is( $out, $exp ); is( $in, '' ); $in = "world\n"; $? = 0; pump $h until $out =~ /world.*world.*world/is; $exp = qr/^(?:hello\r?\n){3}(?:world\r?\n){3}(?!\n)$/i; $out =~ $exp ? ok( 1 ) : is( $out, $exp ); is( $in, '' ); $in = "quit\n"; ok( $h->finish ); ok( ! $? ); is( _map_fds, $fd_map ); IPC-Run-0.92/t/pump.t000644 000765 000024 00000002721 11355012630 014325 0ustar00toddstaff000000 000000 #!/usr/bin/perl =pod =head1 NAME pump.t - Test suite for IPC::Run::run, etc. =cut use strict; BEGIN { $| = 1; $^W = 1; if( $ENV{PERL_CORE} ) { chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; unshift @INC, 'lib', '../..'; $^X = '../../../t/' . $^X; } } use Test::More tests => 27; use IPC::Run::Debug qw( _map_fds ); use IPC::Run qw( start pump finish timeout ); ## ## $^X is the path to the perl binary. This is used run all the subprocesses. ## my @echoer = ( $^X, '-pe', 'BEGIN { $| = 1 }' ); my $in; my $out; my $h; my $fd_map; $in = 'SHOULD BE UNCHANGED'; $out = 'REPLACE ME'; $? = 99; $fd_map = _map_fds; $h = start( \@echoer, \$in, \$out, timeout 5 ); ok( $h->isa('IPC::Run') ); is( $?, 99 ); is( $in, 'SHOULD BE UNCHANGED' ); is( $out, '' ); ok( $h->pumpable ); $in = ''; $? = 0; pump_nb $h for ( 1..100 ); ok( 1 ); is( $in, '' ); is( $out, '' ); ok( $h->pumpable ); $in = "hello\n"; $? = 0; pump $h until $out =~ /hello/; ok( 1 ); ok( ! $? ); is( $in, '' ); is( $out, "hello\n" ); ok( $h->pumpable ); $in = "world\n"; $? = 0; pump $h until $out =~ /world/; ok( 1 ); ok( ! $? ); is( $in, '' ); is( $out, "hello\nworld\n" ); ok( $h->pumpable ); ## Test \G pos() restoral $in = "hello\n"; $out = ""; $? = 0; pump $h until $out =~ /hello\n/g; ok( 1 ); is pos( $out ), 6, "pos\$out"; $in = "world\n"; $? = 0; pump $h until $out =~ /\Gworld/gc; ok( 1 ); ok( $h->finish ); ok( ! $? ); is( _map_fds, $fd_map ); is( $out, "hello\nworld\n" ); ok( ! $h->pumpable ); IPC-Run-0.92/t/run.t000644 000765 000024 00000050334 11373127354 014165 0ustar00toddstaff000000 000000 #!/usr/bin/perl =pod =head1 NAME run.t - Test suite for IPC::Run::run, etc. =cut use strict; BEGIN { $| = 1; $^W = 1; if( $ENV{PERL_CORE} ) { chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; unshift @INC, 'lib', '../..'; $^X = '../../../t/' . $^X; } } my @WARNING_MESSAGES; $SIG{__WARN__} = sub{ push @WARNING_MESSAGES, @_; diag("WARN: $_") foreach(@_); }; sub get_warnings { my @warnings = @WARNING_MESSAGES; @WARNING_MESSAGES = (); return @warnings } ## Handy to have when our output is intermingled with debugging output sent ## to the debugging fd. select STDERR; select STDOUT; use Test::More tests => 268; use IPC::Run::Debug qw( _map_fds ); use IPC::Run qw( :filters :filter_imp start ); use t::lib::Test; # Must do this this late as plan uses localtime, and localtime on darwin opens # a file descriptor. Quite probably other operating systems do file descriptor # things during the test setup. my $fd_map = _map_fds; sub run { IPC::Run::run( ref $_[0] ? ( noinherit => 1 ) : (), @_ ); } ## Test at least some of the win32 PATHEXT logic my $perl = $^X; $perl =~ s/\.\w+\z// if IPC::Run::Win32_MODE(); sub _unlink { my ( $f ) = @_; my $tries; while () { return if unlink $f; if ( $^O =~ /Win32/ && ++$tries <= 10 ) { print STDOUT "# Waiting for Win32 to allow $f to be unlinked ($!)\n"; select undef, undef, undef, 0.1; next; } die "$! unlinking $f at ", join( ", line ", (caller)[1,2] ), "\n"; } } my $text = "Hello World\n"; my @perl = ( $perl ); my $emitter_script = qq{print '$text'; print STDERR uc( '$text' ) unless \@ARGV }; my @emitter = ( @perl, '-e', $emitter_script ); my $in; my $out; my $err; my $in_file = 'run.t.in'; my $out_file = 'run.t.out'; my $err_file = 'run.t.err'; my $h; sub slurp($) { my ( $f ) = @_; open( S, "<$f" ) or return "$! $f"; my $r = join( '', ); close S or warn "$!: $f"; select 0.1 if $^O =~ /Win32/; return $r; } sub spit($$) { my ( $f, $s ) = @_; open( S, ">$f" ) or die "$! $f"; print S $s or die "$! $f"; close S or die "$! $f"; } ## ## A grossly inefficient filter to test filter ## chains. It's inefficient because we want to make sure that the ## filter chain flushing logic works. The inefficiency is that it ## doesn't process as much input as it could each call, so lots of calls ## are required. ## sub alt_casing_filter { my ( $in_ref, $out_ref ) = @_; return input_avail && do { $$out_ref .= lc( substr( $$in_ref, 0, 1, '' ) ); 1; } && ( ! input_avail || do { $$out_ref .= uc( substr( $$in_ref, 0, 1, '' ) ); 1; } ); } sub case_inverting_filter { my ( $in_ref, $out_ref ) = @_; return input_avail && do { $$in_ref =~ tr/a-zA-Z/A-Za-z/; $$out_ref .= $$in_ref; $$in_ref = ''; 1; }; } sub eok { my ( $got, $exp, $name ) = @_; $got =~ s/([\000-\037])/sprintf "\\0x%02x", ord $1/ge if defined $exp; $exp =~ s/([\000-\037])/sprintf "\\0x%02x", ord $1/ge if defined $exp; my($pack, $file, $line) = caller(); $name ||= qq[eok at $file line $line]; local $Test::Builder::Level = $Test::Builder::Level + 1; return is( $got, $exp, $name ); } my $r; is( _map_fds, $fd_map ); $fd_map = _map_fds; ## ## Internal testing ## filter_tests( "alt_casing_filter", "Hello World", ["hElLo wOrLd" =~ m/(..?)/g], \&alt_casing_filter ), is( _map_fds, $fd_map ); $fd_map = _map_fds; filter_tests( "case_inverting_filter", "Hello World", "hELLO wORLD", \&case_inverting_filter ), is( _map_fds, $fd_map ); $fd_map = _map_fds; ## ## Calling the local system shell ## ok( run qq{$perl -e exit} ); is( $?, 0 ); is( _map_fds, $fd_map ); $fd_map = _map_fds; SKIP: { if ( IPC::Run::Win32_MODE() ) { skip( "$^O's shell returns 0 even if last command doesn't", 3 ); } ok( ! run(qq{$perl -e 'exit(42)'}) ); ok( $? ); is( $? >> 8, 42 ); } is( _map_fds, $fd_map ); $fd_map = _map_fds; ## ## Simple commands, not executed via shell ## ok( run $perl, qw{-e exit} ); is( $?, 0 ); is( _map_fds, $fd_map ); $fd_map = _map_fds; ok( ! run $perl, qw{-e exit(42)} ); ok( $? ); is $? >> 8, 42; is( _map_fds, $fd_map ); $fd_map = _map_fds; ## ## A function ## SKIP: { if ( IPC::Run::Win32_MODE() ) { skip( "Can't spawn subroutines on $^O", 5 ); } ok run sub{} ; is $?, 0 ; ok !run sub{ exit 42 }; ok $? ; is $? >> 8, 42 ; } is( _map_fds, $fd_map ); $fd_map = _map_fds; ## ## A function, and an init function ## SKIP: { if ( IPC::Run::Win32_MODE() ) { skip( "Can't spawn subroutines on $^O", 2 ); } my $e = 0; ok( ! run( sub{ exit($e) }, init => sub { $e = 42 } ) ); ok( $? ); } is( _map_fds, $fd_map ); $fd_map = _map_fds; ## ## scalar ref I & O redirection using op tokens ## $out = 'REPLACE ME'; $fd_map = _map_fds; $r = run [ @emitter, "nostderr" ], '>', \$out; ok( $r ); ok( ! $? ); is( _map_fds, $fd_map ); eok( $out, $text ); $out = 'REPLACE ME'; $fd_map = _map_fds; $r = run [ @emitter, "nostderr" ], '<', \undef, '>', \$out; ok( $r ); ok( ! $? ); is( _map_fds, $fd_map ); eok( $out, $text ); $in = $emitter_script; $out = 'REPLACE ME'; $err = 'REPLACE ME'; $fd_map = _map_fds; $r = run \@perl, '<', \$in, '>', \$out, '2>', \$err,; ok( $r ); ok( ! $? ); is( _map_fds, $fd_map ); eok( $in, $emitter_script ); eok( $out, $text ); eok( $err, uc( $text ) ); ## ## scalar ref I & O redirection, succinct mode. ## $in = $emitter_script; $out = 'REPLACE ME'; $err = 'REPLACE ME'; $fd_map = _map_fds; $r = run \@perl, \$in, \$out, \$err; ok( $r ); ok( ! $? ); is( _map_fds, $fd_map ); eok( $in, $emitter_script ); eok( $out, $text ); eok( $err, uc( $text ) ); ## ## Long output, to test for blocking read. ## ## Assume pipe buffer length <= 10000, need to double that to assure enough ## chars to fill a buffer so. This test adapted from a test submitted by ## Borislav Deianov . $in = "-" x 20000 . "end\n"; $out = 'REPLACE ME'; $fd_map = _map_fds; $r = run [ $perl, qw{-e print"-"x20000;;} ], \$in, \$out; ok( $r ); ok( ! $? ); is( _map_fds, $fd_map ); is( length $out, 20000 ); unlike( $out, qr/[^-]/ ); ## ## Long output run through twice ## ## Adapted from a stress test by Aaron Elkiss ## $h = start [$perl, qw( -pe BEGIN{$|=1}1 )], \$in, \$out; $in = "\n"; $out = ""; pump $h until length $out; is $out, "\n"; my $long_string = "x" x 20000 . "DOC2\n"; $in = $long_string; $out = ""; my $ok_1 = eval { pump $h until $out =~ /DOC2/; 1; }; my $x = $@; my $ok_2 = eval { finish $h; 1; }; $x = $@ if $ok_1 && ! $ok_2; if ( $ok_1 && $ok_2 ) { is $long_string, $out; } else { $x =~ s/(x+)/sprintf "...%d \"x\" chars...", length $1/e; is $x, ""; } ## ## child function, scalar ref I & O redirection, succinct mode. ## SKIP: { if ( IPC::Run::Win32_MODE() ) { skip( "Can't spawn subroutines on $^O", 6 ); } $in = $text; $out = 'REPLACE ME'; $err = 'REPLACE ME'; $fd_map = _map_fds; $r = run( sub { while (<>) { print; print STDERR uc( $_ ) } }, \$in, \$out, \$err ); ok( $r ); ok ! $?; is( _map_fds, $fd_map ); eok( $in, $text ); eok( $out, $text ); eok( $err, uc( $text ) ); } ## ## here document as input ## $out = 'REPLACE ME'; $err = 'REPLACE ME'; $fd_map = _map_fds; $r = run \@perl, \<', \$out, '2>', \$err; ## Assume this won't block... print IN $emitter_script; close IN or warn $!; $r = $h->finish; ok( $r ); ok( ! $? ); is( _map_fds, $fd_map ); eok( $out, $text ); eok( $err, uc( $text ) ); ## ## filehandle input redirection, passed via *F{IO} ## $out = 'REPLACE ME'; $err = 'REPLACE ME'; $fd_map = _map_fds; spit( $in_file, $emitter_script ); open( F, "<$in_file" ) or die "$! $in_file"; $r = run \@perl, *F{IO}, \$out, \$err; close F; _unlink $in_file; ok( $r ); ok( ! $? ); is( _map_fds, $fd_map ); eok( $out, $text ); eok( $err, uc( $text ) ); ## ## filehandle output redirection ## $fd_map = _map_fds; open( OUT, ">$out_file" ) or die "$! $out_file"; open( ERR, ">$err_file" ) or die "$! $err_file"; print OUT "out: "; print ERR uc( "err: " ); $r = run \@emitter, \undef, \*OUT, \*ERR; print OUT " more out data"; print ERR uc( " more err data" ); close OUT; close ERR; $out = slurp( $out_file ); $err = slurp( $err_file ); _unlink $out_file; _unlink $err_file; ok( $r ); ok( ! $? ); is( _map_fds, $fd_map ); eok( $out, "out: $text more out data" ); eok( $err, uc( "err: $text more err data" ) ); ## ## filehandle output redirection via a pipe that is returned to the caller ## $fd_map = _map_fds; $r = run \@emitter, \undef, '>pipe', \*OUT, '2>pipe', \*ERR; $out = ''; $err = ''; read OUT, $out, 10000 or warn $!; read ERR, $err, 10000 or warn $!; close OUT or warn $!; close ERR or warn $!; ok( $r ); ok( ! $? ); is( _map_fds, $fd_map ); eok( $out, $text ); eok( $err, uc( $text ) ); ## ## sub I & O redirection ## $in = $emitter_script; $out = undef; $err = undef; $fd_map = _map_fds; $r = run( \@perl, '<', sub { my $f = $in; $in = undef; return $f }, '>', sub { $out .= shift }, '2>', sub { $err .= shift }, ); ok( $r ); ok( ! $? ); is( _map_fds, $fd_map ); eok( $out, $text ); eok( $err, uc( $text ) ); ## ## input redirection from a file ## $out = undef; $err = undef; $fd_map = _map_fds; spit( $in_file, $emitter_script ); $r = run( \@perl, "<$in_file", '>', sub { $out .= shift }, '2>', sub { $err .= shift }, ); _unlink $in_file; ok( $r ); ok( ! $? ); is( _map_fds, $fd_map ); eok( $out, $text ); eok( $err, uc( $text ) ); ## ## reading input from a non standard fd ## SKIP: { if ( IPC::Run::Win32_MODE() ) { skip( "$^O does not allow redirection of file descriptors > 2", 11 ); } $out = undef; $err = undef; $fd_map = _map_fds; $r = run( ## FreeBSD doesn't guarantee that fd 3 or 4 are available, so ## don't assume, go for 5. [ @perl, '-le', 'open( STDIN, "<&5" ) or die $!; print ' ], "5<", \"Hello World", '>', \$out, '2>', \$err, ); ok( $r ); ok( ! $? ); is( _map_fds, $fd_map ); eok( $out, $text ); eok( $err, '' ); ## ## duping input descriptors and an input descriptor > 0 ## $in = $emitter_script; $out = 'REPLACE ME'; $err = 'REPLACE ME'; $fd_map = _map_fds; $r = run( \@perl, '>', \$out, '2>', \$err, '3<', \$in, '0<&3', ); ok( $r ); ok( ! $? ); is( _map_fds, $fd_map ); eok( $in, $emitter_script ); eok( $out, $text ); eok( $err, uc( $text ) ); } ## ## closing input descriptors ## $out = 'REPLACE ME'; $err = 'REPLACE ME'; $fd_map = _map_fds; spit( $in_file, $emitter_script ); $r = run( [ @perl, '-e', '$l = readline *STDIN or die $!; print $l' ], '>', \$out, '2>', \$err, '<', $in_file, '0<&-', ); _unlink $in_file; ok( ! $r ); ok( $? ); is( _map_fds, $fd_map ); eok( $out, '' ); #ok( $err =~ /file descriptor/i ? "Bad file descriptor error" : $err, "Bad file descriptor error" ); # XXX This should be use Errno; if $!{EBADF}. --rs is( length $err ? "Bad file descriptor error" : $err, "Bad file descriptor error" ); ## ## input redirection from a non-existent file ## $out = 'REPLACE ME'; $err = 'REPLACE ME'; $fd_map = _map_fds; my $bad_file = "$in_file.nonexistant"; _unlink $bad_file if -e $bad_file; eval { $r = run \@perl, ">$out_file", "<$bad_file"; }; like $@, qr/\Q$bad_file\E/; is( _map_fds, $fd_map ); ## ## output redirection to a file w/ creation or truncation ## $fd_map = _map_fds; _unlink $out_file if -x $out_file; _unlink $err_file if -x $err_file; $r = run( \@emitter, ">$out_file", "2>$err_file", ); $out = slurp( $out_file ); $err = slurp( $err_file ); ok( $r ); ok( ! $? ); is( _map_fds, $fd_map ); eok( $out, $text ); eok( $err, uc( $text ) ); ## ## output file redirection, w/ truncation ## $fd_map = _map_fds; spit( $out_file, 'out: ' ); spit( $err_file, 'ERR: ' ); $r = run( \@emitter, ">$out_file", "2>$err_file", ); $out = slurp( $out_file ); _unlink $out_file; $err = slurp( $err_file ); _unlink $err_file; ok( $r ); ok( ! $? ); is( _map_fds, $fd_map ); eok( $out, $text ); eok( $err, uc( $text ) ); ## ## output file redirection w/ append ## spit( $out_file, 'out: ' ); spit( $err_file, 'ERR: ' ); $fd_map = _map_fds; $r = run( \@emitter, ">>$out_file", "2>>$err_file", ); $out = slurp( $out_file ); _unlink $out_file; $err = slurp( $err_file ); _unlink $err_file; ok( $r ); ok( ! $? ); is( _map_fds, $fd_map ); eok( $out, "out: $text" ); eok( $err, uc( "err: $text" ) ); ## ## dup()ing output descriptors ## $out = 'REPLACE ME'; $err = 'REPLACE ME'; $fd_map = _map_fds; $r = run \@emitter, '>', \$out, '2>', \$err, '2>&1'; ok( $r ); ok( ! $? ); is( _map_fds, $fd_map ); like $out, qr/(?:$text){2}/i; eok( $err, '' ); ## ## stderr & stdout redirection to the same file via >&word ## $fd_map = _map_fds; _unlink $out_file if -x $out_file; $r = run \@emitter, ">&$out_file"; $out = slurp( $out_file ); ok( $r ); ok( ! $? ); is( _map_fds, $fd_map ); like $out, qr/(?:$text){2}/i; ## ## Non-zero exit value, command with args, no redirects. ## $fd_map = _map_fds; $r = run [ @perl, '-e', 'exit(42)' ]; ok( !$r ); is( $?, 42 << 8 ); is( _map_fds, $fd_map ); ## ## Zero exit value, command with args, no redirects. ## $fd_map = _map_fds; $r = run [ @perl, qw{ -e exit }]; ok( $r ); ok( ! $? ); is( _map_fds, $fd_map ); ## ## dup()ing output descriptors that collide. ## ## This test assumes that our caller doesn't leave a lot of fds opened, ## and assumes that $out_file will be opened on fd 3, 4 or 5. ## SKIP: { if ( IPC::Run::Win32_MODE() ) { skip( "$^O does not allow redirection of file descriptors > 2", 5 ); } $out = 'REPLACE ME'; $err = 'REPLACE ME'; _unlink $out_file if -x $out_file; $fd_map = _map_fds; $r = run( \@emitter, "<", \"", "3>&1", "4>&1", "5>&1", ">$out_file", '2>', \$err, ); $out = slurp( $out_file ); _unlink $out_file; ok( $r ); ok( ! $? ); is( _map_fds, $fd_map ); eok( $out, $text ); eok( $err, uc( $text ) ); } ## ## Pipelining ## $out = 'REPLACE ME'; $err = 'REPLACE ME'; $fd_map = _map_fds; $r = run( [ @perl, '-lane', 'print STDERR "1:$_"; print uc($F[0])," ",$F[1]'], \"Hello World", '|',[ @perl, '-lane', 'print STDERR "2:$_"; print $F[0]," ",lc($F[1])'], \$out, \$err, ); ok( $r ); ok( ! $? ); is( _map_fds, $fd_map ); eok( $out, "HELLO world\n" ); eok( $err, "1:Hello World\n2:HELLO World\n" ); ## ## Parallel (unpiplined) processes ## $out = 'REPLACE ME'; $err = 'REPLACE ME'; $fd_map = _map_fds; $r = run( [ @perl, '-lane', 'print STDERR "1:$_"; print uc($F[0])," ",$F[1]' ], \"Hello World", '&', [ @perl, '-lane', 'print STDERR "2:$_"; print $F[0]," ",lc( $F[1] )' ], \"Hello World", \$out, \$err, ); ok( $r ); ok( ! $? ); is( _map_fds, $fd_map ); like $out, qr/^(?:HELLO World\n|Hello world\n){2}$/s; like $err, qr/^(?:[12]:Hello World.*){2}$/s; ## ## A few error cases... ## eval { $r = run \@perl, '<', [], [] }; like( $@, qr/not allowed/ ); eval { $r = run \@perl, '>', [], [] }; like( $@, qr/not allowed/ ); foreach my $foo ( qw( | & < > >& 1>&2 >file ', \$out, '2>', \$err, _simulate_fork_failure => 1 ); }; ok( $@ ); ok( ! $? ); is( _map_fds, $fd_map ); eok( $out, '' ); eok( $err, '' ); $fd_map = _map_fds; eval { $r = run \@perl, ' 1; }; ok( $@ ); ok( ! $? ); is( _map_fds, $fd_map ); $fd_map = _map_fds; eval { $r = run \@perl, '>file', _simulate_open_failure => 1; }; ok( $@ ); ok( ! $? ); is( _map_fds, $fd_map ); ## ## harness, pump, run ## $in = 'SHOULD BE UNCHANGED'; $out = 'REPLACE ME'; $err = 'REPLACE ME'; $? = 99; $fd_map = _map_fds; $h = start( [ @perl, '-pe', 'BEGIN { $| = 1 } print STDERR uc($_)' ], \$in, \$out, \$err, ); isa_ok( $h, 'IPC::Run' ); is( $?, 99 ); eok( $in, 'SHOULD BE UNCHANGED' ); eok( $out, '' ); eok( $err, '' ); ok( $h->pumpable ); $in = ''; $? = 0; pump_nb $h for ( 1..100 ); pass( "after pump_nb" ); eok( $in, '' ); eok( $out, '' ); eok( $err, '' ); ok( $h->pumpable ); $in = $text; $? = 0; pump $h until $out =~ /Hello World/; pass("after pump"); ok( ! $? ); eok( $in, '' ); eok( $out, $text ); ok( $h->pumpable ); ok( $h->finish ); ok( ! $? ); is( _map_fds, $fd_map ); eok( $out, $text ); eok( $err, uc( $text ) ); ok( ! $h->pumpable ); ## ## start, run, run, run. See Tom run. A do-run-run, a-do-run-run. ## $in = 'SHOULD BE UNCHANGED'; $out = 'REPLACE ME'; $err = 'REPLACE ME'; $fd_map = _map_fds; $h = start( [ @perl, '-pe', 'binmode STDOUT; binmode STDERR; BEGIN { $| = 1 } print STDERR uc($_)' ], \$in, \$out, \$err, ); ok( $h->isa('IPC::Run') ); eok( $in, 'SHOULD BE UNCHANGED' ); eok( $out, '' ); eok( $err, '' ); ok( $h->pumpable ); $in = $text; ok( $h->finish ); ok( ! $? ); is( _map_fds, $fd_map ); eok( $in, '' ); eok( $out, $text ); eok( $err, uc( $text ) ); ok( ! $h->pumpable ); $in = $text; $out = 'REPLACE ME'; $err = 'REPLACE ME'; ok( $h->run ); ok( ! $? ); is( _map_fds, $fd_map ); eok( $in, $text ); eok( $out, $text ); eok( $err, uc( $text ) ); ok( ! $h->pumpable ); $in = $text; $out = 'REPLACE ME'; $err = 'REPLACE ME'; ok( $h->run ); ok( ! $? ); is( _map_fds, $fd_map ); eok( $in, $text ); eok( $out, $text ); eok( $err, uc( $text ) ); ok( ! $h->pumpable ); ## ## Output filters ## $out = 'REPLACE ME'; $err = 'REPLACE ME'; $fd_map = _map_fds; $r = run( \@emitter, '>', \&alt_casing_filter, \&case_inverting_filter, \$out, '2>', \$err, ); ok( $r ); ok( ! $? ); is( _map_fds, $fd_map ); eok( $out, "HeLlO WoRlD\n" ); eok( $err, uc( $text ) ); ## ## Input filters ## $out = 'REPLACE ME'; $err = 'REPLACE ME'; $fd_map = _map_fds; $in = $text; $r = run( [ @perl, '-pe', 'binmode STDOUT; binmode STDERR; print STDERR uc $_' ], '0<', \&case_inverting_filter, \&alt_casing_filter, \$in, '1>', \$out, '2>', \$err, ); ok( $r ); ok( ! $? ); is( _map_fds, $fd_map ); eok( $in, $text ); eok( $out, "HeLlO WoRlD\n" ); eok( $err, uc( $text ) ); { # no warnings for an empty path but it does die. # Some other OSes might not support find. Windows and UNIX do... my @simple_command = ('bogusprogram'); local $ENV{PATH}; delete $ENV{PATH}; eval {$h = start \@simple_command, \$in, \$out;}; ok($@, "Error running bogus program when path is empty"); my ($message) = get_warnings(); is($message, undef, "No warnings found during program call with empty path"); finish $h; # Close out the program call } IPC-Run-0.92/t/signal.t000644 000765 000024 00000002003 11355012630 014612 0ustar00toddstaff000000 000000 #!/usr/bin/perl =pod =head1 NAME signal.t - Test suite IPC::Run->signal =cut use strict; BEGIN { $| = 1; $^W = 1; if( $ENV{PERL_CORE} ) { chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; unshift @INC, 'lib', '../..'; $^X = '../../../t/' . $^X; } } use Test::More; use IPC::Run qw( :filters :filter_imp start run ); use t::lib::Test; BEGIN { if ( IPC::Run::Win32_MODE() ) { plan skip_all => 'Skipping on Win32'; } else { plan tests => 3; } } my @receiver = ( $^X, '-e', <<'END_RECEIVER', my $which = " "; sub s{ $which = $_[0] }; $SIG{$_}=\&s for (qw(USR1 USR2)); $| = 1; print "Ok\n"; for (1..10) { sleep 1; print $which, "\n" } END_RECEIVER ); my $h; my $out; $h = start \@receiver, \undef, \$out; pump $h until $out =~ /Ok/; ok 1; $out = ""; $h->signal( "USR2" ); pump $h; $h->signal( "USR1" ); pump $h; $h->signal( "USR2" ); pump $h; $h->signal( "USR1" ); pump $h; ok $out, "USR2\nUSR1\nUSR2\nUSR1\n"; $h->signal( "TERM" ); finish $h; ok( 1 ); IPC-Run-0.92/t/timeout.t000644 000765 000024 00000004017 11704750444 015044 0ustar00toddstaff000000 000000 #!/usr/bin/perl =pod =head1 NAME timeout.t - Test suite for IPC::Run timeouts =cut use strict; BEGIN { $| = 1; $^W = 1; if( $ENV{PERL_CORE} ) { chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; unshift @INC, 'lib', '../..'; $^X = '../../../t/' . $^X; } } ## Separate from run.t so run.t is not too slow. use Test::More tests => 26; use IPC::Run qw( harness timeout ); my $h; my $t; my $in; my $out; my $started; $h = harness( [ $^X ], \$in, \$out, $t = timeout( 1 ) ); ok( $h->isa('IPC::Run') ); ok( !! $t->is_reset ); ok( ! $t->is_running ); ok( ! $t->is_expired ); $started = time; $h->start; ok( 1 ); ok( ! $t->is_reset ); ok( !! $t->is_running ); ok( ! $t->is_expired ); $in = ''; eval { $h->pump }; # Older perls' Test.pms don't know what to do with qr//s $@ =~ /IPC::Run: timeout/ ? ok( 1 ) : is( $@, qr/IPC::Run: timeout/ ); SCOPE: { my $elapsed = time - $started; $elapsed >= 1 ? ok( 1 ) : is( $elapsed, ">= 1" ); is( $t->interval, 1 ); ok( ! $t->is_reset ); ok( ! $t->is_running ); ok( !! $t->is_expired ); ## ## Starting from an expired state ## $started = time; $h->start; ok( 1 ); ok( ! $t->is_reset ); ok( !! $t->is_running ); ok( ! $t->is_expired ); $in = ''; eval { $h->pump }; $@ =~ /IPC::Run: timeout/ ? ok( 1 ) : is( $@, qr/IPC::Run: timeout/ ); ok( ! $t->is_reset ); ok( ! $t->is_running ); ok( !! $t->is_expired ); } SCOPE: { my $elapsed = time - $started; $elapsed >= 1 ? ok( 1 ) : is( $elapsed, ">= 1" ); $h = harness( [ $^X ], \$in, \$out, timeout( 1 ) ); $started = time; $h->start; $in = ''; eval { $h->pump }; $@ =~ /IPC::Run: timeout/ ? ok( 1 ) : is( $@, qr/IPC::Run: timeout/ ); } SCOPE: { my $elapsed = time - $started; $elapsed >= 1 ? ok( 1 ) : is( $elapsed, ">= 1" ); } { $h = harness( [ $^X, '-e', 'sleep 1' ], timeout( 10 ), debug => 0); my $started_at = time; $h->start; $h->finish; my $finished_at = time; ok( $finished_at-$started_at <= 2, 'not too slow to reap' ) or diag($finished_at-$started_at . " seconds passed"); } IPC-Run-0.92/t/timer.t000644 000765 000024 00000005570 11355012630 014471 0ustar00toddstaff000000 000000 #!/usr/bin/perl =pod =head1 NAME timer.t - Test suite for IPC::Run::Timer =cut use strict; BEGIN { $| = 1; $^W = 1; if( $ENV{PERL_CORE} ) { chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; unshift @INC, 'lib', '../..'; $^X = '../../../t/' . $^X; } } use Test::More tests => 72; use IPC::Run qw( run ); use IPC::Run::Timer qw( :all ); my $t; my $started; $t = timer( # debug => 1, 1, ); is( ref $t, 'IPC::Run::Timer' ); is( $t->interval, 1 ); $t->interval( 0 ); is( $t->interval, 0 ); $t->interval( 0.1 ); ok( $t->interval > 0 ); $t->interval( 1 ); ok( $t->interval >= 1 ); $t->interval( 30 ); ok( $t->interval >= 30 ); $t->interval( 30.1 ); ok( $t->interval > 30 ); $t->interval( 30.1 ); ok( $t->interval <= 31 ); $t->interval( "1:0" ); is( $t->interval, 60 ); $t->interval( "1:0:0" ); is( $t->interval, 3600 ); $t->interval( "1:1:1" ); is( $t->interval, 3661 ); $t->interval( "1:1:1.1" ); ok( $t->interval > 3661 ); $t->interval( "1:1:1.1" ); ok( $t->interval <= 3662 ); $t->interval( "1:1:1:1" ); is( $t->interval, 90061 ); $t->reset; $t->interval( 5 ); $t->start( 1, 0 ); ok( ! $t->is_expired ); ok( !! $t->is_running ); ok( ! $t->is_reset ); ok( !! $t->check( 0 ) ); ok( ! $t->is_expired ); ok( !! $t->is_running ); ok( ! $t->is_reset ); ok( !! $t->check( 1 ) ); ok( ! $t->is_expired ); ok( !! $t->is_running ); ok( ! $t->is_reset ); ok( ! $t->check( 2 ) ); ok( !! $t->is_expired ); ok( ! $t->is_running ); ok( ! $t->is_reset ); ok( ! $t->check( 3 ) ); ok( !! $t->is_expired ); ok( ! $t->is_running ); ok( ! $t->is_reset ); ## Restarting from the expired state. $t->start( undef, 0 ); ok( ! $t->is_expired ); ok( !! $t->is_running ); ok( ! $t->is_reset ); ok( !! $t->check( 0 ) ); ok( ! $t->is_expired ); ok( !! $t->is_running ); ok( ! $t->is_reset ); ok( !! $t->check( 1 ) ); ok( ! $t->is_expired ); ok( !! $t->is_running ); ok( ! $t->is_reset ); ok( ! $t->check( 2 ) ); ok( !! $t->is_expired ); ok( ! $t->is_running ); ok( ! $t->is_reset ); ok( ! $t->check( 3 ) ); ok( !! $t->is_expired ); ok( ! $t->is_running ); ok( ! $t->is_reset ); ## Restarting while running $t->start( 1, 0 ); $t->start( undef, 0 ); ok( ! $t->is_expired ); ok( !! $t->is_running ); ok( ! $t->is_reset ); ok( !! $t->check( 0 ) ); ok( ! $t->is_expired ); ok( !! $t->is_running ); ok( ! $t->is_reset ); ok( !! $t->check( 1 ) ); ok( ! $t->is_expired ); ok( !! $t->is_running ); ok( ! $t->is_reset ); ok( ! $t->check( 2 ) ); ok( !! $t->is_expired ); ok( ! $t->is_running ); ok( ! $t->is_reset ); ok( ! $t->check( 3 ) ); ok( !! $t->is_expired ); ok( ! $t->is_running ); ok( ! $t->is_reset ); my $got; eval { $got = "timeout fired"; run [$^X, '-e', 'sleep 3'], timeout 1; $got = "timeout didn't fire"; }; is $got, "timeout fired", "timer firing in run()"; IPC-Run-0.92/t/win32_compile.t000644 000765 000024 00000003046 11355012630 016017 0ustar00toddstaff000000 000000 #!/usr/bin/perl =pod =head1 NAME win32_compile.t - See if IPC::Run::Win32Helper compiles, even on Unix =cut use strict; BEGIN { $| = 1; $^W = 1; if( $ENV{PERL_CORE} ) { chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; unshift @INC, 'lib', '../..'; $^X = '../../../t/' . $^X; } } use Test::More; BEGIN { unless ( eval "require 5.006" ) { ## NOTE: I'm working around this here because I don't want this ## test to fail on non-Win32 systems with older Perls. Makefile.PL ## does the require 5.6.0 to protect folks on Windows. plan( skip_all => "perl5.00503's Socket.pm does not export IPPROTO_TCP" ); } $INC{$_} = 1 for qw( Win32/Process.pm Win32API/File.pm ); package Win32API::File; use vars qw( @ISA @EXPORT ); @ISA = qw( Exporter ); @EXPORT = qw( GetOsFHandle OsFHandleOpen OsFHandleOpenFd FdGetOsFHandle SetHandleInformation SetFilePointer HANDLE_FLAG_INHERIT INVALID_HANDLE_VALUE createFile WriteFile ReadFile CloseHandle FILE_ATTRIBUTE_TEMPORARY FILE_FLAG_DELETE_ON_CLOSE FILE_FLAG_WRITE_THROUGH FILE_BEGIN ); eval "sub $_ { 1 }" for @EXPORT; use Exporter; package Win32::Process; use vars qw( @ISA @EXPORT ); @ISA = qw( Exporter ); @EXPORT = qw( NORMAL_PRIORITY_CLASS ); eval "sub $_ {}" for @EXPORT; use Exporter; } sub Socket::IPPROTO_TCP() { undef } package main; use IPC::Run::Win32Helper; use IPC::Run::Win32IO; plan( tests => 1 ); ok( 1 ); IPC-Run-0.92/t/windows_search_path.t000644 000765 000024 00000001644 11355012630 017402 0ustar00toddstaff000000 000000 #!perl -w use strict; use warnings; use Test::More tests => 11; use IPC::Run; { no warnings; sub IPC::Run::Win32_MODE {1} } is(IPC::Run::Win32_MODE, 1, "We're win32 mode?"); $^O = 'Win32'; # Proves that files in subdirs with . still work. mkdir '5.11.5'; my @tests = qw( ./temp ./temp.EXE .\\temp .\\temp.EXE ./5.11.5/temp ./5.11.5/temp.EXE ./5.11.5/temp ./5.11.5/temp.BAT ./5.11.5/temp ./5.11.5/temp.COM ); while(@tests) { my $path = shift @tests; my $result = shift @tests; touch($result); my $got = eval { IPC::Run::_search_path($path) }; is($@, '', "No error calling _search_path for '$path'"); is($got, $result, "Executable $result found"); unlink $result; } exit; sub touch { my $file = shift; open(FH, ">$file") or die; print FH 1 or die; close FH or die; chmod(0700, $file) or die; } sub END { rmdir('5.11.5'); }IPC-Run-0.92/t/lib/Test.pm000644 000765 000024 00000006355 11355012630 015211 0ustar00toddstaff000000 000000 package t::lib::Test; use strict; use Test::More; use Exporter; use IPC::Run qw{ harness }; use IPC::Run::IO; use vars qw{@ISA @EXPORT}; BEGIN { @ISA = qw{ Exporter }; @EXPORT = qw{ filter_tests }; } ## This is not needed by most users. Should really move to IPC::Run::TestUtils #=item filter_tests # # my @tests = filter_tests( "foo", "in", "out", \&filter ); # $_->() for ( @tests ); # #This creates a list of test subs that can be used to test most filters #for basic functionality. The first parameter is the name of the #filter to be tested, the second is sample input, the third is the #test(s) to apply to the output(s), and the rest of the parameters are #the filters to be linked and tested. # #If the filter chain is to be fed multiple inputs in sequence, the second #parameter should be a reference to an array of thos inputs: # # my @tests = filter_tests( "foo", [qw(1 2 3)], "123", \&filter ); # #If the filter chain should produce a sequence of outputs, then the #thrid parameter should be a reference to an array of those outputs: # # my @tests = filter_tests( # "foo", # "1\n\2\n", # [ qr/^1$/, qr/^2$/ ], # new_chunker # ); # #See t/run.t and t/filter.t for an example of this in practice. # #=cut ## ## Filter testing routines ## sub filter_tests($;@) { my ( $name, $in, $exp, @filters ) = @_; my @in = ref $in eq 'ARRAY' ? @$in : ( $in ); my @exp = ref $exp eq 'ARRAY' ? @$exp : ( $exp ); my IPC::Run::IO $op; my $output; my @input; my $in_count = 0; my @out; my $h; SCOPE: { $h = harness(); $op = IPC::Run::IO->_new_internal( '<', 0, 0, 0, undef, IPC::Run::new_string_sink( \$output ), @filters, IPC::Run::new_string_source( \@input ), ); $op->_init_filters; @input = (); $output = ''; is( ! defined $op->_do_filters( $h ), 1, "$name didn't pass undef (EOF) through" ); }; ## See if correctly does nothing on 0, (please try again) SCOPE: { $op->_init_filters; $output = ''; @input = ( '' ); is( $op->_do_filters( $h ), 0, "$name didn't return 0 (please try again) when given a 0" ); }; SCOPE: { @input = ( '' ); is( $op->_do_filters( $h ), 0, "$name didn't return 0 (please try again) when given a second 0" ); }; SCOPE: { for (1..100) { last unless defined $op->_do_filters( $h ); } is( ! defined $op->_do_filters( $h ), 1, "$name didn't return undef (EOF) after two 0s and an undef" ); }; ## See if it can take @in and make @out SCOPE: { $op->_init_filters; $output = ''; @input = @in; while ( defined $op->_do_filters( $h ) && @input ) { if ( length $output ) { push @out, $output; $output = ''; } } if ( length $output ) { push @out, $output; $output = ''; } is( scalar @input, 0, "$name didn't consume it's input" ); }; SCOPE: { for (1..100) { last unless defined $op->_do_filters( $h ); if ( length $output ) { push @out, $output; $output = ''; } } is( ! defined $op->_do_filters( $h ), 1, "$name didn't return undef (EOF), tried 100 times" ); }; SCOPE: { is( join( ', ', map "'$_'", @out ), join( ', ', map "'$_'", @exp ), $name ) }; SCOPE: { ## Force the harness to be cleaned up. $h = undef; ok( 1 ); }; } 1; IPC-Run-0.92/lib/IPC/000750 000765 000024 00000000000 12017702723 014073 5ustar00toddstaff000000 000000 IPC-Run-0.92/lib/IPC/Run/000750 000765 000024 00000000000 12017702723 014637 5ustar00toddstaff000000 000000 IPC-Run-0.92/lib/IPC/Run.pm000644 000765 000024 00000415240 12017702506 015207 0ustar00toddstaff000000 000000 package IPC::Run; use bytes; =pod =head1 NAME IPC::Run - system() and background procs w/ piping, redirs, ptys (Unix, Win32) =head1 SYNOPSIS ## First,a command to run: my @cat = qw( cat ); ## Using run() instead of system(): use IPC::Run qw( run timeout ); run \@cmd, \$in, \$out, \$err, timeout( 10 ) or die "cat: $?" # Can do I/O to sub refs and filenames, too: run \@cmd, '<', "in.txt", \&out, \&err or die "cat: $?" run \@cat, '<', "in.txt", '>>', "out.txt", '2>>', "err.txt"; # Redirecting using psuedo-terminals instad of pipes. run \@cat, 'pty>', \$out_and_err; ## Scripting subprocesses (like Expect): use IPC::Run qw( start pump finish timeout ); # Incrementally read from / write to scalars. # $in is drained as it is fed to cat's stdin, # $out accumulates cat's stdout # $err accumulates cat's stderr # $h is for "harness". my $h = start \@cat, \$in, \$out, \$err, timeout( 10 ); $in .= "some input\n"; pump $h until $out =~ /input\n/g; $in .= "some more input\n"; pump $h until $out =~ /\G.*more input\n/; $in .= "some final input\n"; finish $h or die "cat returned $?"; warn $err if $err; print $out; ## All of cat's output # Piping between children run \@cat, '|', \@gzip; # Multiple children simultaneously (run() blocks until all # children exit, use start() for background execution): run \@foo1, '&', \@foo2; # Calling \&set_up_child in the child before it executes the # command (only works on systems with true fork() & exec()) # exceptions thrown in set_up_child() will be propagated back # to the parent and thrown from run(). run \@cat, \$in, \$out, init => \&set_up_child; # Read from / write to file handles you open and close open IN, 'out.txt' or die $!; print OUT "preamble\n"; run \@cat, \*IN, \*OUT or die "cat returned $?"; print OUT "postamble\n"; close IN; close OUT; # Create pipes for you to read / write (like IPC::Open2 & 3). $h = start \@cat, 'pipe', \*OUT, '2>pipe', \*ERR or die "cat returned $?"; print IN "some input\n"; close IN; print , ; finish $h; # Mixing input and output modes run \@cat, 'in.txt', \&catch_some_out, \*ERR_LOG ); # Other redirection constructs run \@cat, '>&', \$out_and_err; run \@cat, '2>&1'; run \@cat, '0<&3'; run \@cat, '<&-'; run \@cat, '3<', \$in3; run \@cat, '4>', \$out4; # etc. # Passing options: run \@cat, 'in.txt', debug => 1; # Call this system's shell, returns TRUE on 0 exit code # THIS IS THE OPPOSITE SENSE OF system()'s RETURN VALUE run "cat a b c" or die "cat returned $?"; # Launch a sub process directly, no shell. Can't do redirection # with this form, it's here to behave like system() with an # inverted result. $r = run "cat a b c"; # Read from a file in to a scalar run io( "filename", 'r', \$recv ); run io( \*HANDLE, 'r', \$recv ); =head1 DESCRIPTION IPC::Run allows you to run and interact with child processes using files, pipes, and pseudo-ttys. Both system()-style and scripted usages are supported and may be mixed. Likewise, functional and OO API styles are both supported and may be mixed. Various redirection operators reminiscent of those seen on common Unix and DOS command lines are provided. Before digging in to the details a few LIMITATIONS are important enough to be mentioned right up front: =over =item Win32 Support Win32 support is working but B, but does pass all relevant tests on NT 4.0. See L. =item pty Support If you need pty support, IPC::Run should work well enough most of the time, but IO::Pty is being improved, and IPC::Run will be improved to use IO::Pty's new features when it is release. The basic problem is that the pty needs to initialize itself before the parent writes to the master pty, or the data written gets lost. So IPC::Run does a sleep(1) in the parent after forking to (hopefully) give the child a chance to run. This is a kludge that works well on non heavily loaded systems :(. ptys are not supported yet under Win32, but will be emulated... =item Debugging Tip You may use the environment variable C to see what's going on under the hood: $ IPCRUNDEBUG=basic myscript # prints minimal debugging $ IPCRUNDEBUG=data myscript # prints all data reads/writes $ IPCRUNDEBUG=details myscript # prints lots of low-level details $ IPCRUNDEBUG=gory myscript # (Win32 only) prints data moving through # the helper processes. =back We now return you to your regularly scheduled documentation. =head2 Harnesses Child processes and I/O handles are gathered in to a harness, then started and run until the processing is finished or aborted. =head2 run() vs. start(); pump(); finish(); There are two modes you can run harnesses in: run() functions as an enhanced system(), and start()/pump()/finish() allow for background processes and scripted interactions with them. When using run(), all data to be sent to the harness is set up in advance (though one can feed subprocesses input from subroutine refs to get around this limitation). The harness is run and all output is collected from it, then any child processes are waited for: run \@cmd, \< and C<$err> in our examples. Regular expressions can be used to wait for appropriate output in several ways. The C example in the previous section demonstrates how to pump() until some string appears in the output. Here's an example that uses C to fetch files from a remote server: $h = harness \@smbclient, \$in, \$out; $in = "cd /src\n"; $h->pump until $out =~ /^smb.*> \Z/m; die "error cding to /src:\n$out" if $out =~ "ERR"; $out = ''; $in = "mget *\n"; $h->pump until $out =~ /^smb.*> \Z/m; die "error retrieving files:\n$out" if $out =~ "ERR"; $in = "quit\n"; $h->finish; Notice that we carefully clear $out after the first command/response cycle? That's because IPC::Run does not delete $out when we continue, and we don't want to trip over the old output in the second command/response cycle. Say you want to accumulate all the output in $out and analyze it afterwards. Perl offers incremental regular expression matching using the C and pattern matching idiom and the C<\G> assertion. IPC::Run is careful not to disturb the current C value for scalars it appends data to, so we could modify the above so as not to destroy $out by adding a couple of C modifiers. The C keeps us from tripping over the previous prompt and the C keeps us from resetting the prior match position if the expected prompt doesn't materialize immediately: $h = harness \@smbclient, \$in, \$out; $in = "cd /src\n"; $h->pump until $out =~ /^smb.*> \Z/mgc; die "error cding to /src:\n$out" if $out =~ "ERR"; $in = "mget *\n"; $h->pump until $out =~ /^smb.*> \Z/mgc; die "error retrieving files:\n$out" if $out =~ "ERR"; $in = "quit\n"; $h->finish; analyze( $out ); When using this technique, you may want to preallocate $out to have plenty of memory or you may find that the act of growing $out each time new input arrives causes an C slowdown as $out grows. Say we expect no more than 10,000 characters of input at the most. To preallocate memory to $out, do something like: my $out = "x" x 10_000; $out = ""; C will allocate at least 10,000 characters' worth of space, then mark the $out as having 0 length without freeing all that yummy RAM. =head2 Timeouts and Timers More than likely, you don't want your subprocesses to run forever, and sometimes it's nice to know that they're going a little slowly. Timeouts throw exceptions after a some time has elapsed, timers merely cause pump() to return after some time has elapsed. Neither is reset/restarted automatically. Timeout objects are created by calling timeout( $interval ) and passing the result to run(), start() or harness(). The timeout period starts ticking just after all the child processes have been fork()ed or spawn()ed, and are polled for expiration in run(), pump() and finish(). If/when they expire, an exception is thrown. This is typically useful to keep a subprocess from taking too long. If a timeout occurs in run(), all child processes will be terminated and all file/pipe/ptty descriptors opened by run() will be closed. File descriptors opened by the parent process and passed in to run() are not closed in this event. If a timeout occurs in pump(), pump_nb(), or finish(), it's up to you to decide whether to kill_kill() all the children or to implement some more graceful fallback. No I/O will be closed in pump(), pump_nb() or finish() by such an exception (though I/O is often closed down in those routines during the natural course of events). Often an exception is too harsh. timer( $interval ) creates timer objects that merely prevent pump() from blocking forever. This can be useful for detecting stalled I/O or printing a soothing message or "." to pacify an anxious user. Timeouts and timers can both be restarted at any time using the timer's start() method (this is not the start() that launches subprocesses). To restart a timer, you need to keep a reference to the timer: ## Start with a nice long timeout to let smbclient connect. If ## pump or finish take too long, an exception will be thrown. my $h; eval { $h = harness \@smbclient, \$in, \$out, \$err, ( my $t = timeout 30 ); sleep 11; # No effect: timer not running yet start $h; $in = "cd /src\n"; pump $h until ! length $in; $in = "ls\n"; ## Now use a short timeout, since this should be faster $t->start( 5 ); pump $h until ! length $in; $t->start( 10 ); ## Give smbclient a little while to shut down. $h->finish; }; if ( $@ ) { my $x = $@; ## Preserve $@ in case another exception occurs $h->kill_kill; ## kill it gently, then brutally if need be, or just ## brutally on Win32. die $x; } Timeouts and timers are I checked once the subprocesses are shut down; they will not expire in the interval between the last valid process and when IPC::Run scoops up the processes' result codes, for instance. =head2 Spawning synchronization, child exception propagation start() pauses the parent until the child executes the command or CODE reference and propagates any exceptions thrown (including exec() failure) back to the parent. This has several pleasant effects: any exceptions thrown in the child, including exec() failure, come flying out of start() or run() as though they had ocurred in the parent. This includes exceptions your code thrown from init subs. In this example: eval { run \@cmd, init => sub { die "blast it! foiled again!" }; }; print $@; the exception "blast it! foiled again" will be thrown from the child process (preventing the exec()) and printed by the parent. In situations like run \@cmd1, "|", \@cmd2, "|", \@cmd3; @cmd1 will be initted and exec()ed before @cmd2, and @cmd2 before @cmd3. This can save time and prevent oddball errors emitted by later commands when earlier commands fail to execute. Note that IPC::Run doesn't start any commands unless it can find the executables referenced by all commands. These executables must pass both the C<-f> and C<-x> tests described in L. Another nice effect is that init() subs can take their time doing things and there will be no problems caused by a parent continuing to execute before a child's init() routine is complete. Say the init() routine needs to open a socket or a temp file that the parent wants to connect to; without this synchronization, the parent will need to implement a retry loop to wait for the child to run, since often, the parent gets a lot of things done before the child's first timeslice is allocated. This is also quite necessary for pseudo-tty initialization, which needs to take place before the parent writes to the child via pty. Writes that occur before the pty is set up can get lost. A final, minor, nicety is that debugging output from the child will be emitted before the parent continues on, making for much clearer debugging output in complex situations. The only drawback I can conceive of is that the parent can't continue to operate while the child is being initted. If this ever becomes a problem in the field, we can implement an option to avoid this behavior, but I don't expect it to. B: executing CODE references isn't supported on Win32, see L for details. =head2 Syntax run(), start(), and harness() can all take a harness specification as input. A harness specification is either a single string to be passed to the systems' shell: run "echo 'hi there'"; or a list of commands, io operations, and/or timers/timeouts to execute. Consecutive commands must be separated by a pipe operator '|' or an '&'. External commands are passed in as array references, and, on systems supporting fork(), Perl code may be passed in as subs: run \@cmd; run \@cmd1, '|', \@cmd2; run \@cmd1, '&', \@cmd2; run \&sub1; run \&sub1, '|', \&sub2; run \&sub1, '&', \&sub2; '|' pipes the stdout of \@cmd1 the stdin of \@cmd2, just like a shell pipe. '&' does not. Child processes to the right of a '&' will have their stdin closed unless it's redirected-to. L objects may be passed in as well, whether or not child processes are also specified: run io( "infile", ">", \$in ), io( "outfile", "<", \$in ); as can L objects: run \@cmd, io( "outfile", "<", \$in ), timeout( 10 ); Commands may be followed by scalar, sub, or i/o handle references for redirecting child process input & output: run \@cmd, \undef, \$out; run \@cmd, \$in, \$out; run \@cmd1, \&in, '|', \@cmd2, \*OUT; run \@cmd1, \*IN, '|', \@cmd2, \&out; This is known as succinct redirection syntax, since run(), start() and harness(), figure out which file descriptor to redirect and how. File descriptor 0 is presumed to be an input for the child process, all others are outputs. The assumed file descriptor always starts at 0, unless the command is being piped to, in which case it starts at 1. To be explicit about your redirects, or if you need to do more complex things, there's also a redirection operator syntax: run \@cmd, '<', \undef, '>', \$out; run \@cmd, '<', \undef, '>&', \$out_and_err; run( \@cmd1, '<', \$in, '|', \@cmd2, \$out ); Operator syntax is required if you need to do something other than simple redirection to/from scalars or subs, like duping or closing file descriptors or redirecting to/from a named file. The operators are covered in detail below. After each \@cmd (or \&foo), parsing begins in succinct mode and toggles to operator syntax mode when an operator (ie plain scalar, not a ref) is seen. Once in operator syntax mode, parsing only reverts to succinct mode when a '|' or '&' is seen. In succinct mode, each parameter after the \@cmd specifies what to do with the next highest file descriptor. These File descriptor start with 0 (stdin) unless stdin is being piped to (C<'|', \@cmd>), in which case they start with 1 (stdout). Currently, being on the left of a pipe (C<\@cmd, \$out, \$err, '|'>) does I cause stdout to be skipped, though this may change since it's not as DWIMerly as it could be. Only stdin is assumed to be an input in succinct mode, all others are assumed to be outputs. If no piping or redirection is specified for a child, it will inherit the parent's open file handles as dictated by your system's close-on-exec behavior and the $^F flag, except that processes after a '&' will not inherit the parent's stdin. Also note that $^F does not affect file desciptors obtained via POSIX, since it only applies to full-fledged Perl file handles. Such processes will have their stdin closed unless it has been redirected-to. If you want to close a child processes stdin, you may do any of: run \@cmd, \undef; run \@cmd, \""; run \@cmd, '<&-'; run \@cmd, '0<&-'; Redirection is done by placing redirection specifications immediately after a command or child subroutine: run \@cmd1, \$in, '|', \@cmd2, \$out; run \@cmd1, '<', \$in, '|', \@cmd2, '>', \$out; If you omit the redirection operators, descriptors are counted starting at 0. Descriptor 0 is assumed to be input, all others are outputs. A leading '|' consumes descriptor 0, so this works as expected. run \@cmd1, \$in, '|', \@cmd2, \$out; The parameter following a redirection operator can be a scalar ref, a subroutine ref, a file name, an open filehandle, or a closed filehandle. If it's a scalar ref, the child reads input from or sends output to that variable: $in = "Hello World.\n"; run \@cat, \$in, \$out; print $out; Scalars used in incremental (start()/pump()/finish()) applications are treated as queues: input is removed from input scalers, resulting in them dwindling to '', and output is appended to output scalars. This is not true of harnesses run() in batch mode. It's usually wise to append new input to be sent to the child to the input queue, and you'll often want to zap output queues to '' before pumping. $h = start \@cat, \$in; $in = "line 1\n"; pump $h; $in .= "line 2\n"; pump $h; $in .= "line 3\n"; finish $h; The final call to finish() must be there: it allows the child process(es) to run to completion and waits for their exit values. =head1 OBSTINATE CHILDREN Interactive applications are usually optimized for human use. This can help or hinder trying to interact with them through modules like IPC::Run. Frequently, programs alter their behavior when they detect that stdin, stdout, or stderr are not connected to a tty, assuming that they are being run in batch mode. Whether this helps or hurts depends on which optimizations change. And there's often no way of telling what a program does in these areas other than trial and error and, occasionally, reading the source. This includes different versions and implementations of the same program. All hope is not lost, however. Most programs behave in reasonably tractable manners, once you figure out what it's trying to do. Here are some of the issues you might need to be aware of. =over =item * fflush()ing stdout and stderr This lets the user see stdout and stderr immediately. Many programs undo this optimization if stdout is not a tty, making them harder to manage by things like IPC::Run. Many programs decline to fflush stdout or stderr if they do not detect a tty there. Some ftp commands do this, for instance. If this happens to you, look for a way to force interactive behavior, like a command line switch or command. If you can't, you will need to use a pseudo terminal ('pty>'). =item * false prompts Interactive programs generally do not guarantee that output from user commands won't contain a prompt string. For example, your shell prompt might be a '$', and a file named '$' might be the only file in a directory listing. This can make it hard to guarantee that your output parser won't be fooled into early termination of results. To help work around this, you can see if the program can alter it's prompt, and use something you feel is never going to occur in actual practice. You should also look for your prompt to be the only thing on a line: pump $h until $out =~ /^\s?\z/m; (use C<(?!\n)\Z> in place of C<\z> on older perls). You can also take the approach that IPC::ChildSafe takes and emit a command with known output after each 'real' command you issue, then look for this known output. See new_appender() and new_chunker() for filters that can help with this task. If it's not convenient or possibly to alter a prompt or use a known command/response pair, you might need to autodetect the prompt in case the local version of the child program is different then the one you tested with, or if the user has control over the look & feel of the prompt. =item * Refusing to accept input unless stdin is a tty. Some programs, for security reasons, will only accept certain types of input from a tty. su, notable, will not prompt for a password unless it's connected to a tty. If this is your situation, use a pseudo terminal ('pty>'). =item * Not prompting unless connected to a tty. Some programs don't prompt unless stdin or stdout is a tty. See if you can turn prompting back on. If not, see if you can come up with a command that you can issue after every real command and look for it's output, as IPC::ChildSafe does. There are two filters included with IPC::Run that can help with doing this: appender and chunker (see new_appender() and new_chunker()). =item * Different output format when not connected to a tty. Some commands alter their formats to ease machine parsability when they aren't connected to a pipe. This is actually good, but can be surprising. =back =head1 PSEUDO TERMINALS On systems providing pseudo terminals under /dev, IPC::Run can use IO::Pty (available on CPAN) to provide a terminal environment to subprocesses. This is necessary when the subprocess really wants to think it's connected to a real terminal. =head2 CAVEATS Psuedo-terminals are not pipes, though they are similar. Here are some differences to watch out for. =over =item Echoing Sending to stdin will cause an echo on stdout, which occurs before each line is passed to the child program. There is currently no way to disable this, although the child process can and should disable it for things like passwords. =item Shutdown IPC::Run cannot close a pty until all output has been collected. This means that it is not possible to send an EOF to stdin by half-closing the pty, as we can when using a pipe to stdin. This means that you need to send the child process an exit command or signal, or run() / finish() will time out. Be careful not to expect a prompt after sending the exit command. =item Command line editing Some subprocesses, notable shells that depend on the user's prompt settings, will reissue the prompt plus the command line input so far once for each character. =item '>pty>' means '&>pty>', not '1>pty>' The pseudo terminal redirects both stdout and stderr unless you specify a file descriptor. If you want to grab stderr separately, do this: start \@cmd, 'pty>', \$out, '2>', \$err; =item stdin, stdout, and stderr not inherited Child processes harnessed to a pseudo terminal have their stdin, stdout, and stderr completely closed before any redirection operators take effect. This casts of the bonds of the controlling terminal. This is not done when using pipes. Right now, this affects all children in a harness that has a pty in use, even if that pty would not affect a particular child. That's a bug and will be fixed. Until it is, it's best not to mix-and-match children. =back =head2 Redirection Operators Operator SHNP Description ======== ==== =========== <, N< SHN Redirects input to a child's fd N (0 assumed) >, N> SHN Redirects output from a child's fd N (1 assumed) >>, N>> SHN Like '>', but appends to scalars or named files >&, &> SHN Redirects stdout & stderr from a child process pty, N>pty S Like '>', but uses a pseudo-tty instead of a pipe N<&M Dups input fd N to input fd M M>&N Dups output fd N to input fd M N<&- Closes fd N pipe, N>pipe P Pipe opens H for caller to read, write, close. 'N' and 'M' are placeholders for integer file descriptor numbers. The terms 'input' and 'output' are from the child process's perspective. The SHNP field indicates what parameters an operator can take: S: \$scalar or \&function references. Filters may be used with these operators (and only these). H: \*HANDLE or IO::Handle for caller to open, and close N: "file name". P: \*HANDLE opened by IPC::Run as the parent end of a pipe, but read and written to and closed by the caller (like IPC::Open3). =over =item Redirecting input: [n]<, [n] below for more information. The : The handle returned is actually a socket handle, so you can use select() on it. =item Redirecting output: [n]>, [n]>>, [n]>&[m], [n]>pipe You can redirect any output the child emits to a scalar variable, subroutine, file handle, or file name. You can have &run truncate or append to named files or scalars. If you are redirecting stdin as well, or if the command is on the receiving end of a pipeline ('|'), you can omit the redirection operator: @ls = ( 'ls' ); run \@ls, \undef, \$out or die "ls returned $?"; run \@ls, \undef, \&out; ## Calls &out each time some output ## is received from the child's ## when undef is returned. run \@ls, \undef, '2>ls.err'; run \@ls, '2>', 'ls.err'; The two parameter form guarantees that the filename will not be interpreted as a redirection operator: run \@ls, '>', "&more"; run \@ls, '2>', ">foo\n"; You can pass file handles you've opened for writing: open( *OUT, ">out.txt" ); open( *ERR, ">err.txt" ); run \@cat, \*OUT, \*ERR; Passing a scalar reference and a code reference requires a little more work, but allows you to capture all of the output in a scalar or each piece of output by a callback: These two do the same things: run( [ 'ls' ], '2>', sub { $err_out .= $_[0] } ); does the same basic thing as: run( [ 'ls' ], '2>', \$err_out ); The subroutine will be called each time some data is read from the child. The >pipe operator is different in concept than the other '>' operators, although it's syntax is similar: $h = start \@cat, $in, '>pipe', \*OUT, '2>pipe', \*ERR; $in = "hello world\n"; finish $h; print ; print ; close OUT; close ERR; causes two pipe to be created, with one end attached to cat's stdout and stderr, respectively, and the other left open on OUT and ERR, so that the script can manually read(), select(), etc. on them. This is like the behavior of IPC::Open2 and IPC::Open3. B: The handle returned is actually a socket handle, so you can use select() on it. =item Duplicating output descriptors: >&m, n>&m This duplicates output descriptor number n (default is 1 if n is omitted) from descriptor number m. =item Duplicating input descriptors: <&m, n<&m This duplicates input descriptor number n (default is 0 if n is omitted) from descriptor number m =item Closing descriptors: <&-, 3<&- This closes descriptor number n (default is 0 if n is omitted). The following commands are equivalent: run \@cmd, \undef; run \@cmd, '<&-'; run \@cmd, ', >&, &>pipe, >pipe& The following pairs of commands are equivalent: run \@cmd, '>&', \$out; run \@cmd, '>', \$out, '2>&1'; run \@cmd, '>&', 'out.txt'; run \@cmd, '>', 'out.txt', '2>&1'; etc. File descriptor numbers are not permitted to the left or the right of these operators, and the '&' may occur on either end of the operator. The '&>pipe' and '>pipe&' variants behave like the '>pipe' operator, except that both stdout and stderr write to the created pipe. =item Redirection Filters Both input redirections and output redirections that use scalars or subs as endpoints may have an arbitrary number of filter subs placed between them and the child process. This is useful if you want to receive output in chunks, or if you want to massage each chunk of data sent to the child. To use this feature, you must use operator syntax: run( \@cmd '<', \&in_filter_2, \&in_filter_1, $in, '>', \&out_filter_1, \&in_filter_2, $out, ); This capability is not provided for IO handles or named files. Two filters are provided by IPC::Run: appender and chunker. Because these may take an argument, you need to use the constructor functions new_appender() and new_chunker() rather than using \& syntax: run( \@cmd '<', new_appender( "\n" ), $in, '>', new_chunker, $out, ); =back =head2 Just doing I/O If you just want to do I/O to a handle or file you open yourself, you may specify a filehandle or filename instead of a command in the harness specification: run io( "filename", '>', \$recv ); $h = start io( $io, '>', \$recv ); $h = harness \@cmd, '&', io( "file", '<', \$send ); =head2 Options Options are passed in as name/value pairs: run \@cat, \$in, debug => 1; If you pass the debug option, you may want to pass it in first, so you can see what parsing is going on: run debug => 1, \@cat, \$in; =over =item debug Enables debugging output in parent and child. Debugging info is emitted to the STDERR that was present when IPC::Run was first Ced (it's Ced out of the way so that it can be redirected in children without having debugging output emitted on it). =back =head1 RETURN VALUES harness() and start() return a reference to an IPC::Run harness. This is blessed in to the IPC::Run package, so you may make later calls to functions as members if you like: $h = harness( ... ); $h->start; $h->pump; $h->finish; $h = start( .... ); $h->pump; ... Of course, using method call syntax lets you deal with any IPC::Run subclasses that might crop up, but don't hold your breath waiting for any. run() and finish() return TRUE when all subcommands exit with a 0 result code. B. All routines raise exceptions (via die()) when error conditions are recognized. A non-zero command result is not treated as an error condition, since some commands are tests whose results are reported in their exit codes. =head1 ROUTINES =over =cut use strict; use Exporter (); use vars qw{$VERSION @ISA @FILTER_IMP @FILTERS @API @EXPORT_OK %EXPORT_TAGS}; BEGIN { $VERSION = '0.92'; @ISA = qw{ Exporter }; ## We use @EXPORT for the end user's convenience: there's only one function ## exported, it's homonymous with the module, it's an unusual name, and ## it can be suppressed by "use IPC::Run ();". @FILTER_IMP = qw( input_avail get_more_input ); @FILTERS = qw( new_appender new_chunker new_string_source new_string_sink ); @API = qw( run harness start pump pumpable finish signal kill_kill reap_nb io timer timeout close_terminal binary ); @EXPORT_OK = ( @API, @FILTER_IMP, @FILTERS, qw( Win32_MODE ) ); %EXPORT_TAGS = ( 'filter_imp' => \@FILTER_IMP, 'all' => \@EXPORT_OK, 'filters' => \@FILTERS, 'api' => \@API, ); } use strict; use IPC::Run::Debug; use Exporter; use Fcntl; use POSIX (); use Symbol; use Carp; use File::Spec (); use IO::Handle; require IPC::Run::IO; require IPC::Run::Timer; use UNIVERSAL (); use constant Win32_MODE => $^O =~ /os2|Win32/i; BEGIN { if ( Win32_MODE ) { eval "use IPC::Run::Win32Helper; 1;" or ( $@ && die ) or die "$!"; } else { eval "use File::Basename; 1;" or die $!; } } sub input_avail(); sub get_more_input(); ############################################################################### ## ## Error constants, not too locale-dependant use vars qw( $_EIO $_EAGAIN ); use Errno qw( EIO EAGAIN ); BEGIN { local $!; $! = EIO; $_EIO = qr/^$!/; $! = EAGAIN; $_EAGAIN = qr/^$!/; } ## ## State machine states, set in $self->{STATE} ## ## These must be in ascending order numerically ## sub _newed() {0} sub _harnessed(){1} sub _finished() {2} ## _finished behave almost exactly like _harnessed sub _started() {3} ## ## Which fds have been opened in the parent. This may have extra fds, since ## we aren't all that rigorous about closing these off, but that's ok. This ## is used on Unixish OSs to close all fds in the child that aren't needed ## by that particular child. my %fds; ## There's a bit of hackery going on here. ## ## We want to have any code anywhere be able to emit ## debugging statements without knowing what harness the code is ## being called in/from, since we'd need to pass a harness around to ## everything. ## ## Thus, $cur_self was born. use vars qw( $cur_self ); sub _debug_fd { return fileno STDERR unless defined $cur_self; if ( _debugging && ! defined $cur_self->{DEBUG_FD} ) { my $fd = select STDERR; $| = 1; select $fd; $cur_self->{DEBUG_FD} = POSIX::dup fileno STDERR; _debug( "debugging fd is $cur_self->{DEBUG_FD}\n" ) if _debugging_details; } return fileno STDERR unless defined $cur_self->{DEBUG_FD}; return $cur_self->{DEBUG_FD} } sub DESTROY { ## We absolutely do not want to do anything else here. We are likely ## to be in a child process and we don't want to do things like kill_kill ## ourself or cause other destruction. my IPC::Run $self = shift; POSIX::close $self->{DEBUG_FD} if defined $self->{DEBUG_FD}; $self->{DEBUG_FD} = undef; } ## ## Support routines (NOT METHODS) ## my %cmd_cache; sub _search_path { my ( $cmd_name ) = @_; if ( File::Spec->file_name_is_absolute( $cmd_name ) && -x $cmd_name) { _debug "'", $cmd_name, "' is absolute" if _debugging_details; return $cmd_name; } my $dirsep = ( Win32_MODE ? '[/\\\\]' : $^O =~ /MacOS/ ? ':' : $^O =~ /VMS/ ? '[\[\]]' : '/' ); if ( Win32_MODE && ( $cmd_name =~ /$dirsep/ ) # && ( $cmd_name !~ /\..+$/ ) ## Only run if cmd_name has no extension? && ( $cmd_name !~ m!\.[^\\/\.]+$! ) ) { _debug "no extension(.exe), checking ENV{PATHEXT}" if _debugging; for ( split /;/, $ENV{PATHEXT} || ".COM;.BAT;.EXE" ) { my $name = "$cmd_name$_"; $cmd_name = $name, last if -f $name && -x _; } _debug "cmd_name is now '$cmd_name'" if _debugging; } if ( $cmd_name =~ /($dirsep)/ ) { _debug "'$cmd_name' contains '$1'" if _debugging; croak "file not found: $cmd_name" unless -e $cmd_name; croak "not a file: $cmd_name" unless -f $cmd_name; croak "permission denied: $cmd_name" unless -x $cmd_name; return $cmd_name; } if ( exists $cmd_cache{$cmd_name} ) { _debug "'$cmd_name' found in cache: '$cmd_cache{$cmd_name}'" if _debugging; return $cmd_cache{$cmd_name} if -x $cmd_cache{$cmd_name}; _debug "'$cmd_cache{$cmd_name}' no longer executable, searching..." if _debugging; delete $cmd_cache{$cmd_name}; } my @searched_in; ## This next bit is Unix/Win32 specific, unfortunately. ## There's been some conversation about extending File::Spec to provide ## a universal interface to PATH, but I haven't seen it yet. my $re = Win32_MODE ? qr/;/ : qr/:/; LOOP: for ( split( $re, $ENV{PATH} || '', -1 ) ) { $_ = "." unless length $_; push @searched_in, $_; my $prospect = File::Spec->catfile( $_, $cmd_name ); my @prospects; @prospects = ( Win32_MODE && ! ( -f $prospect && -x _ ) ) ? map "$prospect$_", split /;/, $ENV{PATHEXT} || ".COM;.BAT;.EXE" : ( $prospect ); for my $found ( @prospects ) { if ( -f $found && -x _ ) { $cmd_cache{$cmd_name} = $found; last LOOP; } } } if ( exists $cmd_cache{$cmd_name} ) { _debug "'", $cmd_name, "' added to cache: '", $cmd_cache{$cmd_name}, "'" if _debugging_details; return $cmd_cache{$cmd_name}; } croak "Command '$cmd_name' not found in " . join( ", ", @searched_in ); } sub _empty($) { ! ( defined $_[0] && length $_[0] ) } ## 'safe' versions of otherwise fun things to do. See also IPC::Run::Win32Helper. sub _close { confess 'undef' unless defined $_[0]; no strict 'refs'; my $fd = $_[0] =~ /^\d+$/ ? $_[0] : fileno $_[0]; my $r = POSIX::close $fd; $r = $r ? '' : " ERROR $!"; delete $fds{$fd}; _debug "close( $fd ) = " . ( $r || 0 ) if _debugging_details; } sub _dup { confess 'undef' unless defined $_[0]; my $r = POSIX::dup( $_[0] ); croak "$!: dup( $_[0] )" unless defined $r; $r = 0 if $r eq '0 but true'; _debug "dup( $_[0] ) = $r" if _debugging_details; $fds{$r} = 1; return $r; } sub _dup2_rudely { confess 'undef' unless defined $_[0] && defined $_[1]; my $r = POSIX::dup2( $_[0], $_[1] ); croak "$!: dup2( $_[0], $_[1] )" unless defined $r; $r = 0 if $r eq '0 but true'; _debug "dup2( $_[0], $_[1] ) = $r" if _debugging_details; $fds{$r} = 1; return $r; } sub _exec { confess 'undef passed' if grep !defined, @_; # exec @_ or croak "$!: exec( " . join( ', ', @_ ) . " )"; _debug 'exec()ing ', join " ", map "'$_'", @_ if _debugging_details; # { ## Commented out since we don't call this on Win32. # # This works around the bug where 5.6.1 complains # # "Can't exec ...: No error" after an exec on NT, where # # exec() is simulated and actually returns in Perl's C # # code, though Perl's &exec does not... # no warnings "exec"; # # # Just in case the no warnings workaround # # stops beign a workaround, we don't want # # old values of $! causing spurious strerr() # # messages to appear in the "Can't exec" message # undef $!; exec @_; # } # croak "$!: exec( " . join( ', ', map "'$_'", @_ ) . " )"; ## Fall through so $! can be reported to parent. } sub _sysopen { confess 'undef' unless defined $_[0] && defined $_[1]; _debug sprintf( "O_RDONLY=0x%02x ", O_RDONLY ), sprintf( "O_WRONLY=0x%02x ", O_WRONLY ), sprintf( "O_RDWR=0x%02x ", O_RDWR ), sprintf( "O_TRUNC=0x%02x ", O_TRUNC), sprintf( "O_CREAT=0x%02x ", O_CREAT), sprintf( "O_APPEND=0x%02x ", O_APPEND), if _debugging_details; my $r = POSIX::open( $_[0], $_[1], 0644 ); croak "$!: open( $_[0], ", sprintf( "0x%03x", $_[1] ), " )" unless defined $r; _debug "open( $_[0], ", sprintf( "0x%03x", $_[1] ), " ) = $r" if _debugging_data; $fds{$r} = 1; return $r; } sub _pipe { ## Normal, blocking write for pipes that we read and the child writes, ## since most children expect writes to stdout to block rather than ## do a partial write. my ( $r, $w ) = POSIX::pipe; croak "$!: pipe()" unless defined $r; _debug "pipe() = ( $r, $w ) " if _debugging_details; $fds{$r} = $fds{$w} = 1; return ( $r, $w ); } sub _pipe_nb { ## For pipes that we write, unblock the write side, so we can fill a buffer ## and continue to select(). ## Contributed by Borislav Deianov , with minor ## bugfix on fcntl result by me. local ( *R, *W ); my $f = pipe( R, W ); croak "$!: pipe()" unless defined $f; my ( $r, $w ) = ( fileno R, fileno W ); _debug "pipe_nb pipe() = ( $r, $w )" if _debugging_details; unless ( Win32_MODE ) { ## POSIX::fcntl doesn't take fd numbers, so gotta use Perl's and ## then _dup the originals (which get closed on leaving this block) my $fres = fcntl( W, &F_SETFL, O_WRONLY | O_NONBLOCK ); croak "$!: fcntl( $w, F_SETFL, O_NONBLOCK )" unless $fres; _debug "fcntl( $w, F_SETFL, O_NONBLOCK )" if _debugging_details; } ( $r, $w ) = ( _dup( $r ), _dup( $w ) ); _debug "pipe_nb() = ( $r, $w )" if _debugging_details; return ( $r, $w ); } sub _pty { require IO::Pty; my $pty = IO::Pty->new(); croak "$!: pty ()" unless $pty; $pty->autoflush(); $pty->blocking( 0 ) or croak "$!: pty->blocking ( 0 )"; _debug "pty() = ( ", $pty->fileno, ", ", $pty->slave->fileno, " )" if _debugging_details; $fds{$pty->fileno} = $fds{$pty->slave->fileno} = 1; return $pty; } sub _read { confess 'undef' unless defined $_[0]; my $s = ''; my $r = POSIX::read( $_[0], $s, 10_000 ); croak "$!: read( $_[0] )" if not($r) and $! != POSIX::EINTR; $r ||= 0; _debug "read( $_[0] ) = $r chars '$s'" if _debugging_data; return $s; } ## A METHOD, not a function. sub _spawn { my IPC::Run $self = shift; my ( $kid ) = @_; _debug "opening sync pipe ", $kid->{PID} if _debugging_details; my $sync_reader_fd; ( $sync_reader_fd, $self->{SYNC_WRITER_FD} ) = _pipe; $kid->{PID} = fork(); croak "$! during fork" unless defined $kid->{PID}; unless ( $kid->{PID} ) { ## _do_kid_and_exit closes sync_reader_fd since it closes all unwanted and ## unloved fds. $self->_do_kid_and_exit( $kid ); } _debug "fork() = ", $kid->{PID} if _debugging_details; ## Wait for kid to get to it's exec() and see if it fails. _close $self->{SYNC_WRITER_FD}; my $sync_pulse = _read $sync_reader_fd; _close $sync_reader_fd; if ( ! defined $sync_pulse || length $sync_pulse ) { if ( waitpid( $kid->{PID}, 0 ) >= 0 ) { $kid->{RESULT} = $?; } else { $kid->{RESULT} = -1; } $sync_pulse = "error reading synchronization pipe for $kid->{NUM}, pid $kid->{PID}" unless length $sync_pulse; croak $sync_pulse; } return $kid->{PID}; ## Wait for pty to get set up. This is a hack until we get synchronous ## selects. if ( keys %{$self->{PTYS}} && $IO::Pty::VERSION < 0.9 ) { _debug "sleeping to give pty a chance to init, will fix when newer IO::Pty arrives."; sleep 1; } } sub _write { confess 'undef' unless defined $_[0] && defined $_[1]; my $r = POSIX::write( $_[0], $_[1], length $_[1] ); croak "$!: write( $_[0], '$_[1]' )" unless $r; _debug "write( $_[0], '$_[1]' ) = $r" if _debugging_data; return $r; } =pod =over =item run Run takes a harness or harness specification and runs it, pumping all input to the child(ren), closing the input pipes when no more input is available, collecting all output that arrives, until the pipes delivering output are closed, then waiting for the children to exit and reaping their result codes. You may think of C as being like start( ... )->finish(); , though there is one subtle difference: run() does not set \$input_scalars to '' like finish() does. If an exception is thrown from run(), all children will be killed off "gently", and then "annihilated" if they do not go gently (in to that dark night. sorry). If any exceptions are thrown, this does a L before propogating them. =cut use vars qw( $in_run ); ## No, not Enron;) sub run { local $in_run = 1; ## Allow run()-only optimizations. my IPC::Run $self = start( @_ ); my $r = eval { $self->{clear_ins} = 0; $self->finish; }; if ( $@ ) { my $x = $@; $self->kill_kill; die $x; } return $r; } =pod =item signal ## To send it a specific signal by name ("USR1"): signal $h, "USR1"; $h->signal ( "USR1" ); If $signal is provided and defined, sends a signal to all child processes. Try not to send numeric signals, use C<"KILL"> instead of C<9>, for instance. Numeric signals aren't portable. Throws an exception if $signal is undef. This will I clean up the harness, C it if you kill it. Normally TERM kills a process gracefully (this is what the command line utility C does by default), INT is sent by one of the keys C<^C>, C or CDelE>, and C is used to kill a process and make it coredump. The C signal is often used to get a process to "restart", rereading config files, and C and C for really application-specific things. Often, running C (that's a lower case "L") on the command line will list the signals present on your operating system. B: The signal subsystem is not at all portable. We *may* offer to simulate C and C on some operating systems, submit code to me if you want this. B: Up to and including perl v5.6.1, doing almost anything in a signal handler could be dangerous. The most safe code avoids all mallocs and system calls, usually by preallocating a flag before entering the signal handler, altering the flag's value in the handler, and responding to the changed value in the main system: my $got_usr1 = 0; sub usr1_handler { ++$got_signal } $SIG{USR1} = \&usr1_handler; while () { sleep 1; print "GOT IT" while $got_usr1--; } Even this approach is perilous if ++ and -- aren't atomic on your system (I've never heard of this on any modern CPU large enough to run perl). =cut sub signal { my IPC::Run $self = shift; local $cur_self = $self; $self->_kill_kill_kill_pussycat_kill unless @_; Carp::cluck "Ignoring extra parameters passed to kill()" if @_ > 1; my ( $signal ) = @_; croak "Undefined signal passed to signal" unless defined $signal; for ( grep $_->{PID} && ! defined $_->{RESULT}, @{$self->{KIDS}} ) { _debug "sending $signal to $_->{PID}" if _debugging; kill $signal, $_->{PID} or _debugging && _debug "$! sending $signal to $_->{PID}"; } return; } =pod =item kill_kill ## To kill off a process: $h->kill_kill; kill_kill $h; ## To specify the grace period other than 30 seconds: kill_kill $h, grace => 5; ## To send QUIT instead of KILL if a process refuses to die: kill_kill $h, coup_d_grace => "QUIT"; Sends a C, waits for all children to exit for up to 30 seconds, then sends a C to any that survived the C. Will wait for up to 30 more seconds for the OS to successfully C the processes. The 30 seconds may be overridden by setting the C option, this overrides both timers. The harness is then cleaned up. The doubled name indicates that this function may kill again and avoids colliding with the core Perl C function. Returns a 1 if the C was sufficient, or a 0 if C was required. Throws an exception if C did not permit the children to be reaped. B: The grace period is actually up to 1 second longer than that given. This is because the granularity of C