view release on metacpan or  search on metacpan

lib/POE/Component/SmokeBox/Backend.pm  view on Meta::CPAN

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 ( $@ ) {