annotate Lib/IMPL/Test/Straps.pm @ 27:b544a772b654

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