File Coverage

blib/lib/Apache/TestHarness.pm
Criterion Covered Total %
statement 27 118 22.9
branch 0 42 0.0
condition 0 10 0.0
subroutine 9 16 56.2
pod 0 6 0.0
total 36 192 18.8


line stmt bran cond sub pod time code
1             # Licensed to the Apache Software Foundation (ASF) under one or more
2             # contributor license agreements. See the NOTICE file distributed with
3             # this work for additional information regarding copyright ownership.
4             # The ASF licenses this file to You under the Apache License, Version 2.0
5             # (the "License"); you may not use this file except in compliance with
6             # the License. You may obtain a copy of the License at
7             #
8             # http://www.apache.org/licenses/LICENSE-2.0
9             #
10             # Unless required by applicable law or agreed to in writing, software
11             # distributed under the License is distributed on an "AS IS" BASIS,
12             # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13             # See the License for the specific language governing permissions and
14             # limitations under the License.
15             #
16             package Apache::TestHarness;
17              
18 6     6   82 use strict;
  6         58  
  6         107  
19 6     6   91 use warnings FATAL => 'all';
  6         55  
  6         100  
20              
21 6     6   227 use Test::Harness ();
  6         56  
  6         63  
22 6     6   104 use Apache::Test ();
  6         55  
  6         86  
23 6     6   175 use Apache::TestSort ();
  6         73  
  6         66  
24 6     6   103 use Apache::TestTrace;
  6         57  
  6         106  
25 6     6   133 use File::Spec::Functions qw(catfile catdir);
  6         56  
  6         132  
26 6     6   94 use File::Find qw(finddepth);
  6         92  
  6         108  
27 6     6   155 use File::Basename qw(dirname);
  6         56  
  6         117  
28              
29             sub inc_fixup {
30             # use blib
31 0     0 0       unshift @INC, map "blib/$_", qw(lib arch);
32              
33             # fix all relative library locations
34 0               for (@INC) {
35 0 0                 $_ = "../$_" unless m,^(/)|([a-f]:),i;
36                 }
37             }
38              
39             #skip tests listed in t/SKIP
40             sub skip {
41 0     0 0       my($self, $file) = @_;
42 0   0           $file ||= catfile Apache::Test::vars('serverroot'), 'SKIP';
43              
44 0 0             return unless -e $file;
45              
46 0               my $fh = Symbol::gensym();
47 0 0             open $fh, $file or die "open $file: $!";
48 0               my @skip;
49 0               local $_;
50              
51 0               while (<$fh>) {
52 0                   chomp;
53 0                   s/^\s+//; s/\s+$//; s/^\#.*//;
  0            
  0            
54 0 0                 next unless $_;
55 0                   s/\*/.*/g;
56 0                   push @skip, $_;
57                 }
58              
59 0               close $fh;
60 0               return join '|', @skip;
61             }
62              
63             #test if all.t would skip tests or not
64             sub run_t {
65 0     0 0       my($self, $file) = @_;
66 0               my $ran = 0;
67              
68 0               my $source_lib = '';
69              
70 0               if (Apache::TestConfig::IS_APACHE_TEST_BUILD) {
71             # so we can find Apache/Test.pm from both the perl-framework/
72             # and Apache-Test/
73              
74 0                   my $top_dir = Apache::Test::vars('top_dir');
75              
76 0                   foreach my $lib (catfile($top_dir, qw(Apache-Test lib)),
77                                      catfile($top_dir, 'lib')) {
78              
79 0 0                     if (-d $lib) {
80              
81 0                           info "adding source lib $lib to \@INC";
82              
83 0                           $source_lib = qq[-Mlib="$lib"];
84              
85 0                           last;
86                         }
87                     }
88                 }
89                 
90 0               my $cmd = qq[$^X $source_lib $file];
91              
92 0               my $h = Symbol::gensym();
93 0 0             open $h, "$cmd|" or die "open $cmd: $!";
94              
95 0               local $_;
96 0               while (<$h>) {
97 0 0                 if (/^1\.\.(\d)/) {
98 0                       $ran = $1;
99 0                       last;
100                     }
101                 }
102              
103 0               close $h;
104              
105 0               $ran;
106             }
107              
108             #if a directory has an all.t test
109             #skip all tests in that directory if all.t prints "1..0\n"
110             sub prune {
111 0     0 0       my($self, @tests) = @_;
112 0               my(@new_tests, %skip_dirs);
113              
114 0               foreach my $test (@tests) {
115 0 0                 next if $test =~ /\.#/; # skip temp emacs files
116 0                   my $dir = dirname $test;
117 0 0                 if ($test =~ m:\Wall\.t$:) {
    0          
118 0 0                     unless ($self->run_t($test)) {
119 0                           $skip_dirs{$dir} = 1;
120 0 0                         @new_tests = grep { m:\Wall\.t$: ||
  0            
121                                                 not $skip_dirs{dirname $_} } @new_tests;
122 0                           push @new_tests, $test;
123                         }
124                     }
125                     elsif (!$skip_dirs{$dir}) {
126 0                       push @new_tests, $test;
127                     }
128                 }
129              
130 0               @new_tests;
131             }
132              
133             sub get_tests {
134 0     0 0       my $self = shift;
135 0               my $args = shift;
136 0               my @tests = ();
137              
138 0 0             my $base = -d 't' ? catdir('t', '.') : '.';
139              
140 0   0           my $ts = $args->{tests} || [];
141              
142 0 0             if (@$ts) {
143 0           for (@$ts) {
144 0 0         if (-d $_) {
145 0           push(@tests, sort <$base/$_/*.t>);
146             }
147             else {
148 0 0         $_ .= ".t" unless /\.t$/;
149 0           push(@tests, $_);
150             }
151             }
152                 }
153                 else {
154 0 0                 if ($args->{tdirs}) {
155 0                       push @tests, map { sort <$base/$_/*.t> } @{ $args->{tdirs} };
  0            
  0            
156                     }
157                     else {
158                         finddepth(sub {
159 0 0   0                               return unless /\.t$/;
160 0                                     my $t = catfile $File::Find::dir, $_;
161 0                                     my $dotslash = catfile '.', "";
162 0                                     $t =~ s:^\Q$dotslash::;
163 0                                     push @tests, $t
164 0                                 }, $base);
165 0                       @tests = sort @tests;
166                     }
167                 }
168              
169 0               @tests = $self->prune(@tests);
170              
171 0 0             if (my $skip = $self->skip) {
172             # Allow / \ and \\ path delimiters in SKIP file
173 0                   $skip =~ s![/\\\\]+![/\\\\]!g;
174              
175 0                   @tests = grep { not /(?:$skip)/ } @tests;
  0            
176                 }
177              
178 0               Apache::TestSort->run(\@tests, $args);
179              
180             #when running 't/TEST t/dir' shell tab completion adds a /
181             #dir//foo output is annoying, fix that.
182 0               s:/+:/:g for @tests;
  0            
183              
184 0               return @tests;
185             }
186              
187             sub run {
188 0     0 0       my $self = shift;
189 0   0           my $args = shift || {};
190              
191 0   0           $Test::Harness::verbose ||= $args->{verbose};
192              
193 0 0             if (my(@subtests) = @{ $args->{subtests} || [] }) {
  0 0          
194 0                   $ENV{HTTPD_TEST_SUBTESTS} = "@subtests";
195                 }
196              
197 0               Test::Harness::runtests($self->get_tests($args, @_));
198             }
199              
200             1;
201