File Coverage

blib/lib/Apache/Test.pm
Criterion Covered Total %
statement 97 249 39.0
branch 34 106 32.1
condition 6 30 20.0
subroutine 21 49 42.9
pod 24 31 77.4
total 182 465 39.1


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::Test;
17              
18 6     6   83 use strict;
  6         54  
  6         88  
19 6     6   93 use warnings FATAL => 'all';
  6         53  
  6         78  
20              
21 6     6   162 use Exporter ();
  6         2257  
  6         58  
22 6     6   131 use Config;
  6         54  
  6         84  
23 6     6   140 use Apache::TestConfig ();
  6         61  
  6         63  
24              
25             BEGIN {
26             # Apache::Test loads a bunch of mp2 stuff while getting itself
27             # together. because we need to choose one of mp1 or mp2 to load
28             # check first (and we choose mp2) $mod_perl::VERSION == 2.0
29             # just because someone loaded Apache::Test. This Is Bad. so,
30             # let's try to correct for that here by removing mod_perl from
31             # %INC after the above use() statements settle in. nobody
32             # should be relying on us loading up mod_perl.pm anyway...
33              
34 6     6   112     delete $INC{'mod_perl.pm'};
35             }
36              
37 6     6   554 use vars qw(@ISA @EXPORT %EXPORT_TAGS $VERSION %SubTests @SkipReasons);
  6         65  
  6         119  
38              
39             $VERSION = '1.29';
40              
41             my @need = qw(need_lwp need_http11 need_cgi need_access need_auth
42             need_module need_apache need_min_apache_version
43             need_apache_version need_perl need_min_perl_version
44             need_min_module_version need_threads need_apache_mpm
45             need_php need_php4 need_ssl need_imagemap);
46              
47             my @have = map { (my $need = $_) =~ s/need/have/; $need } @need;
48              
49             @ISA = qw(Exporter);
50             @EXPORT = (qw(ok skip sok plan skip_reason under_construction need),
51                        @need, @have);
52              
53             # everything but ok(), skip(), and plan() - Test::More provides these
54             my @test_more_exports = grep { ! /^(ok|skip|plan)$/ } @EXPORT;
55              
56             %EXPORT_TAGS = (withtestmore => \@test_more_exports);
57              
58             %SubTests = ();
59             @SkipReasons = ();
60              
61             if (my $subtests = $ENV{HTTPD_TEST_SUBTESTS}) {
62                 %SubTests = map { $_, 1 } split /\s+/, $subtests;
63             }
64              
65             my $Config;
66             my $real_plan;
67             my @testmore;
68              
69             sub import {
70 6     6   69     my $class = shift;
71              
72             # once Test::More always Test::More until plan() is called
73 6 50 33     327     if (($_[0] and $_[0] =~ m/^-withtestmore/) || @testmore) {
      33        
74             # special hoops for Test::More support
75              
76 0 0       0         $real_plan = eval {
77              
78 0         0             require Test::More;
79              
80 6     6   121             no warnings qw(numeric);
  6         57  
  6         161  
81 0         0             Test::Builder->VERSION('0.18_01');
82              
83             # required for Test::More::import() and Apache::Test::plan()
84             # if we don't do this, Test::More exports plan() anyway
85             # and we get collisions. go figure.
86 0         0             @testmore = (import => [qw(!plan)]);
87              
88 0         0             Test::More->import(@testmore);
89              
90 0         0             \&Test::More::plan;
91                     } or die "-withtestmore error: $@";
92              
93             # clean up arguments to export_to_level
94 0         0         shift;
95 0         0         @EXPORT = (@test_more_exports, @Test::More::EXPORT);
96                 }
97                 else {
98             # the default - Test.pm support
99              
100 6         275         require Test;
101 6         155         Test->import(qw(ok skip));
102 6         81         @testmore = (); # reset, just in case.
103 6         70         $real_plan = \&Test::plan;
104                 }
105              
106 6 50       273     $class->export_to_level(1, undef, @_ ? @_ : @EXPORT);
107             }
108              
109             sub config {
110 42   66 42 1 1022     $Config ||= Apache::TestConfig->thaw->httpd_config;
111             }
112              
113             my $Basic_config;
114              
115             # config bits which doesn't require httpd to be found
116             sub basic_config {
117 0   0 0 1 0     $Basic_config ||= Apache::TestConfig->thaw();
118             }
119              
120             sub vars {
121 15 50   15 1 184     @_ ? @{ config()->{vars} }{ @_ } : config()->{vars};
  0         0  
122             }
123              
124             sub sok (&;$) {
125 0     0 1 0     my $sub = shift;
126 0   0     0     my $nok = shift || 1; #allow sok to have 'ok' within
127              
128 0 0 0     0     if (%SubTests and not $SubTests{ $Test::ntest }) {
129 0         0         for my $n (1..$nok) {
130 0         0             skip("skipping this subtest", 0);
131                     }
132 0         0         return;
133                 }
134              
135 0         0     my($package, $filename, $line) = caller;
136              
137             # trick ok() into reporting the caller filename/line when a
138             # sub-test fails in sok()
139 0         0     return eval <<EOE;
140             #line $line $filename
141             ok(\$sub->());
142             EOE
143             }
144              
145             #so Perl's Test.pm can be run inside mod_perl
146             sub test_pm_refresh {
147 6 50   6 1 76     if (@testmore) {
148 0         0         my $builder = Test::Builder->new;
149              
150 0         0         $builder->reset;
151              
152 0         0         $builder->output(\*STDOUT);
153 0         0         $builder->todo_output(\*STDOUT);
154              
155             # this is STDOUT because Test::More seems to put
156             # most of the stuff we want on STDERR, so it ends
157             # up in the error_log instead of where the user can
158             # see it. consider leaving it alone based on
159             # later user reports.
160 0         0         $builder->failure_output(\*STDOUT);
161                 }
162                 else {
163 6         133         $Test::TESTOUT = \*STDOUT;
164 6         59         $Test::planned = 0;
165 6         56         $Test::ntest = 1;
166 6         181         %Test::todo = ();
167                 }
168             }
169              
170             sub init_test_pm {
171 0     0 0 0     my $r = shift;
172              
173             # needed to load Apache2::RequestRec::TIEHANDLE
174 0         0     eval {require Apache2::RequestIO};
  0         0  
175 0 0       0     if (defined &Apache2::RequestRec::TIEHANDLE) {
176 0         0         untie *STDOUT;
177 0         0         tie *STDOUT, $r;
178 0         0         require Apache2::RequestRec; # $r->pool
179 0         0         require APR::Pool;
180 0     0   0         $r->pool->cleanup_register(sub { untie *STDOUT });
  0         0  
181                 }
182                 else {
183 0         0         $r->send_http_header; #1.xx
184                 }
185              
186 0         0     $r->content_type('text/plain');
187             }
188              
189             sub need_http11 {
190 0     0 1 0     require Apache::TestRequest;
191 0 0       0     if (Apache::TestRequest::install_http11()) {
192 0         0         return 1;
193                 }
194                 else {
195 0         0         push @SkipReasons,
196                        "LWP version 5.60+ required for HTTP/1.1 support";
197 0         0         return 0;
198                 }
199             }
200              
201             sub need_ssl {
202 0     0 1 0     my $vars = vars();
203 0         0     need_module([$vars->{ssl_module_name}, 'Net::SSL']);
204             }
205              
206             sub need_lwp {
207 3     3 1 193     require Apache::TestRequest;
208 3 50       145     if (Apache::TestRequest::has_lwp()) {
209 3         81         return 1;
210                 }
211                 else {
212 0         0         push @SkipReasons, "libwww-perl is not installed";
213 0         0         return 0;
214                 }
215             }
216              
217             sub plan {
218 6 50   6 1 76     init_test_pm(shift) if ref $_[0];
219 6         75     test_pm_refresh();
220              
221             # extending Test::plan's functionality, by using the optional
222             # single value in @_ coming after a ballanced %hash which
223             # Test::plan expects
224 6 100       622     if (@_ % 2) {
225 4         40         my $condition = pop @_;
226 4         42         my $ref = ref $condition;
227 4         39         my $meets_condition = 0;
228 4 100       47         if ($ref) {
229 1 50       13             if ($ref eq 'CODE') {
    0          
230             #plan tests $n, \&has_lwp
231 1         11                 $meets_condition = $condition->();
232                         }
233                         elsif ($ref eq 'ARRAY') {
234             #plan tests $n, [qw(php4 rewrite)];
235 0         0                 $meets_condition = need_module($condition);
236                         }
237                         else {
238 0         0                 die "don't know how to handle a condition of type $ref";
239                         }
240                     }
241                     else {
242             # we have the verdict already: true/false
243 3 50       33             $meets_condition = $condition ? 1 : 0;
244                     }
245              
246             # trying to emulate a dual variable (ala errno)
247 4 50       74         unless ($meets_condition) {
248 0 0       0             my $reason = join ', ',
249                           @SkipReasons ? @SkipReasons : "no reason given";
250 0         0             print "1..0 # skipped: $reason\n";
251 0         0             @SkipReasons = (); # reset
252 0         0             exit; #XXX: Apache->exit
253                     }
254                 }
255 6         209     @SkipReasons = (); # reset
256              
257 6         428     $real_plan->(@_, @testmore);
258              
259             # add to Test.pm verbose output
260 6         46760     print "# Using Apache/Test.pm version $VERSION\n";
261             }
262              
263             sub need {
264 3     3 1 30     my $need_all = 1;
265 3         30     for my $cond (@_) {
266 7 50       168         if (ref $cond eq 'HASH') {
    100          
267 0         0             while (my($reason, $value) = each %$cond) {
268 0 0       0                 $value = $value->() if ref $value eq 'CODE';
269 0 0       0                 next if $value;
270 0         0                 push @SkipReasons, $reason;
271 0         0                 $need_all = 0;
272                         }
273                     }
274                     elsif ($cond =~ /^(0|1)$/) {
275 6 50       91             $need_all = 0 if $cond == 0;
276                     }
277                     else {
278 1 50       11             $need_all = 0 unless need_module($cond);
279                     }
280                 }
281 3         152     return $need_all;
282              
283             }
284              
285             sub need_module {
286 6     6 1 91     my $cfg = config();
287              
288 1         14     my @modules = grep defined $_,
289 6 100       569         ref($_[0]) eq 'ARRAY' ? @{ $_[0] } : @_;
290              
291 6         73     my @reasons = ();
292 6         74     for (@modules) {
293 7 100       294         if (/^[a-z0-9_.]+$/) {
294 5         97             my $mod = $_;
295 5 100       144             $mod .= '.c' unless $mod =~ /\.c$/;
296 5 100       106             next if $cfg->{modules}->{$mod};
297 2 50       68             $mod = 'mod_' . $mod unless $mod =~ /^mod_/;
298 2 50       61             next if $cfg->{modules}->{$mod};
299 0 0       0             if (exists $cfg->{cmodules_disabled}->{$mod}) {
300 0         0                 push @reasons, $cfg->{cmodules_disabled}->{$mod};
301 0         0                 next;
302                         }
303                     }
304 2 50       115         die "bogus module name $_" unless /^[\w:.]+$/;
305              
306             # if the module was explicitly passed with a .c extension,
307             # do not try to eval it as a Perl module
308 2         19         my $not_found = 1;
309 2 50       43         unless (/\.c$/) {
310 2         195             eval "require $_";
311 2 50       34             $not_found = 0 unless $@;
312             #print $@ if $@;
313                     }
314 2 50       33         push @reasons, "cannot find module '$_'" if $not_found;
315              
316                 }
317 6 50       111     if (@reasons) {
318 0         0         push @SkipReasons, @reasons;
319 0         0         return 0;
320                 }
321                 else {
322 6         951         return 1;
323                 }
324             }
325              
326             sub need_min_perl_version {
327 0     0 1 0     my $version = shift;
328              
329 0 0       0     return 1 if $] >= $version;
330              
331 0         0     push @SkipReasons, "perl >= $version is required";
332 0         0     return 0;
333             }
334              
335             # currently supports only perl modules
336             sub need_min_module_version {
337 0     0 1 0     my($module, $version) = @_;
338              
339             # need_module requires the perl module
340