File Coverage

blib/lib/POE/Component/SmokeBox/Backend.pm

Criterion	Covered	Total	%
statement	248	307	80.7
branch	96	162	59.2
condition	21	57	36.8
subroutine	33	39	84.6
pod	7	7	100.0
total	405	572	70.8

package POE::Component::SmokeBox::Backend;
$POE::Component::SmokeBox::Backend::VERSION = '0.58';
#ABSTRACT: smoker backend to POE::Component::SmokeBox

use strict;
use warnings;
use Carp;
use Storable;
use File::Temp ();
use File::Path qw[rmtree];
use File::Spec;
use POSIX qw( O_CREAT O_RDWR O_RDONLY );         # for SDBM_File
use SDBM_File;
use POE qw[Wheel::Run Filter::Line];
use Digest::SHA qw[sha256_hex];
use Regexp::Assemble;
use Env::Sanctify;
use Module::Pluggable search_path => 'POE::Component::SmokeBox::Backend', sub_name => 'backends', except => 'POE::Component::SmokeBox::Backend::Base';

use constant ON_BSD => $^O =~ m!^(free|midnight|dragonfly|open)(bsd)?$! ? 1 : 0;

my $GOT_KILLFAM;
my $GOT_PTY;

BEGIN {
        $GOT_KILLFAM = 0;
        eval {
                require Proc::ProcessTable;
                $GOT_KILLFAM = 1;
        };
        $GOT_PTY = 0;
        eval {
                require IO::Pty;
                $GOT_PTY = 1;
        };
	if ( $^O eq 'MSWin32' ) {
		require POE::Wheel::Run::Win32;

		# MSWin32: Disable critical error popups
		# Thanks to https://rt.cpan.org/Public/Bug/Display.html?id=56547

		# Call kernel32.SetErrorMode(SEM_FAILCRITICALERRORS):
		# "The system does not display the critical-error-handler message box.
		# Instead, the system sends the error to the calling process." and
		# "A child process inherits the error mode of its parent process."
		if ( eval { require Win32API::File } ) {
			Win32API::File->import( qw( SetErrorMode SEM_FAILCRITICALERRORS SEM_NOGPFAULTERRORBOX ) );
			SetErrorMode( SEM_FAILCRITICALERRORS() | SEM_NOGPFAULTERRORBOX() );
		} else {
			warn "Unable to use Win32API::File -> $@";
			warn 'This means sometimes perl.exe will popup a dialog box... Annoying!';
		}
	}
}

my @cmds = qw(check index smoke);

sub check {
  my $package = shift;
  return $package->spawn( @_, command => 'check' );
}

sub index {
  my $package = shift;
  return $package->spawn( @_, command => 'index' );
}

sub smoke {
  my $package = shift;
  return $package->spawn( @_, command => 'smoke' );
}

sub spawn {
  my $package = shift;
  my %opts = @_;
  my $extra = { map { ( $_ => delete $opts{$_} ) } grep { /^\_/ } keys %opts };
  $opts{extra} = $extra;
  $opts{lc $_} = delete $opts{$_} for keys %opts;
  my $options = delete $opts{options};
  unless ( $opts{event} ) {
     carp "The 'event' parameter is a mandatory requirement\n";
     return;
  }
  $opts{idle} = 600 unless $opts{idle};
  $opts{timeout} = 3600 unless $opts{timeout};
  $opts{timer} = 60 unless $opts{timer};
  $opts{reaper} = 30 unless $opts{reaper};
  $opts{type} = 'CPANPLUS::YACSmoke' unless $opts{type};
  $opts{command} = lc $opts{command} || 'check';
  $opts{command} = 'check' unless grep { $_ eq $opts{command} } @cmds;
  $opts{perl} = $^X unless $opts{perl}; # and -e $opts{perl};
  $opts{no_log} = 0 unless $opts{no_log};
  $opts{check_warnings} = 1 unless exists $opts{check_warnings};

  if ( $opts{check_warnings} ) {
     require String::Perl::Warnings;
  }

  if ( $opts{command} eq 'smoke' and !$opts{module} ) {
     carp "You must specify a 'module' with 'smoke'\n";
     return;
  }
  my $self = bless \%opts, $package;
  my @backends = $self->backends();
  my ($type) = grep { /\Q$opts{type}\E$/ } @backends;
  unless ( $type ) {
     carp "No such backend '$opts{type}'\n";
     return;
  }
  eval "require $type;";
  if ( $@ ) {
     carp "Could not load '$type' '$@'\n";
     return;
  }
  $self->{backend} = $type->new();
  unless ( $self->{backend} or $self->{backend}->can($self->{command}) ) {
     croak "Problem loading backend '$type'\n";
     return;
  }
  if ( $self->{backend}->can('digest') ) {
     $self->{_reset_digest} = $self->{backend}->digest();
  }
  my $cmd = $self->{command};
  $self->{program} = $self->{backend}->$cmd;
  unless ( $self->{program} or ref $self->{program} eq 'ARRAY' ) {
     carp "The backend method '$cmd' did not return an arrayref\n";
     return;
  }
  unshift @{ $self->{program} }, $self->{perl};
  push @{ $self->{program} }, $self->{module} if $cmd eq 'smoke';
  $self->{session_id} = POE::Session->create(
     package_states => [
	$self => { shutdown => '_shutdown', },
	$self => [qw(_start _spawn_wheel _wheel_error _wheel_closed _wheel_stdout _wheel_stderr _wheel_idle _wheel_reap _wheel_kill _sig_child)],
     ],
     heap => $self,
     ( ref($options) eq 'HASH' ? ( options => $options ) : () ),
  )->ID();
  return $self;
}

sub session_id {
  return $_[0]->{session_id};
}

sub current_log {
  my $self = shift;
  return unless $self->{_wheel_log};
  my $item = Storable::dclone( $self->{_wheel_log} );
  return $item;
}

sub shutdown {
  my $self = shift;
  $poe_kernel->post( $self->session_id() => 'shutdown' => @_ );
}

sub _start {
  my ($kernel,$sender,$self) = @_[KERNEL,SENDER,OBJECT];
  $self->{session_id} = $_[SESSION]->ID();
  if ( $kernel == $sender and !$self->{session} ) {
	croak "Not called from another POE session and 'session' wasn't set\n";
  }
  my $sender_id;
  if ( $self->{session} ) {
    if ( my $ref = $kernel->alias_resolve( $self->{session} ) ) {
	$sender_id = $ref->ID();
    }
    else {
	croak "Could not resolve 'session' to a valid POE session\n";
    }
  }
  else {
    $sender_id = $sender->ID();
  }
  $kernel->refcount_increment( $sender_id, __PACKAGE__ );
  $self->{session} = $sender_id;
  $kernel->detach_myself() if $kernel != $sender;

  $self->{_wheel_log} = [ ];

  if ( !$self->{_reset_digest} ) {
    $self->_tie_digests();
  }
  else {
    $self->{_digests} = { };
  }

  $self->{_loop_detect} = 0;
  $self->{start_time} = time();

  $kernel->yield( '_spawn_wheel' );
  return;
}

sub _shutdown {
  my ($kernel,$self) = @_[KERNEL,OBJECT];
  if ( !$self->{_reset_digest} ) {
    $self->_untie_digests();
  }
  else {
    delete $self->{_digests};
  }
  $self->{term_kill} = 1;
  $kernel->yield( '_wheel_kill', 'Killing current due to component shutdown event' );
  return;
}

# Digests tie and untie

sub _tie_digests {
  my $self = shift;
  $self->{_tempdir} = File::Temp->newdir();
  $self->{_tmpdirname} = $self->{_tempdir}->dirname;
  my $file = File::Spec->catfile( $self->{_tmpdirname}, 'digests.dat' );
  $self->{_digests} = { };
  tie %{ $self->{_digests} }, 'SDBM_File', $file, O_CREAT|O_RDWR, 0644 or die "Could not tie: $!\n";
  return 1;
}

sub _untie_digests {
  my $self = shift;
  if ( $self->{_digests} ) {
    untie %{ $self->{_digests} };
    delete $self->{_digests};
    delete $self->{_tempdir};
    rmtree( $self->{_tmpdirname} ) if -d $self->{_tmpdirname};
  }
  return 1;
}

sub _spawn_wheel {
  my ($kernel,$self) = @_[KERNEL,OBJECT];

  # do we need to process callbacks?
  if ( $self->{do_callback} ) {
    # Ask it if we should process this job or not?
    unless ( $self->{do_callback}->( 'BEFORE', $self ) ) {
      warn "Callback denied job, aborting!\n" if $self->{debug} or $ENV{PERL5_SMOKEBOX_DEBUG};
      my $job = $self->_finalize_job( -1 );
      $job->{cb_kill} = 1;
      $kernel->post( $self->{session}, $self->{event}, $job );
      return;
    }
  }

  # Set appropriate %ENV values before we fork()
  my $sanctify = Env::Sanctify->sanctify(
	env => $self->{env},
	sanctify => [
			'^POE_',
			'^PERL5_SMOKEBOX',
			'^HARNESS_',
			'^(PERL5LIB|TAP_VERSION|TEST_VERBOSE)$',
      '^AUTHOR_TESTING$',
      '^PERL_TEST',
  ] );
  my $type = 'POE::Wheel::Run';
  $type .= '::Win32' if $^O eq 'MSWin32';
  $self->{wheel} = $type->new(
    Program     => $self->{program},
    StdoutEvent => '_wheel_stdout',
    StderrEvent => '_wheel_stderr',
    StdoutFilter => POE::Filter::Line->new( InputLiteral => "\n" ),
    StderrFilter => POE::Filter::Line->new( InputLiteral => "\n" ),
    ErrorEvent  => '_wheel_error',
    CloseEvent  => '_wheel_closed',
    ( $GOT_PTY ? ( Conduit => 'pty-pipe' ) : () ),
  );
  # Restore the %ENV values
  $sanctify->restore();
  $self->{_wheel_time} = time();
  $self->{PID} = $self->{wheel}->PID();
  $kernel->sig_child( $self->{PID}, '_sig_child' );
  $kernel->delay( '_wheel_idle', $self->{timer} ) unless $self->{command} eq 'index';
  return;
}

sub _sig_child {
  my ($kernel,$self,$thing,$pid,$status) = @_[KERNEL,OBJECT,ARG0..ARG2];
  push @{ $self->{_wheel_log} }, "$thing $pid $status" if ! $self->{no_log};
  warn "$thing $pid $status\n" if $self->{debug} or $ENV{PERL5_SMOKEBOX_DEBUG};
  $kernel->sig_handled();
  $kernel->delay( '_wheel_idle' );

  my $job = $self->_finalize_job( $status );

  # do we need to process callbacks?
  if ( $self->{do_callback} ) {
    # Inform the callback that the job is done
    $self->{do_callback}->( 'AFTER', $self, $job );
  }

  $kernel->post( $self->{session}, $self->{event}, $job );
  $kernel->delay( '_wheel_reap' => $self->{reaper} ) if $self->{wheel};
  return;
}

sub _finalize_job {
  my( $self, $status ) = @_;

  $self->{end_time} = time();

  if ( !$self->{_reset_digest} ) {
    $self->_untie_digests();
  }
  else {
    delete $self->{_digests};
  }

  delete $self->{_loop_detect};

  my $job = { };
  $job->{status} = $status;
  $job->{log} = $self->{_wheel_log};
  $job->{$_} = $self->{extra}->{$_} for keys %{ $self->{extra} };
  $job->{$_} = $self->{$_} for grep { $self->{$_} } qw(command env PID start_time end_time idle_kill excess_kill term_kill perl type);
  $job->{program} = $self->{program} if $self->{debug} or $ENV{PERL5_SMOKEBOX_DEBUG};
  $job->{module} = $self->{module} if $self->{command} eq 'smoke';
  $poe_kernel->refcount_decrement( $self->{session}, __PACKAGE__ );

  return $job;
}

sub _wheel_reap {
  my ($kernel,$self) = @_[KERNEL,OBJECT];
  warn "wheel reaped\n" if $self->{debug} or $ENV{PERL5_SMOKEBOX_DEBUG};
  delete $self->{wheel};
  return;
}

sub _wheel_error {
  my ($self,$operation,$errnum,$errstr,$wheel_id) = @_[OBJECT,ARG0..ARG3];
  $errstr = "remote end closed" if $operation eq "read" and !$errnum;
  warn "wheel $wheel_id generated $operation error $errnum: $errstr\n" if $self->{debug} or $ENV{PERL5_SMOKEBOX_DEBUG};
  return;
}

sub _wheel_closed {
  my ($kernel,$self) = @_[KERNEL,OBJECT];
  $kernel->delay( '_wheel_idle' );
  $kernel->delay( '_wheel_reap' );
  warn "wheel closed\n" if $self->{debug} or $ENV{PERL5_SMOKEBOX_DEBUG};
  delete $self->{wheel};
  return;
}

sub _wheel_stdout {
  my ($self, $input, $wheel_id) = @_[OBJECT, ARG0, ARG1];
  return if $self->{_killed};
  $self->{_wheel_time} = time();
  push @{ $self->{_wheel_log} }, $input if ! $self->{no_log};
  warn $input, "\n" if $self->{debug} or $ENV{PERL5_SMOKEBOX_DEBUG};
  if ( $self->_detect_loop( $input, 'stdout' ) ) {
    $self->{excess_kill} = 1;
    $poe_kernel->yield( '_wheel_kill', 'Killing current run due to detection of looping output' );
  }
  return;
}

sub _wheel_stderr {
  my ($self, $input, $wheel_id) = @_[OBJECT, ARG0, ARG1];
  return if $self->{_killed};
  $self->{_wheel_time} = time();
  push @{ $self->{_wheel_log} }, $input if ! $self->{no_log};
  if ( $self->{debug} or $ENV{PERL5_SMOKEBOX_DEBUG} ) {
    if ( length( $input ) > 5000 ) {
      warn "[SUPPRESSED OUTPUT > 5000]\n";
    }
    else {
      warn $input, "\n";
    }
  }
  if ( $self->_detect_loop( $input, 'stderr' ) ) {
    $self->{excess_kill} = 1;
    $poe_kernel->yield( '_wheel_kill', 'Killing current run due to detection of looping output' );
  }
  return;
}

sub _detect_loop {
  my $self = shift;
  my $input = shift || return;
  my $handle = shift || 'stdout';
  return if $self->{_loop_detect};
  if ( my $reset = $self->{_reset_digest} ) {
    if ( eval { $input =~ $reset } ) {
      warn "Resetting digests\n" if $self->{debug} or $ENV{PERL5_SMOKEBOX_DEBUG};
      $self->{_digests} = { };
    }
  }
  return if $input =~ /^\[(MSG|ERROR)\]/;
  my $digest = sha256_hex( $input );

  my $weighting;
  if ( ON_BSD and $handle eq 'stderr' and _bsd_compiler_warnings($input) ) {
    $weighting = 0.01;
  }
  elsif ( $self->{check_warnings} and length( $input ) <= 5000 ) {
    $weighting = ( $handle eq 'stderr' and String::Perl::Warnings::is_warning($input) ) ? 1 : 10;
  } else {
    $weighting = $handle eq 'stderr' ? 1 : 10;
  }

  if ( exists $self->{_digests}->{ $digest } ) {
    $self->{_digests}->{ $digest } += $weighting;
  }
  else {
    $self->{_digests}->{ $digest } = $weighting;
  }
  return unless ++$self->{_digests}->{ $digest } > 3000;
  return $self->{_loop_detect} = 1;
}

{
  my $re = Regexp::Assemble->new()
              ->add('note: expanded from macro')
              ->add('note: .+? token is here')
              ->add('tokens terminating statement expression appear in different macro expansion contexts')
              ->add('tokens introducing statement expression appear in different macro expansion contexts')
              ->add('STMT_START')
              ->add('STMT_END')
              ->add('PUSHMARK')
              ->add('XSRETURN')
              ->add('EXTEND')
              ->add('SvTAINT')
              ->add('SvCUR_set')
              ->add('PUSHTARG')
              ->add('^')
              ->add('~')
              ->re;
  sub _bsd_compiler_warnings {
    my $line = shift;
    return 1 if $line =~ m!$re!;
    return;
  }
}

sub _wheel_idle {
  my ($kernel,$self) = @_[KERNEL,OBJECT];
  my $now = time();
  if ( $now - $self->{_wheel_time} >= $self->{idle} ) {
    $self->{idle_kill} = 1;
    $kernel->yield( '_wheel_kill', 'Killing current run due to excessive idle' );
    return;
  }
  if ( $now - $self->{start_time} >= $self->{timeout} ) {
    $self->{excess_kill} = 1;
    $kernel->yield( '_wheel_kill', 'Killing current run due to excessive run-time' );
    return;
  }
  $kernel->delay( '_wheel_idle', 60 );
  return;
}

sub _wheel_kill {
  my ($kernel,$self,$reason) = @_[KERNEL,OBJECT,ARG0];
  return if $self->{_killed};
  $self->{_killed} = 1;
  push @{ $self->{_wheel_log} }, $reason if ! $self->{no_log};
  warn $reason, "\n" if $self->{debug} or $ENV{PERL5_SMOKEBOX_DEBUG};
  if ( $^O eq 'MSWin32' and $self->{wheel} ) {
    $self->{wheel}->kill();
  }
  else {
    if ( !$self->{no_grp_kill} ) {
      if ( $^O eq 'solaris' ) {
	 kill( 9, '-' . $self->{wheel}->PID() ) if $self->{wheel};
      }
      else {
         $self->{wheel}->kill(-9) if $self->{wheel};
      }
    }
#    elsif ( $GOT_KILLFAM ) {
#      _kill_family( 9, $self->{wheel}->PID() ) if $self->{wheel};
#    }
    else {
      $self->{wheel}->kill(9) if $self->{wheel};
    }
  }
  return;
}

1;

__END__