Mercurial > pub > Impl

comparison Lib/IMPL/Test/Straps.pm @ 0:03e58a454b20

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Создан репозитарий
author Sergey
date Tue, 14 Jul 2009 12:54:37 +0400
parents
children 16ada169ca75
comparison
equal deleted inserted replaced
-1:000000000000 0:03e58a454b20
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;