File Coverage

lib/Class/Usul/IPC/Cmd.pm
Criterion Covered Total %
statement 77 88 87.5
branch 5 12 41.6
condition 3 6 50.0
subroutine 27 32 84.3
pod 2 2 100.0
total 114 140 81.4


line stmt bran cond sub pod time code
1             package Class::Usul::IPC::Cmd;
2              
3 18     18   109 use namespace::autoclean;
  18         39  
  18         104  
4              
5 18     18   1040 use Class::Null;
  18         36  
  18         402  
6 18         91 use Class::Usul::Constants qw( EXCEPTION_CLASS FALSE NUL
7 18     18   76 OK SPC TRUE UNDEFINED_RV );
  18         37  
8 18         108 use Class::Usul::Functions qw( arg_list emit_to io is_arrayref
9             is_coderef is_hashref is_member is_win32
10             nonblocking_write_pipe_pair
11 18     18   16252 strip_leader throw );
  18         38  
12 18     18   35081 use Class::Usul::Time qw( nap );
  18         54  
  18         1236  
13 18         278 use Class::Usul::Types qw( ArrayRef Bool LoadableClass Logger
14             NonEmptySimpleStr Num Object PositiveInt
15 18     18   165 SimpleStr Str Undef );
  18         66  
16 18     18   39027 use English qw( -no_match_vars );
  18         39  
  18         157  
17 18     18   5433 use File::Basename qw( basename );
  18         35  
  18         783  
18 18     18   93 use File::DataClass::Types qw( Directory Path );
  18         37  
  18         128  
19 18     18   18540 use File::Spec::Functions qw( devnull rootdir tmpdir );
  18         38  
  18         830  
20 18     18   108 use IO::Handle;
  18         37  
  18         526  
21 18     18   8670 use IO::Select;
  18         21693  
  18         690  
22 18     18   8334 use IPC::Open3;
  18         37968  
  18         848  
23 18     18   8649 use Module::Load::Conditional qw( can_load );
  18         143678  
  18         1735  
24 18     18   7763 use POSIX qw( _exit setsid sysconf WIFEXITED WNOHANG );
  18         65740  
  18         129  
25 18     18   20909 use Scalar::Util qw( blessed openhandle weaken );
  18         39  
  18         860  
26 18     18   93 use Socket qw( AF_UNIX SOCK_STREAM PF_UNSPEC );
  18         49  
  18         802  
27 18     18   91 use Sub::Install qw( install_sub );
  18         48  
  18         163  
28 18     18   2024 use Try::Tiny;
  18         22  
  18         824  
29 18     18   96 use Unexpected::Functions qw( TimeOut Unspecified );
  18         35  
  18         174  
30              
31 18     18   7094 use Moo; use warnings NONFATAL => 'all';
  18     18   38  
  18         144  
  18         9212  
  18         36  
  18         93740  
32              
33             our ($CHILD_ENUM, $CHILD_PID);
34              
35             # Public attributes
36             has 'async' => is => 'ro', isa => Bool, default => FALSE;
37              
38             has 'close_all_files' => is => 'ro', isa => Bool, default => FALSE;
39              
40             has 'cmd' => is => 'ro', isa => ArrayRef | Str,
41             required => TRUE;
42              
43             has 'detach' => is => 'ro', isa => Bool, default => FALSE;
44              
45             has 'err' => is => 'ro', isa => Path | SimpleStr, default => NUL;
46              
47             has 'expected_rv' => is => 'ro', isa => PositiveInt, default => 0;
48              
49             has 'ignore_zombies' => is => 'lazy', isa => Bool, builder => sub {
50 96 100 100 96   3737 ($_[ 0 ]->async || $_[ 0 ]->detach) ? TRUE : FALSE };
51              
52             has 'in' => is => 'ro', isa => Path | SimpleStr, coerce => sub {
53             (is_arrayref $_[ 0 ]) ? join $RS, @{ $_[ 0 ] } : $_[ 0 ] },
54             default => NUL;
55              
56             has 'log' => is => 'lazy', isa => Logger,
57 0     0   0 builder => sub { Class::Null->new };
58              
59             has 'keep_fhs' => is => 'lazy', isa => ArrayRef,
60             builder => sub {
61 0 0   0   0 $_[ 0 ]->log->can( 'filehandle' ) ? [ $_[ 0 ]->log->filehandle ] : [] };
62              
63             has 'max_pidfile_wait' => is => 'ro', isa => PositiveInt, default => 15;
64              
65             has 'nap_time' => is => 'ro', isa => Num, default => 0.3;
66              
67             has 'out' => is => 'ro', isa => Path | SimpleStr, default => NUL;
68              
69             has 'partition_cmd' => is => 'ro', isa => Bool, default => TRUE;
70              
71             has 'pidfile' => is => 'lazy', isa => Path, coerce => TRUE,
72 374     374   14229 builder => sub { $_[ 0 ]->rundir->tempfile };
73              
74             has 'response_class' => is => 'lazy', isa => LoadableClass, coerce => TRUE,
75             default => 'Class::Usul::Response::IPC';
76              
77             has 'rundir' => is => 'lazy', isa => Directory, coerce => TRUE,
78 0     0   0 builder => sub { $_[ 0 ]->tempdir };
79              
80             has 'tempdir' => is => 'lazy', isa => Directory,
81 0     0   0 builder => sub { tmpdir }, coerce => TRUE,
82             handles => { _tempfile => 'tempfile' };
83              
84             has 'timeout' => is => 'ro', isa => PositiveInt, default => 0;
85              
86             has 'use_ipc_run' => is => 'ro', isa => Bool, default => FALSE;
87              
88             has 'use_system' => is => 'ro', isa => Bool, default => FALSE;
89              
90             has 'working_dir' => is => 'lazy', isa => Directory | Undef,
91             default => sub { $_[ 0 ]->detach ? io rootdir : undef },
92             coerce => TRUE;
93              
94             # Private functions
95             my $_child_handler; $_child_handler = sub {
96             local $OS_ERROR; # So that waitpid does not step on existing value
97              
98             while ((my $child_pid = waitpid -1, WNOHANG) > 0) {
99             if (WIFEXITED( $CHILD_ERROR ) and $child_pid > ($CHILD_PID || 0)) {
100             $CHILD_PID = $child_pid; $CHILD_ENUM = $CHILD_ERROR;
101             }
102             }
103              
104             $SIG{CHLD} = $_child_handler; # In case of unreliable signals
105             return;
106             };
107              
108             my $_close_child_io = sub { # In the parent, close the child end of the pipes
109             my $pipes = shift;
110              
111             close $pipes->[ 0 ]->[ 0 ]; undef $pipes->[ 0 ]->[ 0 ];
112             close $pipes->[ 1 ]->[ 1 ]; undef $pipes->[ 1 ]->[ 1 ];
113             close $pipes->[ 2 ]->[ 1 ]; undef $pipes->[ 2 ]->[ 1 ];
114             close $pipes->[ 3 ]->[ 1 ]; undef $pipes->[ 3 ]->[ 1 ];
115             return;
116             };
117              
118             my $_drain = sub { # Suck up the output from the child process
119             my (%hands, @ready); my $selector = IO::Select->new(); my $i = 0;
120              
121             while (defined (my $fh = $_[ $i ])) {
122             $selector->add( $fh ); $hands{ fileno $fh } = $_[ $i + 1 ]; $i += 2;
123             }
124              
125             while (@ready = $selector->can_read) {
126             for my $fh (@ready) {
127             my $buf; my $bytes_read = sysread $fh, $buf, 64 * 1024;
128              
129             if ($bytes_read) { $hands{ fileno $fh }->( "${buf}" ) }
130             else { $selector->remove( $fh ); close $fh }
131             }
132             }
133              
134             return;
135             };
136              
137             my $_err_handler = sub {
138             my ($err, $filtered, $standard) = @_;
139              
140             return sub {
141             my $buf = shift; defined $buf or return;
142              
143             blessed $err and $err->append( $buf );
144             $err eq 'out' and ${ $filtered } .= $buf;
145             $err ne 'null' and ${ $standard } .= $buf;
146             $err eq 'stderr' and emit_to \*STDERR, $buf;
147             return;
148             }
149             };
150              
151             my $_filter_out = sub {
152             return join "\n", map { strip_leader $_ }
153             grep { not m{ (?: Started | Finished ) }msx }
154             split m{ [\n] }msx, $_[ 0 ];
155             };
156              
157             my $_four_nonblocking_pipe_pairs = sub {
158             return [ nonblocking_write_pipe_pair, nonblocking_write_pipe_pair,
159             nonblocking_write_pipe_pair, nonblocking_write_pipe_pair ];
160             };
161              
162             my $_has_shell_meta = sub {
163             return (is_arrayref $_[ 0 ] && is_member '|', $_[ 0 ]) ? TRUE
164             : (is_arrayref $_[ 0 ] && is_member '&&', $_[ 0 ]) ? TRUE
165             : ( is_arrayref $_[ 0 ]) ? FALSE
166             : ( $_[ 0 ] =~ m{ [|] }mx) ? TRUE
167             : ( $_[ 0 ] =~ m{ [&][&] }mx) ? TRUE
168             : FALSE;
169             };
170              
171             my $_make_socket_pipe = sub {
172             socketpair( $_[ 0 ], $_[ 1 ], AF_UNIX, SOCK_STREAM, PF_UNSPEC )
173             or throw $EXTENDED_OS_ERROR;
174             shutdown ( $_[ 0 ], 1 ); # No more writing for reader
175             shutdown ( $_[ 1 ], 0 ); # No more reading for writer
176             return;
177             };
178              
179             my $_out_handler = sub {
180             my ($out, $filtered, $standard) = @_;
181              
182             return sub {
183             my $buf = shift; defined $buf or return;
184              
185             blessed $out and $out->append( $buf );
186             $out ne 'null' and ${ $filtered } .= $buf;
187             $out ne 'null' and ${ $standard } .= $buf;
188             $out eq 'stdout' and emit_to \*STDOUT, $buf;
189             return;
190             }
191             };
192              
193             my $_partition_command = sub {
194             my $cmd = shift; my $aref = []; my @command = ();
195              
196             for my $item (grep { defined && length } @{ $cmd }) {
197             if ($item !~ m{ [^\\][\<\>\|\&] }mx) { push @{ $aref }, $item }
198             else { push @command, $aref, $item; $aref = [] }
199             }
200              
201             if ($aref->[ 0 ]) {
202             if ($command[ 0 ]) { push @command, $aref }
203             else { @command = @{ $aref } }
204             }
205              
206             return \@command;
207             };
208              
209             my $_pipe_handler; $_pipe_handler = sub {
210             local $OS_ERROR; # So that wait does not step on existing value
211              
212             $CHILD_PID = wait; $CHILD_ENUM = (255 << 8) + 13;
213             $SIG{PIPE} = $_pipe_handler;
214             return;
215             };
216              
217             my $_quote = sub {
218             my $v = shift; return is_win32 ? '"'.$v.'"' : "'${v}'";
219             };
220              
221             my $_quoted_join = sub {
222             return join SPC, map { m{ [ ] }mx ? $_quote->( $_ ) : $_ } @_;
223             };
224              
225             my $_recv_exec_failure = sub {
226             my $fh = shift; my $to_read = 2 * length pack 'I', 0;
227              
228             read $fh, my $buf = NUL, $to_read or return FALSE;
229              
230             (my $errno, $to_read) = unpack 'II', $buf; $ERRNO = $errno;
231              
232             read $fh, my $error = NUL, $to_read; $error and utf8::decode $error;
233              
234             return $error || "${ERRNO}";
235             };
236              
237             my $_redirect_stderr = sub {
238             my $v = shift; my $err = \*STDERR; close $err;
239              
240             my $op = openhandle $v ? '>&' : '>'; my $sink = $op eq '>' ? $v : fileno $v;
241              
242             open $err, $op, $sink
243             or throw "Could not redirect STDERR to ${sink}: ${OS_ERROR}";
244             return;
245             };
246              
247             my $_redirect_stdin = sub {
248             my $v = shift; my $in = \*STDIN; close $in;
249              
250             my $op = openhandle $v ? '<&' : '<'; my $src = $op eq '<' ? $v : fileno $v;
251              
252             open $in, $op, $src
253             or throw "Could not redirect STDIN from ${src}: ${OS_ERROR}";
254             return;
255             };
256              
257             my $_redirect_stdout = sub {
258             my $v = shift; my $out = \*STDOUT; close $out;
259              
260             my $op = openhandle $v ? '>&' : '>'; my $sink = $op eq '>' ? $v : fileno $v;
261              
262             open $out, $op, $sink
263             or throw "Could not redirect STDOUT to ${sink}: ${OS_ERROR}";
264             return;
265             };
266              
267             my $_send_exec_failure = sub {
268             my ($fh, $error) = @_; utf8::encode $error;
269              
270             emit_to $fh, pack 'IIa*', 0+$ERRNO, length $error, $error; close $fh;
271             _exit 255;
272             };
273              
274             my $_send_in = sub {
275             my ($fh, $in) = @_; $in or return;
276              
277             if (blessed $in) { emit_to $fh, $in->slurp }
278             elsif ($in ne 'null' and $in ne 'stdin') { emit_to $fh, $in }
279              
280             return;
281             };
282              
283             my $_open3 = sub {
284             local (*TO_CHLD_R, *TO_CHLD_W);
285             local (*FR_CHLD_R, *FR_CHLD_W);
286             local (*FR_CHLD_ERR_R, *FR_CHLD_ERR_W);
287              
288             $_make_socket_pipe->( *TO_CHLD_R, *TO_CHLD_W );
289             $_make_socket_pipe->( *FR_CHLD_R, *FR_CHLD_W );
290             $_make_socket_pipe->( *FR_CHLD_ERR_R, *FR_CHLD_ERR_W );
291              
292             my $pid = open3( '>&TO_CHLD_R', '<&FR_CHLD_W', '<&FR_CHLD_ERR_W', @_ );
293              
294             return ($pid, *TO_CHLD_W, *FR_CHLD_R, *FR_CHLD_ERR_R);
295             };
296              
297             # Private methods
298             my $_detach_process = sub { # And this method came from MooseX::Daemonize
299             my $self = shift;
300              
301             setsid or throw 'Cannot detach from controlling process';
302             $SIG{HUP} = 'IGNORE'; fork and _exit OK;
303             # Clearing file creation mask allows direct control of the access mode of
304             # created files and directories in open, mkdir, and mkpath functions
305             umask 0;
306              
307             if ($self->close_all_files) { # Close all fds except the ones we should keep
308             my $openmax = sysconf( &POSIX::_SC_OPEN_MAX );
309              
310             (not defined $openmax or $openmax < 0) and $openmax = 64;
311              
312             for (grep { not is_member $_, $self->keep_fhs } 0 .. $openmax) {
313             POSIX::close( $_ );
314             }
315             }
316              
317             $self->pidfile->println( $PID );
318             return;
319             };
320              
321             my $_ipc_run_harness = sub {
322             my ($self, $cmd_ref, @cmd_args) = @_;
323              
324             if ($self->async) {
325             is_coderef $cmd_ref->[ 0 ] and $cmd_ref = $cmd_ref->[ 0 ];
326              
327             my $pidfile = $self->pidfile; weaken( $pidfile );
328             my $h = IPC::Run::harness( $cmd_ref, @cmd_args, init => sub {
329             IPC::Run::close_terminal(); $pidfile->println( $PID ) }, '&' );
330              
331             $h->start; return ( 0, $h );
332             }
333              
334             my $h = IPC::Run::harness( $cmd_ref, @cmd_args ); $h->run;
335             my $rv = $h->full_result || 0; $rv =~ m{ unknown }msx and throw $rv;
336              
337             return ( $rv, $h );
338             };
339              
340             my $_new_async_response = sub {
341             my ($self, $pid) = @_; my $prog = basename( $self->cmd->[ 0 ] );
342              
343             $self->log->debug( my $out = "Running ${prog}(${pid}) in the background" );
344              
345             return $self->response_class->new( out => $out, pid => $pid );
346             };
347              
348             my $_redirect_child_io = sub {
349             my ($self, $pipes) = @_;
350              
351             my $in = $self->in || 'null'; my $out = $self->out; my $err = $self->err;
352              
353             if ($self->async or $self->detach) { $out ||= 'null'; $err ||= 'null' }
354              
355             $in eq 'stdin'
356             or $_redirect_stdin-> ( ($in eq 'null') ? devnull
357             : $pipes->[ 0 ]->[ 0 ] );
358             $out eq 'stdout'
359             or $_redirect_stdout->( ( blessed $out) ? "${out}"
360             : ($out eq 'null') ? devnull
361             : $pipes->[ 1 ]->[ 1 ] );
362             $err eq 'stderr'
363             or $_redirect_stderr->( ( blessed $err) ? "${err}"
364             : ($err eq 'null') ? devnull
365             : $pipes->[ 2 ]->[ 1 ] );
366             return;
367             };
368              
369             my $_return_codes_or_throw = sub {
370             my ($self, $cmd, $e_num, $e_str) = @_;
371              
372             $e_str ||= 'Unknown error'; chomp $e_str;
373              
374             if ($e_num == UNDEFINED_RV) {
375             my $error = 'Program [_1] failed to start: [_2]';
376             my $prog = basename( (split SPC, $cmd)[ 0 ] );
377              
378             throw $error, [ $prog, $e_str ], level => 3, rv => UNDEFINED_RV;
379             }
380              
381             my $rv = $e_num >> 8; my $core = $e_num & 128; my $sig = $e_num & 127;
382              
383             if ($rv > $self->expected_rv) {
384             $self->log->debug( my $error = "${e_str} rv ${rv}" );
385             throw $error, level => 3, rv => $rv;
386             }
387              
388             return { core => $core, rv => $rv, sig => $sig, };
389             };
390              
391             my $_shutdown = sub {
392             my $self = shift; my $pidfile = $self->pidfile;
393              
394             $pidfile->exists and $pidfile->getline == $PID and $self->pidfile->unlink;
395              
396             _exit OK;
397             };
398              
399             my $_wait_for_pidfile_and_read = sub {
400             my $self = shift; my $pidfile = $self->pidfile; my $waited = 0;
401              
402             while (not $pidfile->exists or $pidfile->is_empty) {
403             nap $self->nap_time; $waited += $self->nap_time;
404             $waited > $self->max_pidfile_wait
405             and throw 'File [_1] contains no process id', [ $pidfile ];
406             }
407              
408             my $pid = $pidfile->chomp->getline || UNDEFINED_RV; $pidfile->close;
409              
410             return $pid;
411             };
412              
413             my $_execute_coderef = sub {
414             my $self = shift; my ($code, @args) = @{ $self->cmd }; my $rv;
415              
416             try {
417             local $SIG{INT} = sub { $self->$_shutdown };
418              
419             $rv = $code->( $self, @args ); defined $rv and $rv = $rv << 8;
420              
421             $self->pidfile->exists and $self->pidfile->unlink;
422             }
423             catch {
424             blessed $_ and $_->can( 'rv' ) and $rv = $_->rv; emit_to \*STDERR, $_;
425             };
426              
427             _exit $rv // OK;
428             };
429              
430             my $_wait_for_child = sub {
431             my ($self, $pid, $pipes) = @_;
432              
433             my ($filtered, $stderr, $stdout) = (NUL, NUL, NUL);
434              
435             my $in_fh = $pipes->[ 0 ]->[ 1 ];
436             my $out_fh = $pipes->[ 1 ]->[ 0 ];
437             my $err_fh = $pipes->[ 2 ]->[ 0 ];
438             my $stat_fh = $pipes->[ 3 ]->[ 0 ];
439             my $err_hand = $_err_handler->( $self->err, \$filtered, \$stderr );
440             my $out_hand = $_out_handler->( $self->out, \$filtered, \$stdout );
441             my $prog = basename( my $cmd = $self->cmd->[ 0 ] );
442              
443             try {
444             my $tmout = $self->timeout; $tmout and local $SIG{ALRM} = sub {
445             throw TimeOut, [ $prog, $tmout ];
446             } and alarm $tmout;
447              
448             my $error = $_recv_exec_failure->( $stat_fh ); $error and throw $error;
449              
450             $_send_in->( $in_fh, $self->in ); close $in_fh;
451             $_drain->( $out_fh, $out_hand, $err_fh, $err_hand );
452             waitpid $pid, 0; alarm 0;
453             }
454             catch { alarm 0; throw $_ };
455              
456             my $e_num = $CHILD_PID > 0 ? $CHILD_ENUM : $CHILD_ERROR;
457             my $codes = $self->$_return_codes_or_throw( $cmd, $e_num, $stderr );
458              
459             return $self->response_class->new
460             ( core => $codes->{core}, out => $_filter_out->( $filtered ),
461             rv => $codes->{rv}, sig => $codes->{sig},
462             stderr => $stderr, stdout => $stdout );
463             };
464              
465             my $_run_cmd_using_fork_and_exec = sub {
466             my $self = shift;
467             my $pipes = $_four_nonblocking_pipe_pairs->();
468             my $cmd_str = $_quoted_join->( @{ $self->cmd } );
469              
470             $self->log->debug( "Running ${cmd_str} using fork and exec" );
471              
472             { local ($CHILD_ENUM, $CHILD_PID) = (0, 0);
473             $self->ignore_zombies and local $SIG{CHLD} = 'IGNORE';
474              
475             if (my $pid = fork) { # Parent
476             $_close_child_io->( $pipes );
477             $self->detach and $pid = $self->$_wait_for_pidfile_and_read;
478              
479             return ($self->async || $self->detach)
480             ? $self->$_new_async_response( $pid )
481             : $self->$_wait_for_child( $pid, $pipes );
482             }
483             }
484              
485             try { # Child
486             my $prog = basename( my $cmd = $self->cmd->[ 0 ] );
487              
488             $self->$_redirect_child_io( $pipes );
489             $self->detach and $self->$_detach_process;
490             $self->working_dir and chdir $self->working_dir;
491             is_coderef $cmd and $self->$_execute_coderef; # Never returns
492              
493             exec @{ $self->cmd }
494             or throw 'Program [_1] failed to exec: [_2]', [ $prog, $OS_ERROR ];
495             }
496             catch { $_send_exec_failure->( $pipes->[ 3 ]->[ 1 ], "${_}" ) };
497              
498             close $pipes->[ 3 ]->[ 1 ];
499             return OK;
500             };
501              
502             my $_run_cmd_using_ipc_run = sub {
503             my $self = shift; my ($buf_err, $buf_out, $error, $h, $rv) = (NUL, NUL);
504              
505             my $cmd = $self->cmd;
506             my $cmd_ref = $self->partition_cmd ? $_partition_command->( $cmd ) : $cmd;
507             my $prog = basename( $cmd->[ 0 ] );
508             my $null = devnull;
509             my $in = $self->in || 'null';
510             my $out = $self->out;
511             my $err = $self->err;
512             my @cmd_args = ();
513              
514             if (blessed $in) { push @cmd_args, "0<${in}" }
515             elsif ($in eq 'null') { push @cmd_args, "0<${null}" }
516             elsif ($in ne 'stdin') { push @cmd_args, '0<', \$in }
517              
518             if (blessed $out) { push @cmd_args, "1>${out}" }
519             elsif ($out eq 'null') { push @cmd_args, "1>${null}" }
520             elsif ($out ne 'stdout') { push @cmd_args, '1>', \$buf_out }
521              
522             if (blessed $err) { push @cmd_args, "2>${err}" }
523             elsif ($err eq 'out') { push @cmd_args, '2>&1' }
524             elsif ($err eq 'null') { push @cmd_args, "2>${null}" }
525             elsif ($err ne 'stderr') { push @cmd_args, '2>', \$buf_err }
526              
527             my $cmd_str = $_quoted_join->( @{ $self->cmd }, @cmd_args );
528              
529             $self->async and $cmd_str .= ' &';
530             $self->log->debug( "Running ${cmd_str} using ipc run" );
531              
532             try {
533             my $tmout = $self->timeout; $tmout and local $SIG{ALRM} = sub {
534             throw TimeOut, [ $cmd_str, $tmout ];
535             } and alarm $tmout;
536              
537             ($rv, $h) = $_ipc_run_harness->( $self, $cmd_ref, @cmd_args ); alarm 0;
538             }
539             catch { alarm 0; throw $_ };
540              
541             my $sig = $rv & 127; my $core = $rv & 128; $rv = $rv >> 8;
542              
543             if ($self->async) {
544             my $pid = $self->$_wait_for_pidfile_and_read;
545              
546             $out = "Started ${prog}(${pid}) in the background";
547              
548             return $self->response_class->new
549             ( core => $core, harness => $h, out => $out,
550             pid => $pid, rv => $rv, sig => $sig );
551             }
552              
553             my ($stderr, $stdout) = (NUL, NUL);
554              
555             if ($out ne 'null' and $out ne 'stdout') {
556             not blessed $out and $out = $_filter_out->( $stdout = $buf_out );
557             }
558             else { $out = $stdout = NUL }
559              
560             if ($err eq 'out') { $stderr = $stdout; $error = $out; chomp $error }
561             elsif (blessed $err) { $stderr = $error = $err->all; chomp $error }
562             elsif ($err ne 'null' and $err ne 'stderr') {
563             $stderr = $error = $buf_err; chomp $error;
564             }
565             else { $stderr = $error = NUL }
566              
567             if ($rv > $self->expected_rv) {
568             $error = $error ? "${error} rv ${rv}" : "Unknown error rv ${rv}";
569             $self->log->debug( $error );
570             throw $error, out => $out, rv => $rv;
571             }
572              
573             return $self->response_class->new
574             ( core => $core, out => "${out}", rv => $rv,
575             sig => $sig, stderr => $stderr, stdout => $stdout );
576             };
577              
578             my $_run_cmd_using_open3 = sub { # Robbed in part from IPC::Cmd
579             my ($self, $cmd) = @_; my ($filtered, $stderr, $stdout) = (NUL, NUL, NUL);
580              
581             my $err_hand = $_err_handler->( $self->err, \$filtered, \$stderr );
582              
583             my $out_hand = $_out_handler->( $self->out, \$filtered, \$stdout );
584              
585             $self->log->debug( "Running ${cmd} using open3" ); my $e_num;
586              
587             { local ($CHILD_ENUM, $CHILD_PID) = (0, 0);
588              
589             try {
590             local $SIG{PIPE} = $_pipe_handler;
591              
592             my $tmout = $self->timeout; $tmout and local $SIG{ALRM} = sub {
593             throw TimeOut, [ $cmd, $tmout ];
594             } and alarm $tmout;
595              
596             my ($pid, $in_fh, $out_fh, $err_fh) = $_open3->( $cmd );
597              
598             $_send_in->( $in_fh, $self->in ); close $in_fh;
599             $_drain->( $out_fh, $out_hand, $err_fh, $err_hand );
600             $pid and waitpid $pid, 0; alarm 0;
601             }
602             catch { alarm 0; throw $_ };
603              
604             $e_num = $CHILD_PID > 0 ? $CHILD_ENUM : $CHILD_ERROR;
605             }
606              
607             my $codes = $self->$_return_codes_or_throw( $cmd, $e_num, $stderr );
608              
609             return $self->response_class->new
610             ( core => $codes->{core}, out => $_filter_out->( $filtered ),
611             rv => $codes->{rv}, sig => $codes->{sig},
612             stderr => $stderr, stdout => $stdout );
613             };
614              
615             my $_run_cmd_using_system = sub {
616             my ($self, $cmd) = @_; my ($error, $rv);
617              
618             my $prog = basename( (split SPC, $cmd)[ 0 ] ); my $null = devnull;
619              
620             my $in = $self->in || 'stdin'; my $out = $self->out; my $err = $self->err;
621              
622             if ($in ne 'null' and $in ne 'stdin' and not blessed $in) {
623             # Different semi-random file names in the temp directory
624             my $tmp = $self->_tempfile; $tmp->print( $in ); $in = $tmp;
625             }
626              
627             $out ne 'null' and $out ne 'stdout' and not blessed $out
628             and $out = $self->_tempfile;
629             $self->async and $err ||= 'out';
630             $err ne 'null' and $err ne 'stderr' and not blessed $err and $err ne 'out'
631             and $err = $self->_tempfile;
632              
633             $cmd .= $in eq 'stdin' ? NUL : $in eq 'null' ? " 0<${null}" : " 0<${in}";
634             $cmd .= $out eq 'stdout' ? NUL : $out eq 'null' ? " 1>${null}" : " 1>${out}";
635             $cmd .= $err eq 'stderr' ? NUL : $err eq 'null' ? " 2>${null}"
636             : $err ne 'out' ? " 2>${err}" : ' 2>&1';
637              
638             $self->async and $cmd .= ' & echo $! 1>'.$self->pidfile->pathname;
639             $self->log->debug( "Running ${cmd} using system" );
640              
641             { local ($CHILD_ENUM, $CHILD_PID) = (0, 0);
642              
643             try {
644             local $SIG{CHLD} = $_child_handler;
645              
646             my $tmout = $self->timeout; $tmout and local $SIG{ALRM} = sub {
647             throw TimeOut, [ $cmd, $tmout ];
648             } and alarm $tmout;
649              
650             $rv = system $cmd; alarm 0;
651             }
652             catch { alarm 0; throw $_ };
653              
654             my $os_error = $OS_ERROR;
655              
656             $self->log->debug
657             ( "System rv ${rv} child pid ${CHILD_PID} error ${CHILD_ENUM}" );
658             # On some systems the child handler reaps the child process so the system
659             # call returns -1 and sets $OS_ERROR to 'No child processes'. This line
660             # and the child handler code fix the problem
661             $rv == UNDEFINED_RV and $CHILD_PID > 0 and $rv = $CHILD_ENUM;
662             $rv == UNDEFINED_RV and throw 'Program [_1] failed to start: [_2]',
663             [ $prog, $os_error ], rv => $rv;
664             }
665              
666             my $sig = $rv & 127; my $core = $rv & 128; $rv = $rv >> 8;
667              
668             my ($stderr, $stdout) = (NUL, NUL);
669              
670             if ($self->async) {
671             $rv != 0 and throw 'Program [_1] failed to start', [ $prog ], rv => $rv;
672              
673             my $pid = $self->$_wait_for_pidfile_and_read;
674              
675             $out = "Started ${prog}(${pid}) in the background";
676              
677             return $self->response_class->new
678             ( core => $core, out => $out, pid => $pid, rv => $rv, sig => $sig );
679             }
680              
681             if ($out ne 'stdout' and $out ne 'null' and -f $out) {
682             $out = $_filter_out->( $stdout = io( $out )->slurp );
683             }
684             else { $out = $stdout = NUL }
685              
686             if ($err eq 'out') { $stderr = $stdout; $error = $out; chomp $error }
687             elsif ($err ne 'stderr' and $err ne 'null' and -f $err) {
688             $stderr = $error = io( $err )->slurp; chomp $error;
689             }
690             else { $stderr = $error = NUL }
691              
692             if ($rv > $self->expected_rv) {
693             $error = $error ? "${error} rv ${rv}" : "Unknown error rv ${rv}";
694             $self->log->debug( $error );
695             throw $error, out => $out, rv => $rv;
696             }
697              
698             return $self->response_class->new
699             ( core => $core, out => "${out}", rv => $rv,
700             sig => $sig, stderr => $stderr, stdout => $stdout );
701             };
702              
703             my $_run_cmd = sub { # Select one of the implementations
704             my $self = shift; my $has_meta = $_has_shell_meta->( my $cmd = $self->cmd );
705              
706             if (is_arrayref $cmd) {
707             $cmd->[ 0 ] or throw Unspecified, [ 'command' ];
708              
709             (is_win32 or $has_meta or $self->use_ipc_run)
710             and can_load( modules => { 'IPC::Run' => '0.84' } )
711             and return $self->$_run_cmd_using_ipc_run;
712              
713             is_win32 or $has_meta or $self->use_system
714             or return $self->$_run_cmd_using_fork_and_exec;
715              
716             $cmd = $_quoted_join->( @{ $cmd } );
717             }
718              
719             not is_win32 and ($has_meta or $self->async or $self->use_system)
720             and return $self->$_run_cmd_using_system( $cmd );
721              
722             return $self->$_run_cmd_using_open3( $cmd );
723             };
724              
725             # Construction
726             around 'BUILDARGS' => sub { # Differentiate constructor method signatures
727             my ($orig, $self, @args) = @_; my $n = 0; $n++ while (defined $args[ $n ]);
728              
729             return ( $n == 0) ? {}
730             : (is_hashref $args[ 0 ]) ? { %{ $args[ 0 ] } }
731             : ( $n == 1) ? { cmd => $args[ 0 ] }
732             : (is_hashref $args[ 1 ]) ? { cmd => $args[ 0 ], %{ $args[ 1 ] } }
733             : ( $n % 2 == 1) ? { cmd => @args }
734             : { @args };
735             };
736              
737             sub BUILD {
738 374     374 1 356568 $_[ 0 ]->pidfile->chomp->lock; return;
  374         778669  
739             }
740              
741             sub import { # Export run_cmd as a function on demand
742 18     18   97 my $class = shift;
743 18 50       139 my $params = { (is_hashref $_[ 0 ]) ? %{+ shift } : () };
  0         0  
744 18         72 my @wanted = @_;
745 18         68 my $target = caller;
746              
747             is_member 'run_cmd', @wanted and install_sub {
748             as => 'run_cmd', into => $target, code => sub {
749 0     0   0 my $cmd = shift; my $attr = arg_list @_;
  0         0  
750              
751 0 0       0 $attr->{cmd} = $cmd or throw Unspecified, [ 'command' ];
752              
753 0   0     0 $attr->{ $_ } //= $params->{ $_ } for (keys %{ $params });
  0         0  
754              
755 0         0 return $_run_cmd->( __PACKAGE__->new( $attr ) );
756 18 50       72 } };
757              
758 18         668 return;
759             }
760              
761             # Public methods
762             sub run_cmd { # Either class or object method
763 374 50   374 1 2844 return $_run_cmd->( (blessed $_[ 0 ]) ? $_[ 0 ] : __PACKAGE__->new( @_ ) );
764             }
765              
766             1;
767              
768             __END__
769              
770             =pod
771              
772             =encoding utf-8
773              
774             =head1 Name
775              
776             Class::Usul::IPC::Cmd - Execute system commands
777              
778             =head1 Synopsis
779              
780             use Class::Usul::IPC::Cmd;
781              
782             sub run_cmd {
783             my ($self, $cmd, @args) = @_; my $attr = arg_list @args;
784              
785             $attr->{cmd } = $cmd or throw Unspecified, [ 'command' ];
786             $attr->{log } = $self->log;
787             $attr->{rundir } = $self->config->rundir;
788             $attr->{tempdir} = $self->config->tempdir;
789              
790             return Class::Usul::IPC::Cmd->new( $attr )->run_cmd;
791             }
792              
793             $self->run_cmd( [ 'perl', '-v' ], { async => 1 } );
794              
795             # Alternatively there is a functional interface
796              
797             use Class::Usul::IPC::Cmd { tempdir => ... }, 'run_cmd';
798              
799             run_cmd( [ 'perl', '-v' ], { async => 1 } );
800              
801             =head1 Description
802              
803             Refactored L<IPC::Cmd> with a consistent OO API
804              
805             Would have used L<MooseX::Daemonize> but using L<Moo> not L<Moose> so
806             robbed some code from there instead
807              
808             =head1 Configuration and Environment
809              
810             Defines the following attributes;
811              
812             =over 3
813              
814             =item C<async>
815              
816             Boolean defaults to false. If true the call to C<run_cmd> will return without
817             waiting for the child process to complete. If true the C<ignore_zombies>
818             attribute will default to true
819              
820             =item C<close_all_files>
821              
822             Boolean defaults to false. If true and the C<detach> attribute is also true
823             then all open file descriptors in the child are closed except those in the
824             C<keep_fhs> list attribute
825              
826             =item C<cmd>
827              
828             An array reference or a simple string. Required. The external command to
829             execute
830              
831             =item C<detach>
832              
833             Boolean defaults to false. If true the child process will double fork, set
834             the session id and ignore hangup signals
835              
836             =item C<err>
837              
838             A L<File::DataClass::IO> object reference or a simple str. Defaults to null.
839             Determines where the standard error of the command will be redirected to.
840             Values are the same as for C<out>. Additionally a value of 'out' will
841             redirect standard error to standard output
842              
843             =item C<expected_rv>
844              
845             Positive integer default to zero. The maximum return value which is
846             considered a success
847              
848             =item C<ignore_zombies>
849              
850             Boolean defaults to false unless the C<async> attribute is true in which case
851             this attribute also defaults to true. If true ignores child processes. If you
852             plan to call C<waitpid> to wait for the child process to finish you should
853             set this to false
854              
855             =item C<in>
856              
857             A L<File::DataClass::IO> object reference or a simple str. Defaults to null.
858             Determines where the standard input of the command will be redirected from.
859             Object references should stringify to the name of the file containing input.
860             A scalar is the input unless it is 'stdin' or 'null' which cause redirection
861             from standard input and the null device
862              
863             =item C<keep_fhs>
864              
865             An array reference of file handles that are to be left open in detached
866             children
867              
868             =item C<log>
869              
870             A log object defaults to an instance of L<Class::Null>. Calls are made to
871             it at the debug level
872              
873             =item C<max_pidfile_wait>
874              
875             Positive integer defaults to 15. The maximum number of seconds the parent
876             process should wait for the child's PID file to appear and be populated
877              
878             =item C<nap_time>
879              
880             Positive number defaults to 0.3. The number of seconds to wait between testing
881             for the existence of the child's PID file
882              
883             =item C<out>
884              
885             A L<File::DataClass::IO> object reference or a simple str. Defaults to null.
886             Determines where the standard output of the command will be redirected to.
887             Values include;
888              
889             =over 3
890              
891             =item C<null>
892              
893             Redirect to the null device as defined by L<File::Spec>
894              
895             =item C<stdout>
896              
897             Output is not redirected to standard output
898              
899             =item C<$object_ref>
900              
901             The object reference should stringify to the name of a file to which standard
902             output will be redirected
903              
904             =back
905              
906             =item C<partition_cmd>
907              
908             Boolean default to true. If the L<IPC::Run> implementation is selected the
909             command array reference will be partitioned on meta character boundaries
910             unless this attribute is set to false
911              
912             =item C<pidfile>
913              
914             A L<File::DataClass::IO> object reference. Defaults to a temporary file
915             in the configuration C<rundir> which will automatically unlink when closed
916              
917             =item C<rundir>
918              
919             A L<File::DataClass::IO> object reference. Defaults to the C<tempdir>
920             attribute. Directory in which the PID files a stored
921              
922             =item C<tempdir>
923              
924             A L<File::DataClasS::IO> object reference. Defaults to C<tmpdir> from
925             L<File::Spec>. The directory for storing temporary files
926              
927             =item C<timeout>
928              
929             Positive integer defaults to 0. If greater then zero an alarm will be raised
930             after this many seconds if the external command has not completed
931              
932             =item C<use_ipc_run>
933              
934             Boolean defaults to false. If true forces the use of the L<IPC::Rum>
935             implementation
936              
937             =item C<use_system>
938              
939             Boolean defaults to false. If true forces the use of the C<system>
940             implementation
941              
942             =item C<working_dir>
943              
944             A L<File::DataClass::IO> object reference. Defaults to null. If set the child
945             will C<chdir> to this directory before executing the external command
946              
947             =back
948              
949             =head1 Subroutines/Methods
950              
951             =head2 C<BUILDARGS>
952              
953             $obj_ref = Class::Usul::IPC::Cmd->new( cmd => ..., out => ... );
954             $obj_ref = Class::Usul::IPC::Cmd->new( { cmd => ..., out => ... } );
955             $obj_ref = Class::Usul::IPC::Cmd->new( $cmd, out => ... );
956             $obj_ref = Class::Usul::IPC::Cmd->new( $cmd, { out => ... } );
957             $obj_ref = Class::Usul::IPC::Cmd->new( $cmd );
958              
959             The constructor accepts a list of keys and values, a hash reference, the
960             command followed by a list of keys and values, the command followed by a
961             hash reference
962              
963             =head2 C<BUILD>
964              
965             Set chomp and lock on the C<pidfile>
966              
967             =head2 C<run_cmd>
968              
969             $response_object = Class::Usul::IPC::Cmd->run_cmd( $cmd, @args );
970              
971             Can be called as a class method or an object method
972              
973             Runs a given external command. If the command argument is an array reference
974             the internal C<fork> and C<exec> implementation will be used, if a string is
975             passed the L<IPC::Open3> implementation will be use instead
976              
977             Returns a L<Class::Ususl::Response::IPC> object reference
978              
979             =head1 Diagnostics
980              
981             Passing a logger object reference in with the C<log> attribute will cause
982             the C<run_cmd> method to log at the debug level
983              
984             =head1 Dependencies
985              
986             =over 3
987              
988             =item L<Class::Null>
989              
990             =item L<File::DataClass>
991              
992             =item L<Module::Load::Conditional>
993              
994             =item L<Moo>
995              
996             =item L<Sub::Install>
997              
998             =item L<Try::Tiny>
999              
1000             =item L<Unexpected>
1001              
1002             =back
1003              
1004             =head1 Incompatibilities
1005              
1006             There are no known incompatibilities in this module
1007              
1008             =head1 Bugs and Limitations
1009              
1010             There are no known bugs in this module. Please report problems to
1011             http://rt.cpan.org/NoAuth/Bugs.html?Dist=Class-Usul.
1012             Patches are welcome
1013              
1014             =head1 Acknowledgements
1015              
1016             Larry Wall - For the Perl programming language
1017              
1018             L<MooseX::Daemonize> - Stole some code from that module
1019              
1020             =head1 Author
1021              
1022             Peter Flanigan, C<< <pjfl@cpan.org> >>
1023              
1024             =head1 License and Copyright
1025              
1026             Copyright (c) 2017 Peter Flanigan. All rights reserved
1027              
1028             This program is free software; you can redistribute it and/or modify it
1029             under the same terms as Perl itself. See L<perlartistic>
1030              
1031             This program is distributed in the hope that it will be useful,
1032             but WITHOUT WARRANTY; without even the implied warranty of
1033             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE
1034              
1035             =cut
1036              
1037             # Local Variables:
1038             # mode: perl
1039             # tab-width: 3
1040             # End:
1041             # vim: expandtab shiftwidth=3: