49
+ − 1 package IMPL::Test::Straps;
+ − 2 use strict;
+ − 3 use warnings;
+ − 4
+ − 5 use base qw(Test::Harness::Straps IMPL::Object IMPL::Object::Autofill IMPL::Object::Serializable);
+ − 6 use IMPL::Class::Property;
+ − 7
+ − 8 __PACKAGE__->PassThroughArgs;
+ − 9
+ − 10 BEGIN {
+ − 11 public property Executors => prop_all | prop_list;
+ − 12 }
+ − 13
+ − 14 sub new {
+ − 15 my $class = shift;
+ − 16 my $this = $class->Test::Harness::Straps::new();
+ − 17
+ − 18 $this->callCTOR(@_);
+ − 19
+ − 20 return $this;
+ − 21 }
+ − 22
+ − 23 sub surrogate {
+ − 24 my $class = shift;
+ − 25 return $class->Test::Harness::Straps::new();
+ − 26 }
+ − 27
+ − 28 sub analyze_file {
+ − 29 my($self, $file) = @_;
+ − 30
+ − 31 unless( -e $file ) {
+ − 32 $self->{error} = "$file does not exist";
+ − 33 return;
+ − 34 }
+ − 35
+ − 36 unless( -r $file ) {
+ − 37 $self->{error} = "$file is not readable";
+ − 38 return;
+ − 39 }
+ − 40
+ − 41 # *sigh* this breaks under taint, but open -| is unportable.
+ − 42 my $h = $self->ExecuteFile($file);
+ − 43 unless ($h) {
+ − 44 print "can't run $file. $!\n";
+ − 45 return;
+ − 46 }
+ − 47
+ − 48 my $results = $self->analyze_fh($file, $h);
+ − 49 my $exit = close $h;
+ − 50
+ − 51 $results->set_wait($?);
+ − 52 if ( $? && $self->{_is_vms} ) {
+ − 53 $results->set_exit($?);
+ − 54 }
+ − 55 else {
+ − 56 $results->set_exit( Test::Harness::Straps::_wait2exit($?) );
+ − 57 }
+ − 58 $results->set_passing(0) unless $? == 0;
+ − 59
+ − 60 $self->_restore_PERL5LIB();
+ − 61
+ − 62 return $results;
+ − 63 }
+ − 64
+ − 65 sub SelectExecutor {
+ − 66 my ($this,$file) = @_;
+ − 67
+ − 68 return $_->{Executor} foreach grep $file =~ /$_->{Re}/i, $this->Executors;
+ − 69 }
+ − 70
+ − 71 sub ExecuteFile {
+ − 72 my ($this,$file) = @_;
+ − 73
+ − 74 if (my $executor = $this->SelectExecutor($file)) {
+ − 75 return $executor->Execute($file);
+ − 76 }
+ − 77 return undef;
+ − 78 }
+ − 79
+ − 80 sub Execute {
+ − 81 my ($self,$file) = @_;
+ − 82
+ − 83 local $ENV{PERL5LIB} = $self->_INC2PERL5LIB;
+ − 84
+ − 85 open my $h,'-|',$self->_command_line($file) or return undef;
+ − 86
+ − 87 return $h;
+ − 88 }
+ − 89
+ − 90 1;