├── .github └── workflows │ └── ci.yaml ├── .gitignore ├── .perltidyrc ├── .ship.conf ├── Changes ├── MANIFEST.SKIP ├── Makefile.PL ├── README.md ├── cpanfile ├── examples ├── rwf.pl ├── sshp.pl ├── sshpass └── tail.pl ├── lib └── Mojo │ └── IOLoop │ ├── ReadWriteFork.pm │ └── ReadWriteFork │ └── SIGCHLD.pm └── t ├── 00-basic.t ├── close.t ├── conduit-pty3.t ├── event-asset.t ├── event-drain.t ├── event-finish.t ├── event-legacy.t ├── event-prepare.t ├── event-stderr-stdout.t ├── lsof.t ├── minion.t ├── mojolicious-lite-ev.t ├── mojolicious-lite-poll.t ├── premature-close.t ├── proc-memory-usage.t ├── run-bash.t ├── run-callback.t ├── run-ssh.t ├── run-sudo.t ├── run-telnet.t ├── rwf.t ├── sigchld-poll.t └── synopsis.t /.github/workflows/ci.yaml: -------------------------------------------------------------------------------- 1 | name: CI 2 | on: [push] 3 | jobs: 4 | perl: 5 | runs-on: ubuntu-latest 6 | strategy: 7 | matrix: 8 | perl-version: 9 | - '5.16' 10 | - '5.20' 11 | - '5.26' 12 | - '5.34' 13 | container: 14 | image: perl:${{matrix.perl-version}} 15 | steps: 16 | - uses: actions/checkout@v2 17 | - name: perl -V 18 | run: perl -V 19 | - name: Install dependencies 20 | run: | 21 | cpanm -n EV~"!= 4.28" 22 | cpanm -n https://github.com/mojolicious/mojo/archive/refs/tags/v8.25.tar.gz 23 | cpanm -n Test::Pod Test::Pod::Coverage 24 | cpanm -n --installdeps . 25 | - name: Run perl tests 26 | run: prove -l 27 | env: 28 | TEST_BOT: 1 29 | TEST_FH: 1 30 | TEST_MEMORY: 20 31 | TEST_POD: 1 32 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /META.yml 2 | /MYMETA.* 3 | /blib/ 4 | /inc/ 5 | /local 6 | /pm_to_blib 7 | /MANIFEST 8 | /MANIFEST.bak 9 | /Makefile 10 | /Makefile.old 11 | .readwritefork_ssh 12 | .sudo_password 13 | .readwritefork_ssh_password 14 | *.old 15 | *.swp 16 | ~$ 17 | /Mojo-IOLoop-ReadWriteFork*tar.gz 18 | -------------------------------------------------------------------------------- /.perltidyrc: -------------------------------------------------------------------------------- 1 | -pbp # Start with Perl Best Practices 2 | -w # Show all warnings 3 | -iob # Ignore old breakpoints 4 | -l=120 # 120 characters per line 5 | -mbl=2 # No more than 2 blank lines 6 | -i=2 # Indentation is 2 columns 7 | -ci=2 # Continuation indentation is 2 columns 8 | -vt=0 # Less vertical tightness 9 | -pt=2 # High parenthesis tightness 10 | -bt=2 # High brace tightness 11 | -sbt=2 # High square bracket tightness 12 | -isbc # Don't indent comments without leading space 13 | -------------------------------------------------------------------------------- /.ship.conf: -------------------------------------------------------------------------------- 1 | # Generated by git-ship. See 'git-ship --man' for help or https://github.com/jhthorsen/app-git-ship 2 | class = App::git::ship::perl 3 | project_name = 4 | homepage = https://github.com/jhthorsen/mojo-ioloop-readwritefork 5 | bugtracker = https://github.com/jhthorsen/mojo-ioloop-readwritefork/issues 6 | license = artistic_2 7 | build_test_options = # Example: -l -j8 8 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | Revision history for perl distribution Mojo-IOLoop-ReadWriteFork 2 | 3 | 2.02 2022-06-09T12:47:08+0900 4 | - Fix cleaning up stderr_read 5 | - Fix closing the IO::Pty slave 6 | - Fix also closing pty or stdout if stdin share the same handle 7 | - Changed run_and_capture_p() to only capture STDOUT if STDERR and STDOUT is split 8 | 9 | 2.01 2022-05-30T08:20:46+0900 10 | - Add support for conduit = pty3 11 | - Internal cleanup regarding filehandle passing 12 | 13 | 2.00 2022-02-12T11:53:55+0900 14 | - Add support for "stderr" and "stdout" events 15 | 16 | 1.02 2021-04-21T13:01:11+0900 17 | - Fix Mojo::Promise->timer require Mojolicious 8.41 #18 18 | 19 | 1.01 2021-04-11T12:00:35+0900 20 | - Fix issue in SYNOPSIS 21 | - Fix Test::Memory::Cycle issues 22 | 23 | 1.00 2021-03-25T11:05:26+0900 24 | - Add pids() to Mojo::IOLoop::ReadWriteFork::SIGCHLD 25 | - Add run_and_capture_p() 26 | - Add "asset" event 27 | - Documented "drain" event 28 | - Replaced "before_fork" event with "prepare" 29 | - Replaced "close" event with "finish" 30 | - Replaced "fork" event with "spawn" 31 | 32 | 0.43 2021-03-24T16:45:18+0900 33 | - Fix not triggering "error" on EIO 34 | 35 | 0.42 2021-03-24T15:26:25+0900 36 | - Fix $rwf to keep track of itself as long as the child process is running 37 | - Using Mojo::IOLoop::Stream, since $ioloop->reactor is hard 38 | 39 | 0.41 2021-03-15T17:26:23+0900 40 | - Fix circular references 41 | 42 | 0.40 2021-03-05T18:23:49+0900 43 | - Fix infinite loop, when die() is called inside "close" event 44 | 45 | 0.39 2021-02-26T14:17:23+0900 46 | - Add "before_fork" hook 47 | 48 | 0.38 2021-02-17T10:15:57+0900 49 | - Require Mojolicious 8.0 50 | - Add run_p() 51 | - Add fix for premature close in special pty cases #12 52 | Contributor: Ole Bjørn Hessen 53 | 54 | 0.37 2018-09-26T13:51:13+0900 55 | - Fix minion test requires Minion::Backend::SQLite >=4.001 56 | 57 | 0.36 2018-03-11T14:50:05+0100 58 | - Fix releasing the pty on close #10 59 | Contributor: Ole Bjørn Hessen 60 | 61 | 0.35 2017-08-21T13:07:01+0200 62 | - Need to skip close-filehandles.t for now 63 | 64 | 0.24 2017-08-19T22:46:02+0200 65 | - Fix running RWF with Minion 7.05 #9 66 | - Add test for leaking filehandles in Mojolicious application #7 67 | 68 | 0.23 2016-10-13T10:07:18+0200 69 | - Fix documentation: There is no "spawn" event #8 70 | 71 | 0.22 2016-06-27T08:28:49+0200 72 | - Add "fork" event 73 | 74 | 0.21 2016-05-03T14:27:40+0200 75 | - Fix failing t/synopsis.t #6 76 | 77 | 0.20 2016-04-18T14:51:14+0200 78 | - Add support for passing in %ENV #5 79 | 80 | 0.19 2016-04-14T11:54:18+0200 81 | - Add missing documentation for CODE passed on to run() / start() 82 | - Change conduit() into holding a hash. 83 | 84 | 0.18 2016-04-14T09:54:31+0200 85 | - Improved documentation 86 | - Add conduit() attribute 87 | - Remove deprecated reactor() attribute 88 | 89 | 0.17 2016-03-10T22:41:54+0100 90 | - Improve tests on FreeBSD 91 | http://cpantesters.org/cpan/report/9d911494-a39d-11e5-932c-a1bf8fb2e322 92 | 93 | 0.16 2015-11-19T19:36:39+0100 94 | - Fix Minion::Backend::File does not exist anymore #2 95 | 96 | 0.15 2015-10-15T16:50:48+0200 97 | - Made t/minion.t more robust 98 | 99 | 0.14 2015-10-15T16:21:07+0200 100 | - Will use waitpid() if $SIG{CHLD} = "DEFAULT" 101 | https://github.com/kraih/minion/issues/15 102 | 103 | 0.13 2015-07-16T12:42:41+0200 104 | - Will use EV::child to look for SIGCHLD if EV is available 105 | 106 | 0.12 2015-04-28T15:14:02+0200 107 | - Fix reading from stdout_read after "Input/output error" ($!=5) 108 | - Improved output to screen in DEBUG mode 109 | - Will not require Test::Memory::Cycle 110 | It could not be installed, since it require CGI.pm which is not core anymore 111 | 112 | 0.11 2015-01-03T15:32:16Z 113 | - Skip sudo.t 114 | 115 | 0.10 2015-01-03T12:59:57Z 116 | - Fix die() inside callback in child process 117 | - Fix starting invalid program 118 | - Add "ioloop" attribute 119 | - Remove hackish /proc/$pid test 120 | - Deprecated "reactor" attribute 121 | 122 | 0.09 2014-11-19T15:35:36Z 123 | - Trying to fix t/telnet.t with \r\n on BSD 124 | 125 | 0.08 2014-11-16T14:16:47Z 126 | - Trying to fix t/telnet.t with localhost 127 | 128 | 0.07 2014-11-13T18:52:55Z 129 | - Trying to fix t/telnet.t with 127.0.0.1 130 | - Mojo::EventEmitter::emit_safe is DEPRECATED 131 | 132 | 0.06 2014-08-11T16:59:18Z 133 | - Fix "Use of uninitialized value in numeric eq (==) at ReadWriteFork.pm 134 | line 182." 135 | - Add support for write() before child process has started 136 | - Add support for "drain" callback to write() 137 | - Add run(). a simpler version start() 138 | - Add close() for closing STDIN 139 | 140 | 0.05 2014-02-19T13:29:54Z 141 | - Fix "read" event cannot change ERRNO from sysread() 142 | 143 | 0.04 2013-11-22T19:52:52Z 144 | - Add support for callbacks 145 | - Fix failing tests 146 | 147 | 0.03 2013-11-22T08:35:43Z 148 | - A bit more relaxed test for cat.t: Running it on BSD results in 149 | "^D" at the end. 150 | 151 | 0.02 2013-11-20T11:36:38Z 152 | - Add examples/tail.pl 153 | - Fix failing t/bash.t 154 | 155 | 0.01 2013-11-20T10:25:19Z 156 | - First release on CPAN 157 | 158 | -------------------------------------------------------------------------------- /MANIFEST.SKIP: -------------------------------------------------------------------------------- 1 | # Avoid version control files. 2 | \bRCS\b 3 | \bCVS\b 4 | \bSCCS\b 5 | ,v$ 6 | \B\.svn\b 7 | \B\.git\b 8 | \B\.gitignore\b 9 | \b_darcs\b 10 | \B\.cvsignore$ 11 | 12 | # Avoid VMS specific MakeMaker generated files 13 | \bDescrip.MMS$ 14 | \bDESCRIP.MMS$ 15 | \bdescrip.mms$ 16 | 17 | # Avoid Makemaker generated and utility files. 18 | \bMANIFEST\.bak 19 | \bMakefile$ 20 | \bblib/ 21 | \bMakeMaker-\d 22 | \bpm_to_blib\.ts$ 23 | \bpm_to_blib$ 24 | \bblibdirs\.ts$ # 6.18 through 6.25 generated this 25 | 26 | # Avoid Module::Build generated and utility files. 27 | \bBuild$ 28 | \b_build/ 29 | \bBuild.bat$ 30 | \bBuild.COM$ 31 | \bBUILD.COM$ 32 | \bbuild.com$ 33 | 34 | # Avoid temp and backup files. 35 | ~$ 36 | \.old$ 37 | \#$ 38 | \b\.# 39 | \.bak$ 40 | \.tmp$ 41 | \.# 42 | \.rej$ 43 | 44 | # Avoid OS-specific files/dirs 45 | # Mac OSX metadata 46 | \B\.DS_Store 47 | # Mac OSX SMB mount metadata files 48 | \B\._ 49 | 50 | # Avoid Devel::Cover and Devel::CoverX::Covered files. 51 | \bcover_db\b 52 | \bcovered\b 53 | 54 | # Avoid MYMETA files 55 | ^MYMETA\. 56 | 57 | \.swp$ 58 | ^local/ 59 | ^MANIFEST\.SKIP 60 | ^README\.pod 61 | ^\.readwritefork_ssh 62 | ^\.readwritefork_ssh_password 63 | ^\.sudo_password 64 | ^\.github 65 | ^\.pls_cache 66 | -------------------------------------------------------------------------------- /Makefile.PL: -------------------------------------------------------------------------------- 1 | # Generated by git-ship. See 'git-ship --man' for help or https://github.com/jhthorsen/app-git-ship 2 | use utf8; 3 | use ExtUtils::MakeMaker; 4 | my %WriteMakefileArgs = ( 5 | NAME => 'Mojo::IOLoop::ReadWriteFork', 6 | AUTHOR => 'Jan Henning Thorsen ', 7 | LICENSE => 'artistic_2', 8 | ABSTRACT_FROM => 'lib/Mojo/IOLoop/ReadWriteFork.pm', 9 | VERSION_FROM => 'lib/Mojo/IOLoop/ReadWriteFork.pm', 10 | EXE_FILES => [qw()], 11 | OBJECT => '', 12 | BUILD_REQUIRES => {}, 13 | TEST_REQUIRES => {'Test::More' => '0.88'}, 14 | PREREQ_PM => {'IO::Pty' => '1.16', 'IO::Socket::IP' => '0.37', 'Mojolicious' => '8.25', 'Sub::Util' => '1.41'}, 15 | META_MERGE => { 16 | 'dynamic_config' => 0, 17 | 'meta-spec' => {version => 2}, 18 | 'resources' => { 19 | bugtracker => {web => 'https://github.com/jhthorsen/mojo-ioloop-readwritefork/issues'}, 20 | homepage => 'https://github.com/jhthorsen/mojo-ioloop-readwritefork', 21 | repository => { 22 | type => 'git', 23 | url => 'https://github.com/jhthorsen/mojo-ioloop-readwritefork.git', 24 | web => 'https://github.com/jhthorsen/mojo-ioloop-readwritefork', 25 | }, 26 | }, 27 | 'x_contributors' => ['Jan Henning Thorsen '], 28 | }, 29 | test => {TESTS => (-e 'META.yml' ? 't/*.t' : 't/*.t xt/*.t')}, 30 | ); 31 | 32 | unless (eval { ExtUtils::MakeMaker->VERSION('6.63_03') }) { 33 | my $test_requires = delete $WriteMakefileArgs{TEST_REQUIRES}; 34 | @{$WriteMakefileArgs{PREREQ_PM}}{keys %$test_requires} = values %$test_requires; 35 | } 36 | 37 | WriteMakefile(%WriteMakefileArgs); 38 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # NAME 2 | 3 | Mojo::IOLoop::ReadWriteFork - Fork a process and read/write from it 4 | 5 | # VERSION 6 | 7 | 2.02 8 | 9 | # SYNOPSIS 10 | 11 | use Mojo::Base -strict, -signatures; 12 | my $rwf = Mojo::IOLoop::ReadWriteFork->new; 13 | 14 | # Emitted if something terrible happens 15 | $rwf->on(error => sub ($rwf, $error) { warn $error }); 16 | 17 | # Emitted when the child completes 18 | $rwf->on(finish => sub ($rwf, $exit_value, $signal) { Mojo::IOLoop->stop; }); 19 | 20 | # Emitted when the child prints to STDOUT or STDERR 21 | $rwf->on(read => sub ($rwf, $buf) { print qq(Child process sent us "$buf") }); 22 | 23 | # Need to set "conduit" for bash, ssh, and other programs that require a pty 24 | $rwf->conduit({type => 'pty'}); 25 | 26 | # Start the application 27 | $rwf->run('bash', -c => q(echo $YIKES foo bar baz)); 28 | 29 | # Using promises 30 | $rwf->on(read => sub ($rwf, $buf) { ... }); 31 | $rwf->run_p('bash', -c => q(echo $YIKES foo bar baz))->wait; 32 | 33 | See also 34 | [https://github.com/jhthorsen/mojo-ioloop-readwritefork/tree/master/examples/tail.pl](https://github.com/jhthorsen/mojo-ioloop-readwritefork/tree/master/examples/tail.pl) 35 | for an example usage from a [Mojo::Controller](https://metacpan.org/pod/Mojo%3A%3AController). 36 | 37 | # DESCRIPTION 38 | 39 | [Mojo::IOLoop::ReadWriteFork](https://metacpan.org/pod/Mojo%3A%3AIOLoop%3A%3AReadWriteFork) enable you to fork a child process and ["read"](#read) 40 | and ["write"](#write) data to. You can also [send signals](#kill) to the child and see 41 | when the process ends. The child process can be an external program (bash, 42 | telnet, ffmpeg, ...) or a CODE block running perl. 43 | 44 | ## Conduits 45 | 46 | [Mojo::IOLoop::ReadWriteFork](https://metacpan.org/pod/Mojo%3A%3AIOLoop%3A%3AReadWriteFork) can write to STDIN or a [IO::Pty](https://metacpan.org/pod/IO%3A%3APty) object, and 47 | read from STDOUT or STDERR, depending on the "type" given to ["conduit"](#conduit). 48 | 49 | Here is an overview of the different conduits: 50 | 51 | - pipe 52 | 53 | The "pipe" type will create a STDIN and a STDOUT conduit using a plain pipe. 54 | Passing in `stderr` will also create a seperate pipe for STDERR. 55 | 56 | $rwf->conduit({type => 'pipe'}); 57 | $rwf->conduit({type => 'pipe', stderr => 1}); 58 | $rwf->write('some data'); # write to STDIN 59 | $rwf->on(read => sub { ... }); # STDOUT and STDERR 60 | $rwf->on(stdout => sub { ... }); # STDOUT 61 | $rwf->on(stderr => sub { ... }); # STDERR 62 | 63 | This is useful if you want to run a program like "cat" that simply read/write 64 | from STDIN, STDERR or STDOUT. 65 | 66 | - pty 67 | 68 | The "pty" type will create a STDIN and a STDOUT conduit using [IO::Pty](https://metacpan.org/pod/IO%3A%3APty). 69 | Passing in "stderr" will also create a seperate pipe for STDERR. 70 | 71 | $rwf->conduit({type => 'pty'}); 72 | $rwf->conduit({type => 'pty', stderr => 1}); 73 | $rwf->write('some data'); # write to STDIN 74 | $rwf->on(read => sub { ... }); # STDOUT and STDERR 75 | $rwf->on(stdout => sub { ... }); # STDOUT 76 | $rwf->on(stderr => sub { ... }); # STDERR 77 | 78 | The difference between "pipe" and "pty" is that a [IO::Pty](https://metacpan.org/pod/IO%3A%3APty) object will be 79 | used for STDIN and STDOUT instead of a plain pipe. In addition, it is possible 80 | to pass in `clone_winsize_from` and `raw`: 81 | 82 | $rwf->conduit({type => 'pty', clone_winsize_from => \*STDOUT, raw => 1}); 83 | 84 | This is useful if you want to run "bash" or another program that requires a 85 | pseudo terminal. 86 | 87 | - pty3 88 | 89 | The "pty3" type will create a STDIN, a STDOUT, a STDERR and a PTY conduit. 90 | 91 | $rwf->conduit({type => 'pty3'}); 92 | $rwf->write('some data'); # write to STDIN/PTY 93 | $rwf->on(pty => sub { ... }); # PTY 94 | $rwf->on(stdout => sub { ... }); # STDOUT 95 | $rwf->on(stderr => sub { ... }); # STDERR 96 | 97 | The difference between "pty" and "pty3" is that there will be a different 98 | ["read"](#read) event for bytes coming from the pseudo PTY. This type also supports 99 | "clone\_winsize\_from" and "raw". 100 | 101 | $rwf->conduit({type => 'pty3', clone_winsize_from => \*STDOUT, raw => 1}); 102 | 103 | This is useful if you want to run "ssh" or another program that sends password 104 | prompts (or other output) on the PTY channel. See 105 | [https://github.com/jhthorsen/mojo-ioloop-readwritefork/tree/master/examples/sshpass](https://github.com/jhthorsen/mojo-ioloop-readwritefork/tree/master/examples/sshpass) 106 | for an example application. 107 | 108 | # EVENTS 109 | 110 | ## asset 111 | 112 | $rwf->on(asset => sub ($rwf, $asset) { ... }); 113 | 114 | Emitted at least once when calling ["run\_and\_capture\_p"](#run_and_capture_p). `$asset` can be 115 | either a [Mojo::Asset::Memory](https://metacpan.org/pod/Mojo%3A%3AAsset%3A%3AMemory) or [Mojo::Asset::File](https://metacpan.org/pod/Mojo%3A%3AAsset%3A%3AFile) object. 116 | 117 | $rwf->on(asset => sub ($rwf, $asset) { 118 | # $asset->auto_upgrade(1) is set by default 119 | $asset->max_memory_size(1) if $asset->can('max_memory_size'); 120 | }); 121 | 122 | ## drain 123 | 124 | $rwf->on(drain => sub ($rwf) { ... }); 125 | 126 | Emitted when the buffer has been written to the sub process. 127 | 128 | ## error 129 | 130 | $rwf->on(error => sub ($rwf, $str) { ... }); 131 | 132 | Emitted when when the there is an issue with creating, writing or reading 133 | from the child process. 134 | 135 | ## finish 136 | 137 | $rwf->on(finish => sub ($rwf, $exit_value, $signal) { ... }); 138 | 139 | Emitted when the child process exit. 140 | 141 | ## pty 142 | 143 | $rwf->on(pty => sub ($rwf, $buf) { ... }); 144 | 145 | Emitted when the child has written a chunk of data to a pty and ["conduit"](#conduit) has 146 | "type" set to "pty3". 147 | 148 | ## prepare 149 | 150 | $rwf->on(prepare => sub ($rwf, $fh) { ... }); 151 | 152 | Emitted right before the child process is forked. `$fh` can contain the 153 | example hash below or a subset: 154 | 155 | $fh = { 156 | stderr_read => $pipe_fh_w_or_pty_object, 157 | stderr_read => $stderr_fh_r, 158 | stdin_read => $pipe_fh_r, 159 | stdin_write => $pipe_fh_r_or_pty_object, 160 | stdin_write => $stderr_fh_w, 161 | stdout_read => $pipe_fh_w_or_pty_object, 162 | stdout_read => $stderr_fh_r, 163 | stdout_write => $pipe_fh_w, 164 | }; 165 | 166 | ## read 167 | 168 | $rwf->on(read => sub ($rwf, $buf) { ... }); 169 | 170 | Emitted when the child has written a chunk of data to STDOUT or STDERR, and 171 | neither "stderr" nor "stdout" is set in the ["conduit"](#conduit). 172 | 173 | ## spawn 174 | 175 | $rwf->on(spawn => sub ($rwf) { ... }); 176 | 177 | Emitted after `fork()` has been called. Note that the child process might not yet have 178 | been started. The order of things is impossible to say, but it's something like this: 179 | 180 | .------. 181 | | fork | 182 | '------' 183 | | 184 | ___/ \_______________ 185 | | | 186 | | (parent) | (child) 187 | .--------------. | 188 | | emit "spawn" | .--------------------. 189 | '--------------' | set up filehandles | 190 | '--------------------' 191 | | 192 | .---------------. 193 | | exec $program | 194 | '---------------' 195 | 196 | See also ["pid"](#pid) for example usage of this event. 197 | 198 | ## stderr 199 | 200 | $rwf->on(stderr => sub ($rwf, $buf) { ... }); 201 | 202 | Emitted when the child has written a chunk of data to STDERR and ["conduit"](#conduit) 203 | has the "stderr" key set to a true value or "type" is set to "pty3". 204 | 205 | ## stdout 206 | 207 | $rwf->on(stdout => sub ($rwf, $buf) { ... }); 208 | 209 | Emitted when the child has written a chunk of data to STDOUT and ["conduit"](#conduit) 210 | has the "stdout" key set to a true value or "type" is set to "pty3". 211 | 212 | # ATTRIBUTES 213 | 214 | ## conduit 215 | 216 | $hash = $rwf->conduit; 217 | $rwf = $rwf->conduit(\%options); 218 | 219 | Used to set the conduit options. Possible values are: 220 | 221 | - clone\_winsize\_from 222 | 223 | See ["clone\_winsize\_from" in IO::Pty](https://metacpan.org/pod/IO%3A%3APty#clone_winsize_from). This only makes sense if ["conduit"](#conduit) is set 224 | to "pty". This can also be specified by using the ["conduit"](#conduit) attribute. 225 | 226 | - raw 227 | 228 | See ["set\_raw" in IO::Pty](https://metacpan.org/pod/IO%3A%3APty#set_raw). This only makes sense if ["conduit"](#conduit) is set to "pty". 229 | This can also be specified by using the ["conduit"](#conduit) attribute. 230 | 231 | - stderr 232 | 233 | This will make [Mojo::IOLoop::ReadWriteFork](https://metacpan.org/pod/Mojo%3A%3AIOLoop%3A%3AReadWriteFork) emit "stderr" events, instead of 234 | "read" events. Setting this to "0" will close STDERR in the child. 235 | 236 | - stdout 237 | 238 | This will make [Mojo::IOLoop::ReadWriteFork](https://metacpan.org/pod/Mojo%3A%3AIOLoop%3A%3AReadWriteFork) emit "stdout" events, instead of 239 | "read" events. Setting this to "0" will close STDOUT in the child. 240 | 241 | - type 242 | 243 | "type" can be either "pipe", "pty" or "pty3". Default value is "pipe". 244 | 245 | See also ["Conduits"](#conduits) 246 | 247 | ## ioloop 248 | 249 | $ioloop = $rwf->ioloop; 250 | $rwf = $rwf->ioloop(Mojo::IOLoop->singleton); 251 | 252 | Holds a [Mojo::IOLoop](https://metacpan.org/pod/Mojo%3A%3AIOLoop) object. 253 | 254 | ## pid 255 | 256 | $int = $rwf->pid; 257 | 258 | Holds the child process ID. Note that ["start"](#start) will start the process after 259 | the IO loop is started. This means that the code below will not work: 260 | 261 | $rwf->run("bash", -c => q(echo $YIKES foo bar baz)); 262 | warn $rwf->pid; # pid() is not yet set 263 | 264 | This will work though: 265 | 266 | $rwf->on(fork => sub ($rwf) { warn $rwf->pid }); 267 | $rwf->run('bash', -c => q(echo $YIKES foo bar baz)); 268 | 269 | # METHODS 270 | 271 | ## close 272 | 273 | $rwf = $rwf->close('stdin'); 274 | 275 | Close STDIN stream to the child process immediately. 276 | 277 | ## run 278 | 279 | $rwf = $rwf->run($program, @program_args); 280 | $rwf = $rwf->run(\&Some::Perl::function, @function_args); 281 | 282 | Simpler version of ["start"](#start). Can either start an application or run a perl 283 | function. 284 | 285 | ## run\_and\_capture\_p 286 | 287 | $p = $rwf->run_and_capture_p(...)->then(sub { my $asset = shift }); 288 | 289 | ["run\_and\_capture\_p"](#run_and_capture_p) takes the same arguments as ["run\_p"](#run_p), but the 290 | fullfillment callback will receive a [Mojo::Asset](https://metacpan.org/pod/Mojo%3A%3AAsset) object that holds the 291 | output from the command. 292 | 293 | See also the ["asset"](#asset) event. 294 | 295 | ## run\_p 296 | 297 | $p = $rwf->run_p($program, @program_args); 298 | $p = $rwf->run_p(\&Some::Perl::function, @function_args); 299 | 300 | Promise based version of ["run"](#run). The [Mojo::Promise](https://metacpan.org/pod/Mojo%3A%3APromise) will be resolved on 301 | ["finish"](#finish) and rejected on ["error"](#error). 302 | 303 | ## start 304 | 305 | $rwf = $rwf->start(\%args); 306 | 307 | Used to fork and exec a child process. `%args` can have: 308 | 309 | - program 310 | 311 | Either an application or a CODE ref. 312 | 313 | - program\_args 314 | 315 | A list of options passed on to ["program"](#program) or as input to the CODE ref. 316 | 317 | Note that this module will start ["program"](#program) with this code: 318 | 319 | exec $program, @$program_args; 320 | 321 | This means that the code is subject for 322 | [shell injection](https://en.wikipedia.org/wiki/Code_injection#Shell_injection) 323 | unless invoked with more than one argument. This is considered a feature, but 324 | something you should be avare of. See also ["exec" in perlfunc](https://metacpan.org/pod/perlfunc#exec) for more details. 325 | 326 | - env 327 | 328 | Passing in `env` will override the default set of environment variables, 329 | stored in `%ENV`. 330 | 331 | ## write 332 | 333 | $rwf = $rwf->write($chunk); 334 | $rwf = $rwf->write($chunk, $cb); 335 | 336 | Used to write data to the child process STDIN. An optional callback will be 337 | called once the `$chunk` is written. 338 | 339 | Example: 340 | 341 | $rwf->write("some data\n", sub ($rwf) { $rwf->close }); 342 | 343 | ## kill 344 | 345 | $bool = $rwf->kill; 346 | $bool = $rwf->kill(15); # default 347 | 348 | Used to signal the child. 349 | 350 | # SEE ALSO 351 | 352 | [Mojo::IOLoop::ForkCall](https://metacpan.org/pod/Mojo%3A%3AIOLoop%3A%3AForkCall). 353 | 354 | [https://github.com/jhthorsen/mojo-ioloop-readwritefork/tree/master/examples/tail.pl](https://github.com/jhthorsen/mojo-ioloop-readwritefork/tree/master/examples/tail.pl) 355 | 356 | # COPYRIGHT AND LICENSE 357 | 358 | Copyright (C) 2013-2016, Jan Henning Thorsen 359 | 360 | This program is free software, you can redistribute it and/or modify it under 361 | the terms of the Artistic License version 2.0. 362 | 363 | # AUTHOR 364 | 365 | Jan Henning Thorsen - `jhthorsen@cpan.org` 366 | -------------------------------------------------------------------------------- /cpanfile: -------------------------------------------------------------------------------- 1 | # You can install this projct with curl -L http://cpanmin.us | perl - https://github.com/jhthorsen/mojo-ioloop-readwritefork/archive/master.tar.gz 2 | requires "IO::Pty" => "1.16"; 3 | requires "IO::Socket::IP" => "0.37"; 4 | requires "Mojolicious" => "8.25"; 5 | requires "Sub::Util" => "1.41"; 6 | 7 | test_requires "Test::More" => "0.88"; 8 | -------------------------------------------------------------------------------- /examples/rwf.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use Applify; 3 | use Mojo::IOLoop::ReadWriteFork; 4 | 5 | option bool => flush => 'Flush response to screen as soon as possible'; 6 | 7 | documentation __FILE__; 8 | version 'Mojo::IOLoop::ReadWriteFork'; 9 | 10 | app { 11 | my ($self, $command, @hosts) = @_; 12 | my (@p, @rwf); 13 | 14 | for my $host (@hosts) { 15 | my $rwf = Mojo::IOLoop::ReadWriteFork->new; 16 | my $buf = ''; 17 | 18 | if ($self->flush) { 19 | $rwf->on( 20 | read => sub { 21 | $buf .= $_[1]; 22 | print "$host: $1\n" while $buf =~ s!^(.*)[\n\r]!!m; 23 | } 24 | ); 25 | } 26 | else { 27 | $rwf->on(read => sub { $buf .= $_[1] }); 28 | } 29 | 30 | $rwf->on( 31 | close => sub { 32 | my ($rwf, $exit_value, $signal) = @_; 33 | return warn "Could not execute $command: $exit_value" if $exit_value; 34 | warn "--- $host\n" unless $self->flush; 35 | $buf =~ s!\n$!!; 36 | print $self->flush ? "$host: $buf\n" : "$buf\n" if length $buf; 37 | } 38 | ); 39 | 40 | push @p, $rwf->run_p(ssh => $host => $command); 41 | push @rwf, $rwf; 42 | warn "+++ ssh $host $command\n"; 43 | } 44 | 45 | Mojo::Promise->all(@p)->wait; 46 | 47 | return 0; 48 | }; 49 | 50 | =head1 NAME 51 | 52 | rwf.pl - Example for running commands on multiple hosts 53 | 54 | =head1 SYNOPSIS 55 | 56 | $ rwf.pl [command] [server] ... 57 | $ rwf.pl "ls -l /" some.server.com example2.org localhost 58 | 59 | =head1 AUTHOR 60 | 61 | Jan Henning Thorsen - jhthorsen@cpan.org 62 | 63 | =cut 64 | -------------------------------------------------------------------------------- /examples/sshp.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use Term::ANSIColor ':constants'; 3 | use Applify; 4 | use Mojo::IOLoop::ReadWriteFork; 5 | 6 | option bool => color => 'Force coloring of host names', aliases => ['c']; 7 | 8 | app { 9 | my ($self, $command, @hosts) = @_; 10 | my @color = ($self->color or -t STDOUT) ? (RED, CLEAR) : ('', ''); 11 | my (@forks, @p); 12 | 13 | die "Usage: $0 [command] [host0] [host1] ...\n" unless $command and @hosts; 14 | 15 | for my $host (@hosts) { 16 | my $f = Mojo::IOLoop::ReadWriteFork->new; 17 | my $buf = ''; 18 | 19 | $f->on( 20 | read => sub { 21 | $buf .= $_[1]; 22 | local $| = 1; 23 | printf "%s[%s]%s %s", $color[0], $host, $color[1], $1 while $buf =~ s!([^\r\n]*[\r\n]+)!!s; 24 | } 25 | ); 26 | 27 | push @p, $f->run_p(ssh => $host => $command); 28 | } 29 | 30 | Mojo::Promise->all(@p)->wait; 31 | 32 | return 0; 33 | }; 34 | -------------------------------------------------------------------------------- /examples/sshpass: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use Mojo::Base -strict; 3 | 4 | use IO::Handle; 5 | use Mojo::IOLoop::ReadWriteFork; 6 | use Mojo::Util qw(getopt); 7 | use Term::ReadKey qw(ReadMode); 8 | 9 | my $password; 10 | getopt('f=s' => \&read_password_from_file, 'e' => \&read_password_from_env); 11 | abort("Can't start without valid -e or -f ") unless $password; 12 | run_program(@ARGV); 13 | 14 | sub abort { warn "$_[0]\n"; exit($! || 1) } 15 | sub read_password_from_env { $password = $ENV{SSHPASS} } 16 | 17 | sub read_password_from_file { 18 | my ($name, $file) = @_; 19 | open my $FH, '<', $file or abort("Can't read $file: $!"); 20 | $password = readline $FH; 21 | chomp $password; 22 | } 23 | 24 | sub run_program { 25 | my @program = @_; 26 | my $rwf = Mojo::IOLoop::ReadWriteFork->new->conduit({clone_winsize_from => \*STDIN, type => 'pty3'}); 27 | 28 | STDIN->binmode; 29 | my $stdin = Mojo::IOLoop::Stream->new(\*STDIN); 30 | $rwf->ioloop->stream($stdin); 31 | $stdin->on(error => sub { abort($_[1]) }); 32 | $stdin->on(read => sub { $rwf->write($_[1]) }); 33 | $rwf->once(stdout => sub { ReadMode 5 }); 34 | 35 | $rwf->on(error => sub { abort($_[1]) }); 36 | $rwf->on(pty => \&write_password); 37 | $rwf->on(stderr => \&rwf_stderr); 38 | $rwf->on(stdout => \&rwf_stdout); 39 | $rwf->run_p(@program)->catch(sub { warn @_ })->wait; 40 | } 41 | 42 | sub rwf_stderr { STDERR->binmode; STDERR->syswrite($_[1]) } 43 | sub rwf_stdout { STDOUT->binmode; STDOUT->syswrite($_[1]) } 44 | 45 | sub write_password { 46 | my ($rwf, $chunk) = @_; 47 | return unless $chunk =~ m![Pp]assword:!; 48 | 49 | state $seen_password = 0; 50 | abort("Can't retry same password") if $seen_password++; 51 | $rwf->write("$password\n"); 52 | } 53 | 54 | END { ReadMode 0 } 55 | -------------------------------------------------------------------------------- /examples/tail.pl: -------------------------------------------------------------------------------- 1 | use Mojolicious::Lite; 2 | use Mojo::IOLoop::ReadWriteFork; 3 | 4 | # NOTE! 5 | # THIS APPLICATION IS A BAD IDEA. 6 | # IT SHOULD ONLY SERVE AS AN EXAMPLE. 7 | 8 | get '/tail/:name', sub { 9 | my $self = shift->render_later; 10 | my $file = '/var/log/' . $self->stash('name'); 11 | my $rwf = Mojo::IOLoop::ReadWriteFork->new; 12 | 13 | # The request will end after 15 seconds of inactivity. 14 | # The line below can be used to increase that timeout, 15 | # but it is required to make sure we don't run the 16 | # "tail" process forever. 17 | # Mojo::IOLoop->stream($self->tx->connection)->timeout(60); 18 | 19 | # Make sure the object does not go out of scope 20 | $self->stash(rwf => $rwf); 21 | 22 | $self->write_chunk("# tail -f $file\n"); 23 | 24 | # Make sure we kill "tail" after the request is finished 25 | # NOTE: This code might be to simple 26 | $self->on( 27 | finish => sub { 28 | my $self = shift; 29 | my $rwf = $self->stash('rwf') or return; 30 | app->log->debug("Ending tail process"); 31 | $rwf->kill; 32 | } 33 | ); 34 | 35 | # Write data from "tail" directly to browser 36 | $rwf->on( 37 | read => sub { 38 | my ($rwf, $buffer) = @_; 39 | $self->write_chunk($buffer); 40 | } 41 | ); 42 | 43 | # Start the tail program. 44 | # "-n50" is just to make sure we have enough data to make the browser 45 | # display anything. It should work just fine from curl, Mojo::UserAgent, 46 | # ..., but from chrome, ie, ... we need a big chunk of data before it 47 | # gets visible. 48 | $rwf->start(program => 'tail', program_args => ['-f', '-n50', $file]); 49 | }; 50 | 51 | app->start; 52 | -------------------------------------------------------------------------------- /lib/Mojo/IOLoop/ReadWriteFork.pm: -------------------------------------------------------------------------------- 1 | package Mojo::IOLoop::ReadWriteFork; 2 | use Mojo::Base 'Mojo::EventEmitter'; 3 | 4 | use Errno qw(EAGAIN ECONNRESET EINTR EPIPE EWOULDBLOCK EIO); 5 | use IO::Handle; 6 | use IO::Pty; 7 | use Mojo::Asset::Memory; 8 | use Mojo::IOLoop; 9 | use Mojo::IOLoop::Stream; 10 | use Mojo::IOLoop::ReadWriteFork::SIGCHLD; 11 | use Mojo::Promise; 12 | use Mojo::Util qw(term_escape); 13 | use Scalar::Util qw(blessed); 14 | 15 | use constant CHUNK_SIZE => $ENV{MOJO_CHUNK_SIZE} || 131072; 16 | use constant DEBUG => $ENV{MOJO_READWRITEFORK_DEBUG} && 1; 17 | 18 | our $VERSION = '2.02'; 19 | 20 | our @SAFE_SIG 21 | = grep { !m!^(NUM\d+|__[A-Z0-9]+__|ALL|CATCHALL|DEFER|HOLD|IGNORE|MAX|PAUSE|RTMAX|RTMIN|SEGV|SETS)$! } keys %SIG; 22 | 23 | my $SIGCHLD = Mojo::IOLoop::ReadWriteFork::SIGCHLD->singleton; 24 | 25 | has conduit => sub { +{type => 'pipe'} }; 26 | sub pid { shift->{pid} || 0; } 27 | has ioloop => sub { Mojo::IOLoop->singleton }, weak => 1; 28 | 29 | sub close { 30 | my $self = shift; 31 | my $fh = delete $self->{stdin_write} or return $self; 32 | 33 | if (blessed $fh and $fh->isa('IO::Pty')) { 34 | for my $name (qw(pty stdout)) { 35 | my $stream = $self->{stream}{$name} && $self->ioloop->stream($self->{stream}{$name}); 36 | $stream->close if $stream and $stream->handle eq $fh; 37 | } 38 | } 39 | 40 | if (!$fh->close) { 41 | $self->emit(error => $!); 42 | } 43 | 44 | return $self; 45 | } 46 | 47 | sub kill { 48 | my $self = shift; 49 | my $signal = shift // 15; 50 | return undef unless my $pid = $self->{pid}; 51 | $self->_d("kill $signal $pid") if DEBUG; 52 | return kill $signal, $pid; 53 | } 54 | 55 | sub run { 56 | my $args = ref $_[-1] eq 'HASH' ? pop : {}; 57 | my ($self, $program, @program_args) = @_; 58 | return $self->start({%$args, program => $program, program_args => \@program_args}); 59 | } 60 | 61 | sub run_and_capture_p { 62 | my $self = shift; 63 | my $asset = Mojo::Asset::Memory->new(auto_upgrade => 1); 64 | my $read_event = $self->conduit->{stdout} ? 'stdout' : 'read'; 65 | my $read_cb = $self->on($read_event => sub { $asset->add_chunk($_[1]) }); 66 | $asset->once(upgrade => sub { $asset = $_[1]; $self->emit(asset => $asset) }); 67 | return $self->emit(asset => $asset)->run_p(@_)->then(sub {$asset}) 68 | ->finally(sub { $self->unsubscribe($read_event => $read_cb) }); 69 | } 70 | 71 | sub run_p { 72 | my $self = shift; 73 | my $p = Mojo::Promise->new; 74 | my @cb; 75 | push @cb, $self->once(error => sub { shift->unsubscribe(finish => $cb[1]); $p->reject(@_) }); 76 | push @cb, $self->once(finish => sub { shift->unsubscribe(error => $cb[0]); $p->resolve(@_) }); 77 | $self->run(@_); 78 | return $p; 79 | } 80 | 81 | sub start { 82 | my $self = shift; 83 | my $args = ref $_[0] ? $_[0] : {@_}; 84 | my $conduit = $self->conduit; 85 | 86 | $args->{$_} //= $conduit->{$_} for keys %$conduit; 87 | $args->{conduit} ||= delete $args->{type}; 88 | $args->{env} ||= {%ENV}; 89 | $self->{errno} = 0; 90 | $args->{program} or die 'program is required input'; 91 | $self->ioloop->next_tick(sub { $self->_start($args) }); 92 | return $self; 93 | } 94 | 95 | sub write { 96 | my ($self, $chunk, $cb) = @_; 97 | $self->once(drain => $cb) if $cb; 98 | $self->{stdin_buffer} .= $chunk; 99 | $self->_write if $self->{stdin_write}; 100 | return $self; 101 | } 102 | 103 | sub _d { warn "-- [$_[0]->{pid}] $_[1]\n" } 104 | 105 | sub _error { 106 | return if $! == EAGAIN || $! == EINTR || $! == EWOULDBLOCK; 107 | return $_[0]->kill if $! == ECONNRESET || $! == EPIPE; 108 | return $_[0]->emit(error => $!)->kill; 109 | } 110 | 111 | sub _maybe_terminate { 112 | my ($self, $pending_event) = @_; 113 | delete $self->{$pending_event}; 114 | return if $self->{wait_eof} or $self->{wait_sigchld}; 115 | 116 | delete $self->{stdin_write}; 117 | delete $self->{stdout_read}; 118 | delete $self->{stderr_read}; 119 | 120 | my @errors; 121 | for my $cb (@{$self->subscribers('close')}, @{$self->subscribers('finish')}) { 122 | push @errors, $@ unless eval { $self->$cb(@$self{qw(exit_value signal)}); 1 }; 123 | } 124 | 125 | $self->emit(error => $_) for @errors; 126 | } 127 | 128 | sub _pipe { 129 | my $self = shift; 130 | pipe my $read, my $write or return $self->emit(error => "pipe: $!"); 131 | $write->autoflush(1); 132 | return $read, $write; 133 | } 134 | 135 | sub _sigchld { 136 | my ($self, $status, $pid) = @_; 137 | my ($exit_value, $signal) = ($status >> 8, $status & 127); 138 | $self->_d("Exit exit_value=$exit_value, signal=$signal") if DEBUG; 139 | @$self{qw(exit_value signal)} = ($exit_value, $signal); 140 | $self->_maybe_terminate('wait_sigchld'); 141 | } 142 | 143 | sub _start { 144 | my ($self, $args) = @_; 145 | my %fh; 146 | 147 | if ($args->{conduit} eq 'pipe') { 148 | @fh{qw(stdin_read stdin_write)} = $self->_pipe; 149 | @fh{qw(stdout_read stdout_write)} = $self->_pipe; 150 | } 151 | elsif ($args->{conduit} eq 'pty') { 152 | $fh{stdin_write} = $fh{stdout_read} = IO::Pty->new; 153 | } 154 | elsif ($args->{conduit} eq 'pty3') { 155 | $args->{$_} //= 1 for qw(stdin stdout stderr); 156 | @fh{stdin_write} = IO::Pty->new; 157 | @fh{qw(stdout_read stdout_write)} = $self->_pipe; 158 | } 159 | else { 160 | warn "[RWF] Invalid conduit ($args->{conduit})\n" if DEBUG; 161 | return $self->emit(error => "Invalid conduit ($args->{conduit})"); 162 | } 163 | 164 | @fh{qw(stderr_read stderr_write)} = $self->_pipe if $args->{stderr}; 165 | 166 | $self->emit(before_fork => \%fh); # LEGACY 167 | $self->emit(prepare => \%fh); 168 | 169 | return $self->emit(error => "Couldn't fork ($!)") unless defined($self->{pid} = fork); 170 | return $self->{pid} ? $self->_start_parent($args, \%fh) : $self->_start_child($args, \%fh); 171 | } 172 | 173 | sub _start_child { 174 | my ($self, $args, $fh) = @_; 175 | 176 | if (my $pty = blessed $fh->{stdin_write} && $fh->{stdin_write}->isa('IO::Pty') && $fh->{stdin_write}) { 177 | $pty->make_slave_controlling_terminal; 178 | $fh->{stdin_read} = $pty->slave; 179 | $fh->{stdin_read}->set_raw if $args->{raw}; 180 | $fh->{stdin_read}->clone_winsize_from($args->{clone_winsize_from}) if $args->{clone_winsize_from}; 181 | $fh->{stdout_write} ||= $fh->{stdin_read}; 182 | } 183 | 184 | my $stdout_no = ($args->{stdout} // 1) && fileno($fh->{stdout_write}); 185 | my $stderr_no = ($args->{stderr} // 1) && fileno($fh->{stderr_write} || $fh->{stdout_write}); 186 | open STDIN, '<&' . fileno($fh->{stdin_read}) or die $!; 187 | open STDOUT, '>&' . $stdout_no or die $! if $stdout_no; 188 | open STDERR, '>&' . $stderr_no or die $! if $stderr_no; 189 | $stdout_no ? STDOUT->autoflush(1) : STDOUT->close; 190 | $stderr_no ? STDERR->autoflush(1) : STDERR->close; 191 | 192 | $fh->{stdin_write}->close; 193 | $fh->{stdout_read}->close; 194 | $fh->{stderr_read}->close if $fh->{stderr_read}; 195 | 196 | %ENV = %{$args->{env}}; 197 | 198 | my $errno; 199 | if (ref $args->{program} eq 'CODE') { 200 | $! = 0; 201 | @SIG{@SAFE_SIG} = ('DEFAULT') x @SAFE_SIG; 202 | eval { $args->{program}->(@{$args->{program_args} || []}); }; 203 | $errno = $@ ? 255 : $!; 204 | print STDERR $@ if length $@; 205 | } 206 | else { 207 | exec $args->{program}, @{$args->{program_args} || []}; 208 | } 209 | 210 | eval { POSIX::_exit($errno // $!); }; 211 | die($errno // $!); 212 | } 213 | 214 | sub _start_parent { 215 | my ($self, $args, $fh) = @_; 216 | 217 | $self->_d("Forked $args->{program} @{$args->{program_args} || []}") if DEBUG; 218 | @$self{qw(stdin_write stdout_read stderr_read)} = @$fh{qw(stdin_write stdout_read stderr_read)}; 219 | @$self{qw(wait_eof wait_sigchld)} = (1, 1); 220 | 221 | $fh->{stdin_write}->close_slave if blessed $fh->{stdin_write} and $fh->{stdin_write}->isa('IO::Pty'); 222 | $self->{stream}{pty} = $self->_stream(pty => $fh->{stdin_write}) if $args->{conduit} eq 'pty3'; 223 | $self->{stream}{stderr} = $self->_stream(stderr => $fh->{stderr_read}) if $fh->{stderr_read}; 224 | $self->{stream}{stdout} = $self->_stream(stdout => $fh->{stdout_read}) if !$fh->{stderr_read} or $args->{stdout}; 225 | 226 | $SIGCHLD->waitpid($self->{pid} => sub { $self->_sigchld(@_) }); 227 | $self->emit('fork'); # LEGACY 228 | $self->emit('spawn'); 229 | $self->_write; 230 | } 231 | 232 | sub _stream { 233 | my ($self, $conduit, $handle) = @_; 234 | my $stream = Mojo::IOLoop::Stream->new($handle)->timeout(0); 235 | 236 | my $event_name = $self->{stderr_read} ? $conduit : 'read'; 237 | my $read_cb = sub { 238 | $self->_d(sprintf ">>> RWF:%s ($event_name)\n%s", uc $conduit, term_escape $_[1]) if DEBUG; 239 | $self->emit($event_name => $_[1]); 240 | }; 241 | 242 | $stream->on(error => sub { $! != EIO && $self->emit(error => "Read error: $_[1]") }); 243 | $stream->on(close => sub { $self->_maybe_terminate('wait_eof') }); 244 | $stream->on(read => $read_cb); 245 | 246 | return $self->ioloop->stream($stream); 247 | } 248 | 249 | sub _write { 250 | my $self = shift; 251 | return unless length $self->{stdin_buffer}; 252 | 253 | my $stdin_write = $self->{stdin_write}; 254 | my $written = $stdin_write->syswrite($self->{stdin_buffer}); 255 | return $self->_error unless defined $written; 256 | 257 | my $chunk = substr $self->{stdin_buffer}, 0, $written, ''; 258 | $self->_d(sprintf "<<< RWF:STDIN\n%s", term_escape $chunk) if DEBUG; 259 | 260 | if (length $self->{stdin_buffer}) { 261 | 262 | # This is one ugly hack because it does not seem like IO::Pty play 263 | # nice with Mojo::Reactor(::EV) ->io(...) and ->watch(...) 264 | $self->ioloop->timer(0.01 => sub { $self and $self->_write }); 265 | } 266 | else { 267 | $self->emit('drain'); 268 | } 269 | } 270 | 271 | 1; 272 | 273 | =encoding utf8 274 | 275 | =head1 NAME 276 | 277 | Mojo::IOLoop::ReadWriteFork - Fork a process and read/write from it 278 | 279 | =head1 VERSION 280 | 281 | 2.02 282 | 283 | =head1 SYNOPSIS 284 | 285 | use Mojo::Base -strict, -signatures; 286 | my $rwf = Mojo::IOLoop::ReadWriteFork->new; 287 | 288 | # Emitted if something terrible happens 289 | $rwf->on(error => sub ($rwf, $error) { warn $error }); 290 | 291 | # Emitted when the child completes 292 | $rwf->on(finish => sub ($rwf, $exit_value, $signal) { Mojo::IOLoop->stop; }); 293 | 294 | # Emitted when the child prints to STDOUT or STDERR 295 | $rwf->on(read => sub ($rwf, $buf) { print qq(Child process sent us "$buf") }); 296 | 297 | # Need to set "conduit" for bash, ssh, and other programs that require a pty 298 | $rwf->conduit({type => 'pty'}); 299 | 300 | # Start the application 301 | $rwf->run('bash', -c => q(echo $YIKES foo bar baz)); 302 | 303 | # Using promises 304 | $rwf->on(read => sub ($rwf, $buf) { ... }); 305 | $rwf->run_p('bash', -c => q(echo $YIKES foo bar baz))->wait; 306 | 307 | See also 308 | L 309 | for an example usage from a L. 310 | 311 | =head1 DESCRIPTION 312 | 313 | L enable you to fork a child process and L 314 | and L data to. You can also L to the child and see 315 | when the process ends. The child process can be an external program (bash, 316 | telnet, ffmpeg, ...) or a CODE block running perl. 317 | 318 | =head2 Conduits 319 | 320 | L can write to STDIN or a L object, and 321 | read from STDOUT or STDERR, depending on the "type" given to L. 322 | 323 | Here is an overview of the different conduits: 324 | 325 | =over 2 326 | 327 | =item * pipe 328 | 329 | The "pipe" type will create a STDIN and a STDOUT conduit using a plain pipe. 330 | Passing in C will also create a seperate pipe for STDERR. 331 | 332 | $rwf->conduit({type => 'pipe'}); 333 | $rwf->conduit({type => 'pipe', stderr => 1}); 334 | $rwf->write('some data'); # write to STDIN 335 | $rwf->on(read => sub { ... }); # STDOUT and STDERR 336 | $rwf->on(stdout => sub { ... }); # STDOUT 337 | $rwf->on(stderr => sub { ... }); # STDERR 338 | 339 | This is useful if you want to run a program like "cat" that simply read/write 340 | from STDIN, STDERR or STDOUT. 341 | 342 | =item * pty 343 | 344 | The "pty" type will create a STDIN and a STDOUT conduit using L. 345 | Passing in "stderr" will also create a seperate pipe for STDERR. 346 | 347 | $rwf->conduit({type => 'pty'}); 348 | $rwf->conduit({type => 'pty', stderr => 1}); 349 | $rwf->write('some data'); # write to STDIN 350 | $rwf->on(read => sub { ... }); # STDOUT and STDERR 351 | $rwf->on(stdout => sub { ... }); # STDOUT 352 | $rwf->on(stderr => sub { ... }); # STDERR 353 | 354 | The difference between "pipe" and "pty" is that a L object will be 355 | used for STDIN and STDOUT instead of a plain pipe. In addition, it is possible 356 | to pass in C and C: 357 | 358 | $rwf->conduit({type => 'pty', clone_winsize_from => \*STDOUT, raw => 1}); 359 | 360 | This is useful if you want to run "bash" or another program that requires a 361 | pseudo terminal. 362 | 363 | =item * pty3 364 | 365 | The "pty3" type will create a STDIN, a STDOUT, a STDERR and a PTY conduit. 366 | 367 | $rwf->conduit({type => 'pty3'}); 368 | $rwf->write('some data'); # write to STDIN/PTY 369 | $rwf->on(pty => sub { ... }); # PTY 370 | $rwf->on(stdout => sub { ... }); # STDOUT 371 | $rwf->on(stderr => sub { ... }); # STDERR 372 | 373 | The difference between "pty" and "pty3" is that there will be a different 374 | L event for bytes coming from the pseudo PTY. This type also supports 375 | "clone_winsize_from" and "raw". 376 | 377 | $rwf->conduit({type => 'pty3', clone_winsize_from => \*STDOUT, raw => 1}); 378 | 379 | This is useful if you want to run "ssh" or another program that sends password 380 | prompts (or other output) on the PTY channel. See 381 | L 382 | for an example application. 383 | 384 | =back 385 | 386 | =head1 EVENTS 387 | 388 | =head2 asset 389 | 390 | $rwf->on(asset => sub ($rwf, $asset) { ... }); 391 | 392 | Emitted at least once when calling L. C<$asset> can be 393 | either a L or L object. 394 | 395 | $rwf->on(asset => sub ($rwf, $asset) { 396 | # $asset->auto_upgrade(1) is set by default 397 | $asset->max_memory_size(1) if $asset->can('max_memory_size'); 398 | }); 399 | 400 | =head2 drain 401 | 402 | $rwf->on(drain => sub ($rwf) { ... }); 403 | 404 | Emitted when the buffer has been written to the sub process. 405 | 406 | =head2 error 407 | 408 | $rwf->on(error => sub ($rwf, $str) { ... }); 409 | 410 | Emitted when when the there is an issue with creating, writing or reading 411 | from the child process. 412 | 413 | =head2 finish 414 | 415 | $rwf->on(finish => sub ($rwf, $exit_value, $signal) { ... }); 416 | 417 | Emitted when the child process exit. 418 | 419 | =head2 prepare 420 | 421 | $rwf->on(prepare => sub ($rwf, $fh) { ... }); 422 | 423 | Emitted right before the child process is forked. C<$fh> can contain the 424 | example hash below or a subset: 425 | 426 | $fh = { 427 | stderr_read => $pipe_fh_w_or_pty_object, 428 | stderr_read => $stderr_fh_r, 429 | stdin_read => $pipe_fh_r, 430 | stdin_write => $pipe_fh_r_or_pty_object, 431 | stdin_write => $stderr_fh_w, 432 | stdout_read => $pipe_fh_w_or_pty_object, 433 | stdout_read => $stderr_fh_r, 434 | stdout_write => $pipe_fh_w, 435 | }; 436 | 437 | =head2 pty 438 | 439 | $rwf->on(pty => sub ($rwf, $buf) { ... }); 440 | 441 | Emitted when the child has written a chunk of data to a pty and L has 442 | "type" set to "pty3". 443 | 444 | =head2 read 445 | 446 | $rwf->on(read => sub ($rwf, $buf) { ... }); 447 | 448 | Emitted when the child has written a chunk of data to STDOUT or STDERR, and 449 | neither "stderr" nor "stdout" is set in the L. 450 | 451 | =head2 spawn 452 | 453 | $rwf->on(spawn => sub ($rwf) { ... }); 454 | 455 | Emitted after C has been called. Note that the child process might not yet have 456 | been started. The order of things is impossible to say, but it's something like this: 457 | 458 | .------. 459 | | fork | 460 | '------' 461 | | 462 | ___/ \_______________ 463 | | | 464 | | (parent) | (child) 465 | .--------------. | 466 | | emit "spawn" | .--------------------. 467 | '--------------' | set up filehandles | 468 | '--------------------' 469 | | 470 | .---------------. 471 | | exec $program | 472 | '---------------' 473 | 474 | See also L for example usage of this event. 475 | 476 | =head2 stderr 477 | 478 | $rwf->on(stderr => sub ($rwf, $buf) { ... }); 479 | 480 | Emitted when the child has written a chunk of data to STDERR and L 481 | has the "stderr" key set to a true value or "type" is set to "pty3". 482 | 483 | =head2 stdout 484 | 485 | $rwf->on(stdout => sub ($rwf, $buf) { ... }); 486 | 487 | Emitted when the child has written a chunk of data to STDOUT and L 488 | has the "stdout" key set to a true value or "type" is set to "pty3". 489 | 490 | =head1 ATTRIBUTES 491 | 492 | =head2 conduit 493 | 494 | $hash = $rwf->conduit; 495 | $rwf = $rwf->conduit(\%options); 496 | 497 | Used to set the conduit options. Possible values are: 498 | 499 | =over 2 500 | 501 | =item * clone_winsize_from 502 | 503 | See L. This only makes sense if L is set 504 | to "pty". This can also be specified by using the L attribute. 505 | 506 | =item * raw 507 | 508 | See L. This only makes sense if L is set to "pty". 509 | This can also be specified by using the L attribute. 510 | 511 | =item * stderr 512 | 513 | This will make L emit "stderr" events, instead of 514 | "read" events. Setting this to "0" will close STDERR in the child. 515 | 516 | =item * stdout 517 | 518 | This will make L emit "stdout" events, instead of 519 | "read" events. Setting this to "0" will close STDOUT in the child. 520 | 521 | =item * type 522 | 523 | "type" can be either "pipe", "pty" or "pty3". Default value is "pipe". 524 | 525 | See also L 526 | 527 | =back 528 | 529 | =head2 ioloop 530 | 531 | $ioloop = $rwf->ioloop; 532 | $rwf = $rwf->ioloop(Mojo::IOLoop->singleton); 533 | 534 | Holds a L object. 535 | 536 | =head2 pid 537 | 538 | $int = $rwf->pid; 539 | 540 | Holds the child process ID. Note that L will start the process after 541 | the IO loop is started. This means that the code below will not work: 542 | 543 | $rwf->run("bash", -c => q(echo $YIKES foo bar baz)); 544 | warn $rwf->pid; # pid() is not yet set 545 | 546 | This will work though: 547 | 548 | $rwf->on(fork => sub ($rwf) { warn $rwf->pid }); 549 | $rwf->run('bash', -c => q(echo $YIKES foo bar baz)); 550 | 551 | =head1 METHODS 552 | 553 | =head2 close 554 | 555 | $rwf = $rwf->close('stdin'); 556 | 557 | Close STDIN stream to the child process immediately. 558 | 559 | =head2 kill 560 | 561 | $bool = $rwf->kill; 562 | $bool = $rwf->kill(15); # default 563 | 564 | Used to signal the child. 565 | 566 | =head2 run 567 | 568 | $rwf = $rwf->run($program, @program_args); 569 | $rwf = $rwf->run(\&Some::Perl::function, @function_args); 570 | 571 | Simpler version of L. Can either start an application or run a perl 572 | function. 573 | 574 | =head2 run_and_capture_p 575 | 576 | $p = $rwf->run_and_capture_p(...)->then(sub { my $asset = shift }); 577 | 578 | L takes the same arguments as L, but the 579 | fullfillment callback will receive a L object that holds the 580 | output from the command. 581 | 582 | See also the L event. 583 | 584 | =head2 run_p 585 | 586 | $p = $rwf->run_p($program, @program_args); 587 | $p = $rwf->run_p(\&Some::Perl::function, @function_args); 588 | 589 | Promise based version of L. The L will be resolved on 590 | L and rejected on L. 591 | 592 | =head2 start 593 | 594 | $rwf = $rwf->start(\%args); 595 | 596 | Used to fork and exec a child process. C<%args> can have: 597 | 598 | =over 2 599 | 600 | =item * program 601 | 602 | Either an application or a CODE ref. 603 | 604 | =item * program_args 605 | 606 | A list of options passed on to L or as input to the CODE ref. 607 | 608 | Note that this module will start L with this code: 609 | 610 | exec $program, @$program_args; 611 | 612 | This means that the code is subject for 613 | L 614 | unless invoked with more than one argument. This is considered a feature, but 615 | something you should be avare of. See also L for more details. 616 | 617 | =item * env 618 | 619 | Passing in C will override the default set of environment variables, 620 | stored in C<%ENV>. 621 | 622 | =back 623 | 624 | =head2 write 625 | 626 | $rwf = $rwf->write($chunk); 627 | $rwf = $rwf->write($chunk, $cb); 628 | 629 | Used to write data to the child process STDIN. An optional callback will be 630 | called once the C<$chunk> is written. 631 | 632 | Example: 633 | 634 | $rwf->write("some data\n", sub ($rwf) { $rwf->close }); 635 | 636 | =head1 SEE ALSO 637 | 638 | L. 639 | 640 | L 641 | 642 | =head1 COPYRIGHT AND LICENSE 643 | 644 | Copyright (C) 2013-2016, Jan Henning Thorsen 645 | 646 | This program is free software, you can redistribute it and/or modify it under 647 | the terms of the Artistic License version 2.0. 648 | 649 | =head1 AUTHOR 650 | 651 | Jan Henning Thorsen - C 652 | 653 | =cut 654 | -------------------------------------------------------------------------------- /lib/Mojo/IOLoop/ReadWriteFork/SIGCHLD.pm: -------------------------------------------------------------------------------- 1 | package Mojo::IOLoop::ReadWriteFork::SIGCHLD; 2 | use Mojo::Base -base; 3 | 4 | use POSIX ':sys_wait_h'; 5 | use Scalar::Util qw(weaken); 6 | 7 | use constant WAIT_PID_INTERVAL => $ENV{WAIT_PID_INTERVAL} || 0.05; 8 | 9 | has pids => sub { +{} }; 10 | 11 | sub is_waiting { 12 | my $self = shift; 13 | return !!(%{$self->pids} || $self->{tid}); 14 | } 15 | 16 | sub singleton { state $singleton = Mojo::IOLoop::ReadWriteFork::SIGCHLD->new } 17 | 18 | sub waitpid { 19 | my ($self, $pid, $cb) = @_; 20 | push @{$self->pids->{$pid}}, $cb; 21 | 22 | # The CHLD test is for code, such as Minion::Command::minion::worker 23 | # where SIGCHLD is set up for manual waitpid() checks. 24 | # See https://github.com/kraih/minion/issues/15 and 25 | # https://github.com/jhthorsen/mojo-ioloop-readwritefork/issues/9 for details. 26 | my $reactor = Mojo::IOLoop->singleton->reactor; 27 | return $self->{ev}{$pid} ||= EV::child($pid, 0, sub { $self->_exit($pid, shift->rstatus) }) 28 | if !$SIG{CHLD} and $reactor->isa('Mojo::Reactor::EV'); 29 | 30 | weaken $self; 31 | $self->{tid} ||= Mojo::IOLoop->recurring( 32 | WAIT_PID_INTERVAL, 33 | sub { 34 | my $ioloop = shift; 35 | my $pids = $self->pids; 36 | return $ioloop->remove(delete $self->{tid}) unless %$pids; 37 | 38 | for my $pid (keys %$pids) { 39 | local ($?, $!); 40 | my $kid = CORE::waitpid($pid, WNOHANG); 41 | $self->_exit($pid, $?) if $kid == $pid or $kid == -1; 42 | } 43 | } 44 | ); 45 | } 46 | 47 | sub _exit { 48 | my ($self, $pid, $status) = @_; 49 | delete $self->{ev}{$pid}; 50 | my $listeners = delete $self->pids->{$pid}; 51 | for my $cb (@$listeners) { $cb->($status, $pid) } 52 | } 53 | 54 | 1; 55 | 56 | =head1 NAME 57 | 58 | Mojo::IOLoop::ReadWriteFork::SIGCHLD - Non-blocking waitpid for Mojolicious 59 | 60 | =head1 DESCRIPTION 61 | 62 | L is a module that can wait for a child 63 | process to exit. This is currently done either with L or a recurring 64 | timer and C. 65 | 66 | =head1 ATTRIBUTES 67 | 68 | $hash_ref = $sigchld->pids; 69 | 70 | Returns a hash ref where the keys are active child process IDs and the values 71 | are array-refs of callbacks passed on to L. 72 | 73 | =head1 METHODS 74 | 75 | =head2 is_waiting 76 | 77 | $bool = $sigchld->is_waiting; 78 | 79 | Returns true if C<$sigchld> is still has a recurring timer or waiting for a 80 | process to exit. 81 | 82 | =head2 singleton 83 | 84 | $sigchld = Mojo::IOLoop::ReadWriteFork::SIGCHLD->singleton; 85 | 86 | Returns a shared L object. 87 | 88 | =head2 waitpid 89 | 90 | $sigchld->waitpid($pid, sub { my ($exit_value) = @_ }); 91 | 92 | Will call the provided callback with C<$?> when the C<$pid> is no longer running. 93 | 94 | =head1 SEE ALSO 95 | 96 | L. 97 | 98 | =cut 99 | -------------------------------------------------------------------------------- /t/00-basic.t: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | use File::Find; 3 | 4 | if (($ENV{HARNESS_PERL_SWITCHES} || '') =~ /Devel::Cover/) { 5 | plan skip_all => 'HARNESS_PERL_SWITCHES =~ /Devel::Cover/'; 6 | } 7 | if (!eval 'use Test::Pod; 1') { 8 | *Test::Pod::pod_file_ok = sub { 9 | SKIP: { skip "pod_file_ok(@_) (Test::Pod is required)", 1 } 10 | }; 11 | } 12 | if (!eval 'use Test::Pod::Coverage; 1') { 13 | *Test::Pod::Coverage::pod_coverage_ok = sub { 14 | SKIP: { skip "pod_coverage_ok(@_) (Test::Pod::Coverage is required)", 1 } 15 | }; 16 | } 17 | if (!eval 'use Test::CPAN::Changes; 1') { 18 | *Test::CPAN::Changes::changes_file_ok = sub { 19 | SKIP: { skip "changes_ok(@_) (Test::CPAN::Changes is required)", 4 } 20 | }; 21 | } 22 | 23 | find({wanted => sub { /\.pm$/ and push @files, $File::Find::name }, no_chdir => 1}, -e 'blib' ? 'blib' : 'lib',); 24 | 25 | plan tests => @files * 3 + 4; 26 | 27 | for my $file (@files) { 28 | my $module = $file; 29 | $module =~ s,\.pm$,,; 30 | $module =~ s,.*/?lib/,,; 31 | $module =~ s,/,::,g; 32 | ok eval "use $module; 1", "use $module" or diag $@; 33 | Test::Pod::pod_file_ok($file); 34 | Test::Pod::Coverage::pod_coverage_ok($module, {also_private => [qr/^[A-Z_]+$/],}); 35 | } 36 | 37 | Test::CPAN::Changes::changes_file_ok(); 38 | -------------------------------------------------------------------------------- /t/close.t: -------------------------------------------------------------------------------- 1 | use Mojo::Base -strict; 2 | use Mojo::IOLoop::ReadWriteFork; 3 | use Test::More; 4 | 5 | plan skip_all => 'bash is missing' unless grep { -x "$_/bash" } split /:/, $ENV{PATH}; 6 | plan skip_all => 'cat is missing' unless grep { -x "$_/cat" } split /:/, $ENV{PATH}; 7 | 8 | subtest 'pipe' => sub { 9 | my $rwf = Mojo::IOLoop::ReadWriteFork->new->conduit({type => 'pipe'}); 10 | my ($err, $exit_value); 11 | $rwf->on(spawn => sub { $rwf->close('stdin') }); 12 | $rwf->run_p(qw(cat -))->then(sub { $exit_value = shift }, sub { $err = shift })->wait; 13 | is $err || $exit_value, 0, 'success'; 14 | }; 15 | 16 | subtest 'pty' => sub { 17 | my $rwf = Mojo::IOLoop::ReadWriteFork->new->conduit({type => 'pty'}); 18 | my ($err, $exit_value); 19 | $rwf->on(spawn => sub { $rwf->close('stdin') }); 20 | $rwf->run_p(qw(bash))->then(sub { $exit_value = shift }, sub { $err = shift })->wait; 21 | is $err || $exit_value, 0, 'success'; 22 | }; 23 | 24 | subtest 'pty3' => sub { 25 | my $rwf = Mojo::IOLoop::ReadWriteFork->new->conduit({type => 'pty3'}); 26 | my ($err, $exit_value); 27 | $rwf->on(spawn => sub { $rwf->close('stdin') }); 28 | $rwf->run_p(qw(bash))->then(sub { $exit_value = shift }, sub { $err = shift })->wait; 29 | is $err || $exit_value, 0, 'success'; 30 | }; 31 | 32 | done_testing; 33 | -------------------------------------------------------------------------------- /t/conduit-pty3.t: -------------------------------------------------------------------------------- 1 | use Mojo::Base -strict; 2 | use Test::More; 3 | use Mojo::File qw(path); 4 | use Mojo::IOLoop::ReadWriteFork; 5 | 6 | plan skip_all => 'READWRITEFORK_SSH=host is not set' unless $ENV{READWRITEFORK_SSH}; 7 | 8 | my $password ||= -e '.readwritefork_ssh_password' ? path('.readwritefork_ssh_password')->slurp : 's3cret'; 9 | chomp $password; 10 | 11 | my @ssh_options = ( 12 | -o => 'IdentitiesOnly=no', 13 | -o => 'NumberOfPasswordPrompts=1', 14 | -o => 'PreferredAuthentications=keyboard-interactive,password' 15 | ); 16 | 17 | my $rwf = Mojo::IOLoop::ReadWriteFork->new->conduit({type => 'pty3'}); 18 | my %out = map { ($_ => '') } qw(pty stderr stdout); 19 | 20 | $rwf->on( 21 | pty => sub { 22 | my ($rwf, $chunk) = @_; 23 | $out{pty} .= $chunk; 24 | $rwf->write("$password\n") if $chunk =~ m![Pp]assword:!; 25 | } 26 | ); 27 | 28 | $rwf->on( 29 | stderr => sub { 30 | my ($rwf, $chunk) = @_; 31 | $out{stderr} .= $chunk; 32 | } 33 | ); 34 | 35 | $rwf->on( 36 | stdout => sub { 37 | my ($rwf, $chunk) = @_; 38 | $out{stdout} .= $chunk; 39 | } 40 | ); 41 | 42 | $rwf->run_p(ssh => @ssh_options, $ENV{READWRITEFORK_SSH}, qw(ls -l /))->wait; 43 | like $out{pty}, qr{password:\s+$}s, 'pty'; 44 | like $out{stdout}, qr{\sroot\s}s, 'stdout'; 45 | is $out{stderr}, '', 'stderr'; 46 | 47 | done_testing; 48 | -------------------------------------------------------------------------------- /t/event-asset.t: -------------------------------------------------------------------------------- 1 | use Mojo::Base -strict; 2 | use Mojo::IOLoop::ReadWriteFork; 3 | use Test::More; 4 | 5 | my $rwf = Mojo::IOLoop::ReadWriteFork->new; 6 | my @assets; 7 | 8 | $rwf->on( 9 | asset => sub { 10 | my ($rwf, $asset) = @_; 11 | $asset->max_memory_size(3) if $asset->can('max_memory_size'); 12 | $rwf->write("line one\n") unless @assets; 13 | push @assets, $asset; 14 | } 15 | ); 16 | 17 | $rwf->once(read => sub { shift->write("line two\n")->close('stdin'); }); 18 | $rwf->run_and_capture_p(sub { print while <> })->then(sub { push @assets, shift })->wait; 19 | 20 | my $path = $assets[-1]->path; 21 | like $assets[-1]->slurp, qr/line one\nline two\n/, 'asset content'; 22 | isa_ok $_, 'Mojo::Asset' for @assets; 23 | is @assets, 3, 'got three assets'; 24 | ok $path, 'got file asset'; 25 | 26 | my %subscribers = map { ($_ => $rwf->subscribers($_)) } qw(error finish read); 27 | is_deeply \%subscribers, {error => [], finish => [], read => []}, 'run_and_capture_p clean up subscribers after run' 28 | or diag explain \%subscribers; 29 | 30 | @assets = (); 31 | ok !-e $path, 'file asset was cleaned up'; 32 | 33 | done_testing; 34 | -------------------------------------------------------------------------------- /t/event-drain.t: -------------------------------------------------------------------------------- 1 | use Mojo::Base -strict; 2 | use Mojo::IOLoop::ReadWriteFork; 3 | use Test::More; 4 | 5 | BEGIN { 6 | eval 'use Test::Memory::Cycle;1' or Mojo::Util::monkey_patch(main => memory_cycle_ok => sub { }); 7 | } 8 | 9 | my $rwf = Mojo::IOLoop::ReadWriteFork->new; 10 | my $drain = 0; 11 | my $output = ''; 12 | 13 | $rwf->on(close => sub { Mojo::IOLoop->stop; }); 14 | $rwf->on(read => sub { $output .= $_[1]; }); 15 | $rwf->write("line one\n", sub { $drain++; }); 16 | $rwf->start( 17 | program => sub { 18 | print sysread STDIN, my $buf, 1024; 19 | print "\n$buf"; 20 | print "line two\n"; 21 | } 22 | ); 23 | 24 | Mojo::IOLoop->timer(3 => sub { Mojo::IOLoop->stop }); # guard 25 | Mojo::IOLoop->start; 26 | memory_cycle_ok $rwf, 'no cycle after run'; 27 | 28 | like $output, qr/^9\nline one\nline two\n/, 'can write() before start()' or diag $output; 29 | is $drain, 1, 'drain callback was called'; 30 | 31 | done_testing; 32 | -------------------------------------------------------------------------------- /t/event-finish.t: -------------------------------------------------------------------------------- 1 | use Mojo::Base -strict; 2 | use Mojo::IOLoop::ReadWriteFork; 3 | use Test::More; 4 | 5 | my $rwf = Mojo::IOLoop::ReadWriteFork->new; 6 | my $output = ''; 7 | 8 | $rwf->on(error => sub { diag "error: @_" }); 9 | $rwf->on(finish => sub { Mojo::IOLoop->stop }); 10 | $rwf->on(read => sub { $output .= $_[1] }); 11 | $rwf->write("line one\nline two\n", sub { shift->close('stdin'); }); 12 | $rwf->run_p(sub { print while <>; print "FORCE\n"; })->wait; 13 | 14 | like $output, qr/line one\nline two\nFORCE\n/, 'finish' or diag $output; 15 | 16 | my ($got_event, $err, @errors) = (0); 17 | $rwf = Mojo::IOLoop::ReadWriteFork->new; 18 | $rwf->on(error => sub { push @errors, $_[1]; die 'yikes!' }); 19 | $rwf->on(finish => sub { Carp::confess('infinite loop') if $got_event++ < 3 }); 20 | $rwf->run_p(sub { })->catch(sub { $err = shift })->wait; 21 | is $got_event, 1, 'avoid infinite loop'; 22 | ok !$err, 'promise fullfills, even if close() and error() fail'; 23 | ok @errors, 'error was emitted'; 24 | 25 | undef $rwf; 26 | 27 | done_testing; 28 | -------------------------------------------------------------------------------- /t/event-legacy.t: -------------------------------------------------------------------------------- 1 | use Mojo::Base -strict; 2 | use Mojo::IOLoop::ReadWriteFork; 3 | use Test::More; 4 | 5 | my $rwf = Mojo::IOLoop::ReadWriteFork->new; 6 | my %events; 7 | 8 | # legacy 9 | $rwf->on(before_fork => sub { $events{before_fork}++ }); 10 | $rwf->on(close => sub { $events{close}++ }); 11 | $rwf->on(fork => sub { $events{fork}++ }); 12 | 13 | # current 14 | $rwf->on(error => sub { $events{error}++ }); 15 | $rwf->on(finish => sub { $events{finish}++ }); 16 | $rwf->on(prepare => sub { $events{prepare}++ }); 17 | $rwf->on(read => sub { $events{read}++ }); 18 | $rwf->on(spawn => sub { $events{spawn}++ }); 19 | 20 | $rwf->write("line one\nline two\n", sub { shift->close('stdin'); }); 21 | $rwf->run_p(sub { print while <>; print "FORCE\n"; })->wait; 22 | 23 | $events{read} = 1 if $events{read}; 24 | is_deeply \%events, {before_fork => 1, close => 1, finish => 1, fork => 1, prepare => 1, read => 1, spawn => 1}, 25 | 'got all events'; 26 | 27 | done_testing; 28 | -------------------------------------------------------------------------------- /t/event-prepare.t: -------------------------------------------------------------------------------- 1 | use Mojo::Base -strict; 2 | use Test::More; 3 | use Mojo::IOLoop::ReadWriteFork; 4 | 5 | plan skip_all => 'READWRITEFORK_SSH=host is not set' unless $ENV{READWRITEFORK_SSH} or -e '.readwritefork_ssh'; 6 | 7 | $ENV{READWRITEFORK_SSH} ||= Mojo::File->new('.readwritefork_ssh')->slurp; 8 | chomp $ENV{READWRITEFORK_SSH}; 9 | 10 | my $columns = int(300 * rand); 11 | my $rwf = Mojo::IOLoop::ReadWriteFork->new; 12 | my (@pipe_names, @pipe_ref); 13 | $rwf->on( 14 | prepare => sub { 15 | my ($rwf, $fh) = @_; 16 | @pipe_names = sort keys %$fh; 17 | @pipe_ref = map { ref $fh->{$_} } @pipe_names; 18 | $fh->{stdout_read}->set_winsize(40, $columns); 19 | } 20 | ); 21 | 22 | my ($stdout, $stderr) = ('', ''); 23 | $rwf->on(stdout => sub { $stdout .= pop }); 24 | $rwf->on(stderr => sub { $stderr .= pop }); 25 | $rwf->conduit({stderr => 1, stdout => 1, type => 'pty'})->run_p(ssh => $ENV{READWRITEFORK_SSH}, -t => q(tput cols)) 26 | ->wait; 27 | 28 | is_deeply \@pipe_names, [qw(stderr_read stderr_write stdin_write stdout_read)], 'pipe names' or diag "@pipe_names"; 29 | is_deeply \@pipe_ref, ['GLOB', 'GLOB', 'IO::Pty', 'IO::Pty'], 'pipe types'; 30 | like $stdout, qr{$columns\r\n}s, 'changed columns'; 31 | like $stderr, qr{closed}, 'stderr'; 32 | 33 | done_testing; 34 | -------------------------------------------------------------------------------- /t/event-stderr-stdout.t: -------------------------------------------------------------------------------- 1 | use Mojo::Base -strict; 2 | use Mojo::IOLoop::ReadWriteFork; 3 | use Test::More; 4 | 5 | subtest 'stderr=1' => sub { 6 | my ($rwf, $stdout, $stderr) = rwf(); 7 | $rwf->conduit->{stderr} = 1; 8 | $rwf->run_p(\&run_cb)->wait; 9 | is $$stdout, '', 'stdout closed'; 10 | like $$stderr, qr{Not cool}, 'stderr'; 11 | }; 12 | 13 | subtest 'stderr=1, stdout=1' => sub { 14 | my ($rwf, $stdout, $stderr) = rwf(); 15 | $rwf->conduit->{stderr} = 1; 16 | $rwf->conduit->{stdout} = 1; 17 | $rwf->run_p(\&run_cb)->wait; 18 | is $$stdout, "cool beans\n", 'stdout'; 19 | like $$stderr, qr{Not cool}, 'stderr'; 20 | }; 21 | 22 | done_testing; 23 | 24 | sub run_cb { 25 | print STDOUT "cool beans\n"; 26 | die 'Not cool'; 27 | } 28 | 29 | sub rwf { 30 | my $rwf = Mojo::IOLoop::ReadWriteFork->new; 31 | my ($stdout, $stderr) = ('', ''); 32 | $rwf->on(stderr => sub { $stderr .= $_[1] }); 33 | $rwf->on(stdout => sub { $stdout .= $_[1] }); 34 | 35 | return $rwf, \$stdout, \$stderr; 36 | } 37 | -------------------------------------------------------------------------------- /t/lsof.t: -------------------------------------------------------------------------------- 1 | BEGIN { $ENV{MOJO_REACTOR} = 'Mojo::Reactor::Poll' } 2 | use Mojo::Base -strict; 3 | use Mojo::IOLoop::ReadWriteFork; 4 | use Test::Mojo; 5 | use Test::More; 6 | 7 | plan skip_all => 'TEST_LSOF=1' unless $ENV{TEST_LSOF}; 8 | 9 | eval 'use Test::Memory::Cycle;1' or Mojo::Util::monkey_patch(main => memory_cycle_ok => sub { }); 10 | 11 | my %tests = (pipe => 3, pty => 2, pty3 => 3); 12 | my $initial = lsof(); 13 | 14 | for my $type (sort keys %tests) { 15 | is lsof(), $initial, "$type before"; 16 | my $rwf = Mojo::IOLoop::ReadWriteFork->new(conduit => {stderr => 1, stdout => 1, type => $type}); 17 | my ($asset, $err); 18 | $rwf->on(stderr => sub { note "[ERR] $_[1]" }); 19 | $rwf->run_and_capture_p(sub { print lsof() })->then(sub { $asset = shift })->catch(sub { $err = shift })->wait; 20 | last unless is $err, undef, "$type success"; 21 | last unless is $asset->slurp, $initial + $tests{$type}, "$type run_p"; 22 | is lsof(), $initial, "$type after run"; 23 | undef $rwf; 24 | is lsof(), $initial, "$type after undef"; 25 | memory_cycle_ok($rwf, 'memory cycle after'); 26 | } 27 | 28 | is lsof(), $initial, "all done ($initial)"; 29 | 30 | done_testing; 31 | 32 | sub lsof { 33 | my $n = qx{lsof -p $$ | wc -l}; 34 | return $n =~ m!(\d+)! ? $1 : -1; 35 | } 36 | -------------------------------------------------------------------------------- /t/minion.t: -------------------------------------------------------------------------------- 1 | BEGIN { 2 | use Time::HiRes; 3 | $ENV{MOJO_REACTOR} = 'Mojo::Reactor::EV'; 4 | *Minion::Command::minion::worker::sleep = sub { Time::HiRes::usleep(10e3) }; 5 | } 6 | use Mojo::Base -strict; 7 | use Mojo::IOLoop::ReadWriteFork; 8 | use File::Spec::Functions 'catfile'; 9 | use File::Temp 'tempdir'; 10 | use Test::Mojo; 11 | use Test::More; 12 | use version; 13 | 14 | plan skip_all => 'Minion::Backend::SQLite >=4.001 need to be installed to run this test' 15 | unless eval 16 | 'require Minion::Backend::SQLite; version->parse(Minion::Backend::SQLite->VERSION) >= version->parse(4.001)'; 17 | plan skip_all => 'EV need to be installed to run this test' 18 | unless eval { Mojo::IOLoop->singleton->reactor->isa('Mojo::Reactor::EV') }; 19 | 20 | my $tmpdir = tempdir CLEANUP => 1; 21 | my $file = catfile $tmpdir, 'minion.db'; 22 | my $pid = $$; 23 | 24 | use Mojolicious::Lite; 25 | plugin Minion => {SQLite => "sqlite:$file"}; 26 | app->minion->add_task( 27 | rwf => sub { 28 | my $job = shift; 29 | my $rwf = Mojo::IOLoop::ReadWriteFork->new; 30 | my $exit_code = 0; 31 | 32 | $rwf->on(finish => sub { $exit_code = $_[1]; Mojo::IOLoop->stop; }); 33 | $rwf->run(sub { print "I am $$.\n"; $! = 42; }); 34 | Mojo::IOLoop->start; 35 | $job->finish($exit_code); 36 | } 37 | ); 38 | 39 | # Make $worker->run() return after job is done 40 | app->minion->on( 41 | worker => sub { 42 | pop->on( 43 | dequeue => sub { 44 | pop->on( 45 | finished => sub { 46 | diag 'Job finished'; 47 | kill TERM => $pid; 48 | } 49 | ); 50 | } 51 | ); 52 | } 53 | ); 54 | 55 | require Minion::Command::minion::worker; 56 | my $worker = Minion::Command::minion::worker->new(app => app); 57 | my $id = $worker->app->minion->enqueue('rwf'); 58 | my $job = $worker->app->minion->job($id) || {}; 59 | 60 | ok $job, 'got rwf job'; 61 | is $job->info->{state}, 'inactive', 'inactive job'; 62 | 63 | $worker->run; 64 | is $job->info->{state}, 'finished', 'finished job'; 65 | is $job->info->{result}, 42, 'exit_code from child'; 66 | 67 | done_testing; 68 | -------------------------------------------------------------------------------- /t/mojolicious-lite-ev.t: -------------------------------------------------------------------------------- 1 | BEGIN { $ENV{MOJO_REACTOR} = 'Mojo::Reactor::EV' } 2 | use Mojo::Base -strict; 3 | use Mojo::IOLoop::ReadWriteFork; 4 | use Test::Mojo; 5 | use Test::More; 6 | 7 | plan skip_all => 'EV need to be installed to run this test' 8 | unless eval { Mojo::IOLoop->singleton->reactor->isa('Mojo::Reactor::EV') }; 9 | 10 | use Mojolicious::Lite; 11 | my @pids; 12 | 13 | get '/' => sub { 14 | my $c = shift->render_later; 15 | my $rwf = Mojo::IOLoop::ReadWriteFork->new; 16 | 17 | my $output = ''; 18 | $rwf->on(read => sub { $output .= $_[1] }); 19 | $rwf->on( 20 | finish => sub { 21 | my ($rwf, $exit_value, $signal) = @_; 22 | push @pids, $rwf->pid; 23 | $c->render(json => {output => $output, exit_value => $exit_value}); 24 | } 25 | ); 26 | 27 | $rwf->run('uptime'); 28 | }; 29 | 30 | my $t = Test::Mojo->new; 31 | $t->get_ok('/')->status_is(200)->json_has('/exit_value') for 1 .. 5; 32 | ok !kill(0, $_), "dead child $_" for @pids; 33 | 34 | done_testing; 35 | -------------------------------------------------------------------------------- /t/mojolicious-lite-poll.t: -------------------------------------------------------------------------------- 1 | BEGIN { $ENV{MOJO_REACTOR} = 'Mojo::Reactor::Poll' } 2 | use Mojo::Base -strict; 3 | use Mojo::IOLoop::ReadWriteFork; 4 | use Test::Mojo; 5 | use Test::More; 6 | 7 | plan skip_all => 'TEST_FH=1 # http://www.cpantesters.org/cpan/report/001a7fac-85d7-11e7-a074-e1beba07c9dd' 8 | unless $ENV{TEST_FH}; 9 | plan skip_all => 'uptime is missing' unless grep { -x "$_/uptime" } split /:/, $ENV{PATH}; 10 | 11 | my ($expected_pty_objects, @pids) = (0); 12 | use IO::Pty; 13 | sub IO::Pty::DESTROY { $expected_pty_objects-- } 14 | 15 | use Mojolicious::Lite; 16 | 17 | get '/' => sub { 18 | my $c = shift->render_later; 19 | my $rwf = Mojo::IOLoop::ReadWriteFork->new(conduit => {type => 'pty'}); 20 | 21 | my $output = ''; 22 | $rwf->on(read => sub { $output .= $_[1] }); 23 | $rwf->on( 24 | finish => sub { 25 | my ($rwf, $exit_value, $signal) = @_; 26 | push @pids, $rwf->pid; 27 | $c->render(json => {output => $output, exit_value => $exit_value}); 28 | } 29 | ); 30 | 31 | $rwf->run('uptime'); 32 | }; 33 | 34 | my $t = Test::Mojo->new; 35 | 36 | $expected_pty_objects++; 37 | $t->get_ok('/')->status_is(200); 38 | my $before = count_fh(); 39 | 40 | $expected_pty_objects++; 41 | $t->get_ok('/')->status_is(200); 42 | is count_fh(), $before, 'second run'; 43 | 44 | $expected_pty_objects++; 45 | $t->get_ok('/')->status_is(200); 46 | is count_fh(), $before, 'third run'; 47 | 48 | is $expected_pty_objects, 0, 'all pty objects has been destroyed'; 49 | ok !kill(0, $_), "dead child $_" for @pids; 50 | 51 | done_testing; 52 | 53 | sub count_fh { 54 | use Scalar::Util 'openhandle'; 55 | return int grep { 56 | open my $fh, '<&=', $_; 57 | openhandle($fh); 58 | } 0 .. 1023; 59 | } 60 | -------------------------------------------------------------------------------- /t/premature-close.t: -------------------------------------------------------------------------------- 1 | use Mojo::Base -strict; 2 | 3 | BEGIN { 4 | $ENV{MOJO_CHUNK_SIZE} = 1; 5 | $ENV{MOJO_REACTOR} = 'Mojo::Reactor::Poll'; 6 | } 7 | 8 | use Mojo::IOLoop::ReadWriteFork; 9 | use Test::Mojo; 10 | use Test::More; 11 | 12 | my ($attempts, $len, $max_loop, $recv) = (0, 4643, $ENV{TEST_MAX_LOOPS} || 20, 0); 13 | Mojo::IOLoop->next_tick(\&start_rwf); 14 | Mojo::IOLoop->start; 15 | 16 | is $recv, $len * $max_loop, 'got all bytes'; 17 | 18 | done_testing; 19 | 20 | sub start_rwf { 21 | Mojo::IOLoop->stop if $attempts++ >= $max_loop; 22 | my $rwf = Mojo::IOLoop::ReadWriteFork->new(conduit => {type => 'pty'}); 23 | my $output = ''; 24 | $rwf->run(sub { printf "%s\n", 'a' x $len; }, {env => {}}); 25 | $rwf->on(read => sub { $output .= $_[1] }); 26 | $rwf->on( 27 | finish => sub { 28 | $output =~ s/\r?\n//g; 29 | $recv += length $output; 30 | Mojo::IOLoop->next_tick(\&start_rwf); 31 | } 32 | ); 33 | } 34 | -------------------------------------------------------------------------------- /t/proc-memory-usage.t: -------------------------------------------------------------------------------- 1 | use Mojo::Base -strict; 2 | use Mojo::IOLoop::ReadWriteFork; 3 | use Test::More; 4 | use Time::HiRes qw(time); 5 | 6 | plan skip_all => "Perl $^V" unless version->parse($^V) > 5.026; 7 | plan skip_all => 'TEST_MEMORY=10' unless $ENV{TEST_MEMORY}; 8 | plan skip_all => "open /proc/$$/statm: $!" unless do { sysopen my $PROC, "/proc/$$/statm", 0 }; 9 | 10 | my @tracked, (get_mem_usage()); 11 | 12 | for (1 .. $ENV{TEST_MEMORY}) { 13 | my $rwf = Mojo::IOLoop::ReadWriteFork->new; 14 | my $output = ''; 15 | $rwf->on(read => sub { $output .= $_[1] }); 16 | $rwf->run_p('dd if=/dev/urandom bs=10M count=1')->wait; 17 | 18 | ok length($output) > 1e6, 'got output'; 19 | sleep 0.2; 20 | push @tracked, get_mem_usage(); 21 | } 22 | 23 | ok !Mojo::IOLoop::ReadWriteFork::SIGCHLD->singleton->is_waiting, 'SIGCHLD is idle'; 24 | 25 | push @tracked, get_mem_usage(); 26 | note sprintf "%4s | %8s | %8s | %8s | %8s\n", '', qw(data rss share vsz); 27 | note sprintf "%4s | %8s | %8s | %8s | %8s\n", @$_ for @tracked; 28 | 29 | local $TODO = 'Seems to fail if TEST_MEMORY < 10' if $ENV{TEST_MEMORY} < 10; 30 | my %same; 31 | $same{$_->[2]}++ for @tracked; 32 | is int(grep { $_ > $ENV{TEST_MEMORY} / 2 } values %same), 1, 'memory usage stabilizes'; 33 | 34 | done_testing; 35 | 36 | sub get_mem_usage { 37 | sysopen my $PROC, "/proc/$$/statm", 0 or die $!; 38 | sysread $PROC, my $proc_info, 255 or die $!; 39 | my ($vsz, $rss, $share, undef, undef, $data, undef) = split /\s+/, $proc_info, 7; 40 | 41 | # Need to to multipled with page_size_in_kb=4 42 | state $i = 0; 43 | return [$i++, map { $_ * 4 } $data, $rss, $share, $vsz]; 44 | } 45 | -------------------------------------------------------------------------------- /t/run-bash.t: -------------------------------------------------------------------------------- 1 | use Mojo::Base -strict; 2 | use Mojo::IOLoop::ReadWriteFork; 3 | use Test::More; 4 | 5 | $ENV{PATH} ||= ''; 6 | plan skip_all => 'bash is missing' unless grep { -x "$_/bash" } split /:/, $ENV{PATH}; 7 | 8 | my $rwf = Mojo::IOLoop::ReadWriteFork->new; 9 | my ($closed, $n, $output) = (0, 0, ''); 10 | 11 | $rwf->on(error => sub { diag $_[1]; $n++ > 20 && exit }); 12 | $rwf->on(finish => sub { $closed++; Mojo::IOLoop->stop }); 13 | 14 | note 'Set $! to test that it does not trigger "error" event'; 15 | $rwf->on(read => sub { $! = 2; $output .= $_[1]; $n++ > 20 && exit }); 16 | 17 | { 18 | local $ENV{YIKES} = 'too cool'; 19 | $rwf->start(program => 'bash', program_args => [-c => 'echo $YIKES foo bar baz'], conduit => 'pty'); 20 | } 21 | 22 | is $rwf->pid, 0, 'no pid' or diag $rwf->pid; 23 | Mojo::IOLoop->timer(3 => sub { Mojo::IOLoop->stop }); # guard 24 | Mojo::IOLoop->start; 25 | like $rwf->pid, qr{^[1-9]\d+$}, 'got pid' or diag $rwf->pid; 26 | like $output, qr/^too cool foo bar baz\W{1,2}$/, 'got stdout from "echo"' or diag $output; 27 | is $closed, 1, 'got close event'; 28 | ok !$rwf->{stdin_write}, 'stdin_write handle was cleaed up'; 29 | ok !$rwf->{stdout_read}, 'stdout_read handle was cleaed up'; 30 | 31 | done_testing; 32 | -------------------------------------------------------------------------------- /t/run-callback.t: -------------------------------------------------------------------------------- 1 | use Mojo::Base -strict; 2 | use Mojo::IOLoop::ReadWriteFork; 3 | use Test::More; 4 | 5 | BEGIN { 6 | eval 'use Test::Memory::Cycle;1' or Mojo::Util::monkey_patch(main => memory_cycle_ok => sub { }); 7 | } 8 | 9 | my $rwf = Mojo::IOLoop::ReadWriteFork->new; 10 | my ($output, $exit_value, $signal, $spawn) = ('', -1, -1, 0); 11 | 12 | memory_cycle_ok $rwf, 'no cycle after new()'; 13 | 14 | $rwf->on(error => sub { diag $_[1] }); 15 | $rwf->on(spawn => sub { $spawn++ }); 16 | $rwf->on(finish => sub { ($exit_value, $signal) = @_[1, 2]; Mojo::IOLoop->stop }); 17 | $rwf->on( 18 | read => sub { 19 | $_[0]->write("line one\n") unless $output; 20 | $output .= $_[1]; 21 | } 22 | ); 23 | 24 | $rwf->run_p( 25 | sub { 26 | print join(" ", @_), "\n"; 27 | my $input = ; 28 | print $input; 29 | print "line two\n"; 30 | die "Oops"; 31 | }, 32 | qw(some args), 33 | )->wait; 34 | 35 | like $rwf->pid, qr{^[1-9]\d+$}, 'got pid' or diag $rwf->pid; 36 | like $output, qr{^some args\nline one\nline two\nOops at t/run-callback\.t.* line }s, 'got stdout from callback' 37 | or diag $output; 38 | is $spawn, 1, 'spawn'; 39 | is $exit_value, 255, 'exit_value'; 40 | is $signal, 0, 'signal'; 41 | 42 | memory_cycle_ok $rwf, 'no cycle after run_p has completed'; 43 | 44 | done_testing; 45 | -------------------------------------------------------------------------------- /t/run-ssh.t: -------------------------------------------------------------------------------- 1 | use Mojo::Base -strict; 2 | use Test::More; 3 | use Mojo::IOLoop::ReadWriteFork; 4 | 5 | plan skip_all => 'READWRITEFORK_SSH=host is not set' unless $ENV{READWRITEFORK_SSH} or -e '.readwriterwf_ssh'; 6 | 7 | $ENV{READWRITEFORK_SSH} ||= Mojo::File->new('.readwriterwf_ssh')->slurp; 8 | chomp $ENV{READWRITEFORK_SSH}; 9 | 10 | my $rwf = Mojo::IOLoop::ReadWriteFork->new; 11 | my $output = ''; 12 | $rwf->on(read => sub { $output .= $_[1]; }); 13 | $rwf->run_p(ssh => $ENV{READWRITEFORK_SSH}, qw( ls -l / ))->wait; 14 | 15 | like $output, qr{bin.*sbin}s, 'ls -l'; 16 | 17 | done_testing; 18 | -------------------------------------------------------------------------------- /t/run-sudo.t: -------------------------------------------------------------------------------- 1 | use Mojo::Base -strict; 2 | use Test::Mojo; 3 | use Test::More; 4 | use Mojo::IOLoop::ReadWriteFork; 5 | 6 | $ENV{PATH} ||= ''; 7 | plan skip_all => './.sudo_password is missing' unless -r '.sudo_password'; 8 | 9 | my $rwf = Mojo::IOLoop::ReadWriteFork->new; 10 | my $password = Mojo::File->new('.sudo_password')->slurp; 11 | my ($output, $exit_value, $signal) = (''); 12 | 13 | chomp $password; 14 | 15 | $rwf->on(finish => sub { ($exit_value, $signal) = @_[1, 2]; Mojo::IOLoop->stop }); 16 | $rwf->on( 17 | read => sub { 18 | $output .= $_[1]; 19 | $rwf->write("$password\n") if $output =~ s!password.*:!!i; 20 | } 21 | ); 22 | 23 | $rwf->start(program => 'sudo', program_args => [$^X, -e => q(print "hey $ENV{USER}!\n"; exit 3)], conduit => 'pty'); 24 | 25 | my @killer = ($rwf); 26 | Scalar::Util::weaken($killer[0]); 27 | Mojo::IOLoop->timer(0.5 => sub { $killer[0]->kill(9) }); 28 | Mojo::IOLoop->timer(1 => sub { Mojo::IOLoop->stop; }); 29 | Mojo::IOLoop->start; 30 | 31 | like $output, qr{hey root}, 'perl -e hey $USER'; 32 | is $exit_value, 3, 'exit_value'; 33 | 34 | done_testing; 35 | -------------------------------------------------------------------------------- /t/run-telnet.t: -------------------------------------------------------------------------------- 1 | use Mojo::Base -strict; 2 | use Mojo::IOLoop; 3 | use Mojo::IOLoop::ReadWriteFork; 4 | use Test::More; 5 | 6 | $ENV{PATH} ||= ''; 7 | plan skip_all => 'telnet is missing' unless grep { -x "$_/telnet" } split /:/, $ENV{PATH}; 8 | 9 | my $address = '127.0.0.1'; 10 | my $port = Mojo::IOLoop::Server->generate_port; 11 | my ($connected, $exit_value, $signal) = (0); 12 | 13 | # echo server 14 | Mojo::IOLoop->server( 15 | {address => $address, port => $port}, 16 | sub { 17 | my ($ioloop, $stream) = @_; 18 | $stream->on( 19 | read => sub { 20 | my ($stream, $chunk) = @_; 21 | $stream->write("I heard you say: $chunk"); 22 | } 23 | ); 24 | } 25 | ); 26 | 27 | my $rwf = Mojo::IOLoop::ReadWriteFork->new; 28 | my ($drain, $output) = (0, ''); 29 | 30 | $rwf->on(finish => sub { ($exit_value, $signal) = @_[1, 2]; Mojo::IOLoop->stop }); 31 | $rwf->on( 32 | read => sub { 33 | my ($rwf, $chunk) = @_; 34 | $rwf->write("hey\r\n", sub { $drain++; }) if $chunk =~ /Connected/; 35 | $rwf->kill(15) if $chunk =~ /I heard you say/; 36 | $output .= $chunk; 37 | } 38 | ); 39 | 40 | $rwf->start(program => 'telnet', program_args => [$address, $port], conduit => 'pty',); 41 | 42 | my $guard; 43 | Mojo::IOLoop->timer(1 => sub { $guard++; Mojo::IOLoop->stop }); # guard 44 | Mojo::IOLoop->start; 45 | plan skip_all => 'Saved by guard' if $guard; 46 | 47 | like $output, qr{Connected}, 'Connected'; 48 | like $output, qr{I heard you say:.*hey}s, 'got echo'; 49 | is $drain, 1, 'got drain event'; 50 | is $exit_value, 0, 'exit_value'; 51 | is $signal, 15, 'signal'; 52 | 53 | done_testing; 54 | -------------------------------------------------------------------------------- /t/rwf.t: -------------------------------------------------------------------------------- 1 | use Mojo::Base -strict; 2 | use Mojo::IOLoop::ReadWriteFork; 3 | use Test::More; 4 | 5 | my $rwf = Mojo::IOLoop::ReadWriteFork->new; 6 | 7 | subtest 'missing arguments' => sub { 8 | eval { $rwf->start({program_args => []}) }; 9 | like $@, qr{program is required input}, 'program is required'; 10 | }; 11 | 12 | subtest 'invalid program' => sub { 13 | my ($exit_value, $signal); 14 | $rwf->on(finish => sub { ($exit_value, $signal) = @_[1, 2] }); 15 | $rwf->run_p('__INVALID_PROGRAM_NAME_THAT_DOES_NOT_EXIST__')->wait; 16 | is $exit_value, 2, 'exit_value'; 17 | is $signal, 0, 'signal'; 18 | }; 19 | 20 | done_testing; 21 | -------------------------------------------------------------------------------- /t/sigchld-poll.t: -------------------------------------------------------------------------------- 1 | BEGIN { $ENV{MOJO_REACTOR} = 'Mojo::Reactor::Poll' } 2 | use Mojo::Base -strict; 3 | use Mojo::IOLoop::ReadWriteFork; 4 | use Test::More; 5 | use Time::HiRes 'usleep'; 6 | 7 | # This test will check if the recurring waitpid function works 8 | 9 | my $sigchld = Mojo::IOLoop::ReadWriteFork::SIGCHLD->singleton; 10 | my $rwf = Mojo::IOLoop::ReadWriteFork->new; 11 | my $exit_value = 24; 12 | 13 | ok !$sigchld->is_waiting, 'no forks'; 14 | 15 | my $close_p = Mojo::Promise->new; 16 | $rwf->once(finish => sub { $exit_value = $_[1]; $close_p->resolve }); 17 | $rwf->once( 18 | spawn => sub { 19 | is_deeply [keys %{$sigchld->pids}], [$rwf->pid], 'one pid after spawn'; 20 | } 21 | ); 22 | 23 | $rwf->start(program => sub { usleep 0.2; $! = 42; }); 24 | Mojo::Promise->race(Mojo::Promise->timeout(1), Mojo::Promise->all(Mojo::Promise->timer(0.5), $close_p))->wait; 25 | 26 | ok !$sigchld->is_waiting, 'no forks after waitpid'; 27 | is_deeply [keys %{$sigchld->pids}], [], 'no pids after waitpid'; 28 | is $exit_value, 42, 'exit_value'; 29 | 30 | done_testing; 31 | -------------------------------------------------------------------------------- /t/synopsis.t: -------------------------------------------------------------------------------- 1 | use Mojo::Base -strict; 2 | use Mojo::IOLoop::ReadWriteFork; 3 | use Test::More; 4 | 5 | $ENV{PATH} ||= ''; 6 | plan skip_all => 'bash is missing' unless grep { -x "$_/bash" } split /:/, $ENV{PATH}; 7 | 8 | my $rwf = Mojo::IOLoop::ReadWriteFork->new; 9 | my $output = ''; 10 | 11 | $rwf->on(error => sub { my ($rwf, $error) = @_; diag $error; }); 12 | $rwf->on(finish => sub { my ($rwf, $exit_value, $signal) = @_; Mojo::IOLoop->stop; }); 13 | $rwf->on(read => sub { my ($rwf, $buf) = @_; $output .= $buf }); 14 | $rwf->conduit({type => "pty"}); 15 | 16 | $ENV{RWF_INVISIBLE} = 'invisble'; 17 | $rwf->run(qw(bash -c), q(echo "$RWF_VISIBLE. RWF_INVISIBLE=$RWF_INVISIBLE."), {env => {RWF_VISIBLE => 'Hello'}}); 18 | 19 | is $rwf->pid, 0, 'no pid' or diag $rwf->pid; 20 | Mojo::IOLoop->timer(3 => sub { Mojo::IOLoop->stop }); # guard 21 | Mojo::IOLoop->start; 22 | like $rwf->pid, qr{^[1-9]\d+$}, 'got pid' or diag $rwf->pid; 23 | 24 | if ($output =~ /Can't exec/) { # "Can't exec "bash": ..." 25 | like $output, qr/Can't exec/, 'could not start bash'; 26 | } 27 | else { 28 | like $output, qr/Hello. RWF_INVISIBLE=\./, 'got stdout from "echo"' or diag $output; 29 | } 30 | 31 | done_testing; 32 | --------------------------------------------------------------------------------