view release on metacpan or  search on metacpan

lib/Class/Usul/IPC/Cmd.pm  view on Meta::CPAN

package Class::Usul::IPC::Cmd;

use namespace::autoclean;

use Class::Null;
use Class::Usul::Constants    qw( EXCEPTION_CLASS FALSE NUL
                                  OK SPC TRUE UNDEFINED_RV );
use Class::Usul::Functions    qw( arg_list emit_to io is_arrayref
                                  is_coderef is_hashref is_member is_win32
                                  nonblocking_write_pipe_pair
                                  strip_leader throw );
use Class::Usul::Time         qw( nap );
use Class::Usul::Types        qw( ArrayRef Bool LoadableClass Logger
                                  NonEmptySimpleStr Num Object PositiveInt
                                  SimpleStr Str Undef );
use English                   qw( -no_match_vars );
use File::Basename            qw( basename );
use File::DataClass::Types    qw( Directory Path );
use File::Spec::Functions     qw( devnull rootdir tmpdir );
use IO::Handle;
use IO::Select;
use IPC::Open3;
use Module::Load::Conditional qw( can_load );
use POSIX                     qw( _exit setsid sysconf WIFEXITED WNOHANG );
use Scalar::Util              qw( blessed openhandle weaken );
use Socket                    qw( AF_UNIX SOCK_STREAM PF_UNSPEC );
use Sub::Install              qw( install_sub );
use Try::Tiny;
use Unexpected::Functions     qw( TimeOut Unspecified );

use Moo; use warnings NONFATAL => 'all';

our ($CHILD_ENUM, $CHILD_PID);

# Public attributes
has 'async'            => is => 'ro',   isa => Bool, default => FALSE;

has 'close_all_files'  => is => 'ro',   isa => Bool, default => FALSE;

has 'cmd'              => is => 'ro',   isa => ArrayRef | Str,
   required            => TRUE;

has 'detach'           => is => 'ro',   isa => Bool, default => FALSE;

has 'err'              => is => 'ro',   isa => Path | SimpleStr, default => NUL;

has 'expected_rv'      => is => 'ro',   isa => PositiveInt, default => 0;

has 'ignore_zombies'   => is => 'lazy', isa => Bool, builder => sub {
   ($_[ 0 ]->async || $_[ 0 ]->detach) ? TRUE : FALSE };

has 'in'               => is => 'ro',   isa => Path | SimpleStr, coerce => sub {
   (is_arrayref $_[ 0 ]) ? join $RS, @{ $_[ 0 ] } : $_[ 0 ] },
   default             => NUL;

has 'log'              => is => 'lazy', isa => Logger,
   builder             => sub { Class::Null->new };

has 'keep_fhs'         => is => 'lazy', isa => ArrayRef,
   builder             => sub {
      $_[ 0 ]->log->can( 'filehandle' ) ? [ $_[ 0 ]->log->filehandle ] : [] };

has 'max_pidfile_wait' => is => 'ro',   isa => PositiveInt, default => 15;

has 'nap_time'         => is => 'ro',   isa => Num, default => 0.3;

has 'out'              => is => 'ro',   isa => Path | SimpleStr, default => NUL;

has 'partition_cmd'    => is => 'ro',   isa => Bool, default => TRUE;

has 'pidfile'          => is => 'lazy', isa => Path, coerce => TRUE,
   builder             => sub { $_[ 0 ]->rundir->tempfile };

has 'response_class'   => is => 'lazy', isa => LoadableClass, coerce => TRUE,
   default             => 'Class::Usul::Response::IPC';

has 'rundir'           => is => 'lazy', isa => Directory, coerce => TRUE,
   builder             => sub { $_[ 0 ]->tempdir };

has 'tempdir'          => is => 'lazy', isa => Directory,
   builder             => sub { tmpdir }, coerce => TRUE,
   handles             => { _tempfile => 'tempfile' };

has 'timeout'          => is => 'ro',   isa => PositiveInt, default => 0;

lib/Class/Usul/IPC/Cmd.pm  view on Meta::CPAN

my $_send_exec_failure = sub {
   my ($fh, $error) = @_; utf8::encode $error;

   emit_to $fh, pack 'IIa*', 0+$ERRNO, length $error, $error; close $fh;
   _exit 255;
};

my $_send_in = sub {
   my ($fh, $in) = @_; $in or return;

   if    (blessed $in)                      { emit_to $fh, $in->slurp }
   elsif ($in ne 'null' and $in ne 'stdin') { emit_to $fh, $in }

   return;
};

my $_open3 = sub {
   local (*TO_CHLD_R,     *TO_CHLD_W);
   local (*FR_CHLD_R,     *FR_CHLD_W);
   local (*FR_CHLD_ERR_R, *FR_CHLD_ERR_W);

   $_make_socket_pipe->( *TO_CHLD_R,     *TO_CHLD_W     );
   $_make_socket_pipe->( *FR_CHLD_R,     *FR_CHLD_W     );
   $_make_socket_pipe->( *FR_CHLD_ERR_R, *FR_CHLD_ERR_W );

   my $pid = open3( '>&TO_CHLD_R', '<&FR_CHLD_W', '<&FR_CHLD_ERR_W', @_ );

   return ($pid, *TO_CHLD_W, *FR_CHLD_R, *FR_CHLD_ERR_R);
};

# Private methods
my $_detach_process = sub { # And this method came from MooseX::Daemonize
   my $self = shift;

   setsid or throw 'Cannot detach from controlling process';
   $SIG{HUP} = 'IGNORE'; fork and _exit OK;
#  Clearing file creation mask allows direct control of the access mode of
#  created files and directories in open, mkdir, and mkpath functions
   umask 0;

   if ($self->close_all_files) { # Close all fds except the ones we should keep
      my $openmax = sysconf( &POSIX::_SC_OPEN_MAX );

      (not defined $openmax or $openmax < 0) and $openmax = 64;

      for (grep { not is_member $_, $self->keep_fhs } 0 .. $openmax) {
         POSIX::close( $_ );
      }
   }

   $self->pidfile->println( $PID );
   return;
};

my $_ipc_run_harness = sub {
   my ($self, $cmd_ref, @cmd_args) = @_;

   if ($self->async) {
      is_coderef $cmd_ref->[ 0 ] and $cmd_ref = $cmd_ref->[ 0 ];

      my $pidfile = $self->pidfile; weaken( $pidfile );
      my $h = IPC::Run::harness( $cmd_ref, @cmd_args, init => sub {
         IPC::Run::close_terminal(); $pidfile->println( $PID ) }, '&' );

      $h->start; return ( 0, $h );
   }

   my $h  = IPC::Run::harness( $cmd_ref, @cmd_args ); $h->run;
   my $rv = $h->full_result || 0; $rv =~ m{ unknown }msx and throw $rv;

   return ( $rv, $h );
};

my $_new_async_response = sub {
   my ($self, $pid) = @_; my $prog = basename( $self->cmd->[ 0 ] );

   $self->log->debug( my $out = "Running ${prog}(${pid}) in the background" );

   return $self->response_class->new( out => $out, pid => $pid );
};

my $_redirect_child_io = sub {
   my ($self, $pipes) = @_;

   my $in = $self->in || 'null'; my $out = $self->out; my $err = $self->err;

   if ($self->async or $self->detach) { $out ||= 'null'; $err ||= 'null' }

   $in  eq 'stdin'
      or $_redirect_stdin-> ( ($in  eq 'null') ? devnull
                                               : $pipes->[ 0 ]->[ 0 ] );
   $out eq 'stdout'
      or $_redirect_stdout->( (  blessed $out) ? "${out}"
                            : ($out eq 'null') ? devnull
                                               : $pipes->[ 1 ]->[ 1 ] );
   $err eq 'stderr'
      or $_redirect_stderr->( (  blessed $err) ? "${err}"
                            : ($err eq 'null') ? devnull
                                               : $pipes->[ 2 ]->[ 1 ] );
   return;
};

my $_return_codes_or_throw = sub {
   my ($self, $cmd, $e_num, $e_str) = @_;

   $e_str ||= 'Unknown error'; chomp $e_str;

   if ($e_num == UNDEFINED_RV) {
      my $error = 'Program [_1] failed to start: [_2]';
      my $prog  = basename( (split SPC, $cmd)[ 0 ] );

      throw $error, [ $prog, $e_str ], level => 3, rv => UNDEFINED_RV;
   }

   my $rv = $e_num >> 8; my $core = $e_num & 128; my $sig = $e_num & 127;

   if ($rv > $self->expected_rv) {
      $self->log->debug( my $error = "${e_str} rv ${rv}" );
      throw $error, level => 3, rv => $rv;
   }