CatalystX::Usul::Utils - Base class utility methods for models and programs

   package CatalystX::Usul::Model;

   use parent qw(CatalystX::Usul CatalystX::Usul::Utils);

   package YourApp::Model::YourModel;

   use parent qw(CatalystX::Usul::Model);

   @pids = $self->child_list( $pid );

   $response = $self->popen( $cmd, @input );

   $bool = $self->process_exists( file => $path, pid => $pid );

   $response = $self->run_cmd( $cmd, $args );

   $result = $self->send_email( $args );

   $self->signal_process( [{] param => value, ... [}] );

# @(#)$Id: Utils.pm 576 2009-06-09 23:23:46Z pjf $

package CatalystX::Usul::Utils;

use strict;
use warnings;
use version; our $VERSION = qv( sprintf '0.3.%d', q$Rev: 576 $ =~ /\d+/gmx );
use parent qw(CatalystX::Usul::Base);

use CatalystX::Usul::Response;
use English qw(-no_match_vars);
use Email::Send;
use Email::MIME;
use Email::MIME::Creator;
use IO::Handle;
use IO::Select;
use IPC::Open3;
use MIME::Types;
use POSIX qw(:signal_h :errno_h :sys_wait_h);
use Proc::ProcessTable;
use Template;

my $NUL = q(); my ($ERROR, $WAITEDPID);

sub child_list {
   my ($self, $pid, $ref) = @_; my ($child, $p, $t); my @pids = ();

   unless (defined $ref) {
      $t = Proc::ProcessTable->new(); $ref = {};

      for $p (@{ $t->table }) { $ref->{ $p->pid } = $p->ppid }
   }

   if (exists $ref->{ $pid }) {
      for $child (grep { $ref->{ $_ } == $pid } keys %{ $ref }) {
         push @pids, $self->child_list( $child, $ref ); # Recurse
      }

      push @pids, $pid;
   }

   return @pids;
}

sub cleaner {
   $ERROR = 1; $WAITEDPID = wait; $SIG{PIPE} = \&cleaner; return;
}

sub handler {
   my $pid = waitpid -1, WNOHANG();

   $WAITEDPID = $pid if ($pid != -1 and WIFEXITED( $CHILD_ERROR ));

   $SIG{CHLD} = \&handler; # in case of unreliable signals
   return;
}

sub popen {
   my ($self, $cmd, @input) = @_; my ($e, $pid, @ready);

   my $err = IO::Handle->new();
   my $rdr = IO::Handle->new();
   my $wtr = IO::Handle->new();
   my $res = CatalystX::Usul::Response->new();

   eval {
      $ERROR = 0; $SIG{CHLD} = \&handler; $SIG{PIPE} = \&cleaner;
      $pid   = open3( $wtr, $rdr, $err, $cmd );

      if (defined $input[0]) {
         for my $line (@input) {
            print {$wtr} $line
               or $self->throw( error => 'IO error [_1]', args =>[ $ERRNO ] );
         }
      }

      $wtr->close;
   };

   if ($e = $self->catch) { $err->close; $rdr->close; $self->throw( $e ) }

   if ($ERROR) {
      $e = do { local $RS = undef; <$err> }; $err->close; $rdr->close;
      $self->throw( $e );
   }

   my $selector = IO::Select->new(); $selector->add( $err, $rdr );

   while (@ready = $selector->can_read) {
      for my $fh (@ready) {
         if (fileno $fh == fileno $err) {
            $e = do { local $RS = undef; <$err> };
         }
         else { $res->out( do { local $RS = undef; <$rdr> } ) }

         $selector->remove( $fh ) if (eof $fh);
      }
   }

   waitpid $pid, 0;

   $self->throw( $e ) if ($e);

   return $res;
}

sub process_exists {
   my ($self, @rest) = @_;
   my $args     = $self->arg_list( @rest );
   my $pid_file = $args->{file};
   my $pid      = $args->{pid};

   if ($pid_file and -f $pid_file) {
      $pid = $self->io( $pid_file )->chomp->lock->getline;
   }

   return 0 if (not $pid or $pid !~ m{ \d+ }mx);
   return 1 if (CORE::kill 0, $pid);
   return 0;
}

sub run_cmd {
   my ($self, $cmd, @rest) = @_; my ($e, $err, $text);

   $self->throw( 'No command specified' ) unless ($cmd);

   my $args = $self->_get_run_cmd_args( @rest );
   my $prog = $self->basename( (split q( ), $cmd)[0] );

   if ($args->{async} and not $args->{out}) {
      $args->{out} = $args->{out_ref}->pathname; $args->{err} = q(out);
   }

   my $out = $args->{out} ? $args->{out} : $args->{out_ref}->pathname;

   if ($args->{err}) { $err = $args->{err} eq q(out) ? $out : $args->{err} }
   else { $err = $args->{err_ref}->pathname }

   $cmd .= ' 1>'.$out if ($out ne q(stdout));
   $cmd .= $err eq $out ? ' 2>&1' : ($err ne q(stderr) ? ' 2>'.$err : $NUL);
   $cmd .= ' & echo $! 1>'.$args->{pid_ref}->pathname if ($args->{async});

   $self->log_debug( "Running $cmd" ) if ($args->{debug});

   my $rv = eval { local $SIG{CHLD} = \&handler; system $cmd; };

   if ($e = $self->catch) { $e->rv( -1 ); $self->throw( $e ) }

   if ($rv == -1) {
      $text = 'Program [_1] failed to start [_2]';
      $self->throw( error => $text, args  => [ $prog, $ERRNO ], rv => -1 );
   }

   my $res = CatalystX::Usul::Response->new();

   $res->sig( $rv & 127 ); $res->core( $rv & 128 ); $rv = $rv >> 8;

   if ($args->{async}) {
      if ($rv != 0) {
         $text = 'Program [_1] failed to start';
         $self->throw( error => $text, args => [ $prog ], rv => $rv );
      }

      my $pid = $self->io( $args->{pid_ref}->pathname )->chomp->getline
             || q(pid unknown);

      $res->out( "Started ${prog}(${pid}) in the background" );
      return $res;
   }

   if ($out ne q(stdout) and -f $out and $text = $self->io( $out )->slurp) {
      $res->stdout( $text );
      $res->out( join "\n", map    { $self->strip_leader( $_ ) }
                            grep   { !m{ (?: Started | Finished ) }msx }
                            split m{ [\n] }msx, $text );
   }

   if ($err ne q(stderr)) {
      if ($err ne $out) {
         if (-f $err and $text = $self->io( $err )->slurp) {
            $res->stderr( $text ); chomp $text;
         }
         else { $text = $NUL }
      }
      else { $res->stderr( $res->stdout ); $text = $res->out; chomp $text }
   }

   if ($rv > $args->{expected_rv}) {
      $text .= ' code [_1]' if ($args->{debug});
      $self->throw( error => $text, args => [ $rv ], rv => $rv );
   }

   return $res;
}

sub send_email {
   my ($self, $args) = @_; my ($email, $text, $tmplt);

   $self->throw( 'No parameters specified' ) unless ($args);

   $email->{attributes} =  $args->{attributes} || {};
   $email->{header    } =
      [ From            => $args->{from      } || q(unknown),
        To              => $args->{to        } || q(postmaster),
        Subject         => $args->{subject   } || q(No subject) ];

   unless ($email->{body} = $args->{body}) {
      $self->throw( 'No message body' ) unless ($args->{template});

      if ($tmplt = Template->new( $self )) {
         if ($tmplt->process( $args->{template}, $args->{stash}, \$text )) {
            $email->{body} = $text;
         }
         else { $self->throw( $tmplt->error() ) }
      }
      else { $self->throw( $Template::ERROR ) }
   }

   if (exists $args->{attachments}) {
      my $types = MIME::Types->new( only_complete => 1 );
      my $part  = Email::MIME->create( attributes => $email->{attributes},
                                       body       => delete $email->{body} );
      $email->{parts} = [ $part ];

      while (my ($attachment, $path) = each %{ $args->{attachments} }) {
         my $body  = $self->io( $path )->lock->all;
         my $file  = $self->basename( $path );
         my $mime  = $types->mimeTypeOf( $file );
         my $attrs = { content_type => $mime->type,
                       encoding     => $mime->encoding,
                       filename     => $file,
                       name         => $attachment };
         $part     = Email::MIME->create( attributes => $attrs,
                                          body       => $body );
         push @{ $email->{parts} }, $part;
      }
   }

   my $sender = Email::Send->new( {
      mailer      => $args->{mailer} || q(SMTP),
      mailer_args => [ Host => $args->{mailer_host} || q(localhost) ],
   } );

   return $sender->send( Email::MIME->create( %{ $email } ) );
}

sub signal_process {
   my ($self, @rest) = @_; my $args = $self->arg_list( @rest );
   my ($io, $mpid, $pid, $pids, $pid_file, @pids, $sig);

   $sig      = $args->{sig } || q(TERM);
   $pids     = $args->{pids} || [];
   $pid_file = $args->{file};

   push @{ $pids }, $args->{pid} if ($args->{pid});

   if ($pid_file and -f $pid_file) {
      push @{ $pids }, $self->io( $pid_file )->chomp->lock->getlines;

      unlink $pid_file if ($sig eq q(TERM));
   }

   unless (defined $pids->[0] and $pids->[0] =~ m{ \d+ }mx) {
      $self->throw( 'Bad process id' );
   }

   for $mpid (@{ $pids }) {
      if (exists $args->{flag} and $args->{flag} =~ m{ one }imx) {
         CORE::kill $sig, $mpid;
         next;
      }

      @pids = reverse $self->child_list( $mpid );

      for $pid (@pids) { CORE::kill $sig, $pid }

      next unless ($args->{force});

      sleep 3; @pids = reverse $self->child_list( $mpid );

      for $pid (@pids) { CORE::kill q(KILL), $pid }
   }

   return;
}

# Private methods

sub _get_run_cmd_args {
   my ($self, $args) = @_;

   $args                ||= {};
   $args->{debug      } ||= $self->debug;
   $args->{expected_rv} ||= 0;
   $args->{tempdir    } ||= $self->tempdir;
   # Three different semi-random file names in the temp directory
   $args->{err_ref    } ||= $self->tempfile( $args->{tempdir} );
   $args->{out_ref    } ||= $self->tempfile( $args->{tempdir} );
   $args->{pid_ref    } ||= $self->tempfile( $args->{tempdir} );

   return $args;
}

1;

__END__

# Local Variables:
# mode: perl
# tab-width: 3
# End: