|
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;
|
