File Coverage

blib/lib/Apache/TestConfigPerl.pm
Criterion Covered Total %
statement 27 267 10.1
branch 0 116 0.0
condition 0 28 0.0
subroutine 9 31 29.0
pod 0 21 0.0
total 36 463 7.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::TestConfig; #not TestConfigPerl on purpose
17              
18             #things specific to mod_perl
19              
20 6     6   78 use strict;
  6         57  
  6         93  
21 6     6   191 use warnings FATAL => 'all';
  6         61  
  6         97  
22 6     6   105 use File::Spec::Functions qw(catfile splitdir abs2rel file_name_is_absolute);
  6         73  
  6         116  
23 6     6   98 use File::Find qw(finddepth);
  6         53  
  6         141  
24 6     6   91 use Apache::TestTrace;
  6         56  
  6         1002  
25 6     6   187 use Apache::TestRequest;
  6         63  
  6         118  
26 6     6   116 use Config;
  6         56  
  6         96  
27              
28             my %libmodperl = (1 => 'libperl.so', 2 => 'mod_perl.so');
29              
30             sub configure_libmodperl {
31 0     0 0       my $self = shift;
32              
33 0               my $server = $self->{server};
34 0               my $libname = $server->version_of(\%libmodperl);
35 0               my $vars = $self->{vars};
36              
37 0 0 0           if ($vars->{libmodperl}) {
    0          
38             # if set, libmodperl was specified from the command line and
39             # should be used instead of the one that is looked up
40              
41             # resolve a non-absolute path
42 0 0                 $vars->{libmodperl} = $self->find_apache_module($vars->{libmodperl})
43                         unless file_name_is_absolute($vars->{libmodperl});
44                 }
45             # $server->{rev} could be set to 2 as a fallback, even when
46             # the wanted version is 1. So check that we use mod_perl 2
47                 elsif ($server->{rev} >= 2 && IS_MOD_PERL_2) {
48 0 0                 if (my $build_config = $self->modperl_build_config()) {
49 0 0                     if ($build_config->{MODPERL_LIB_SHARED}) {
50 0                           $libname = $build_config->{MODPERL_LIB_SHARED};
51 0   0                       $vars->{libmodperl} ||= $self->find_apache_module($libname);
52                         }
53             # XXX: we have a problem with several perl trees pointing
54             # to the same httpd tree. So it's possible that we
55             # configure the test suite to run with mod_perl.so built
56             # against perl which it wasn't built with. Should we use
57             # something like ldd to check the match?
58                     }
59                     else {
60             # XXX: can we test whether mod_perl was linked statically
61             # so we don't need to preload it
62             # if (!linked statically) {
63             # die "can't find mod_perl built for perl version $]"
64             # }
65 0                       error "can't find mod_perl.so built for perl version $]";
66                     }
67             # don't use find_apache_module or we may end up with the wrong
68             # shared object, built against different perl
69                 }
70                 else {
71             # mod_perl 1.0
72 0   0               $vars->{libmodperl} ||= $self->find_apache_module($libname);
73             # XXX: how do we find out whether we have a static or dynamic
74             # mod_perl build? die if its dynamic and can't find the module
75                 }
76              
77 0               my $cfg = '';
78              
79 0 0 0           if ($vars->{libmodperl} && -e $vars->{libmodperl}) {
80 0                   if (Apache::TestConfig::WIN32) {
81                         my $lib = "$Config{installbin}\\$Config{libperl}";
82                         $lib =~ s/lib$/dll/;
83                         $cfg = 'LoadFile ' . qq("$lib"\n) if -e $lib;
84             }
85             # add the module we found to the cached modules list
86             # otherwise have_module('mod_perl') doesn't work unless
87             # we have a LoadModule in our base config
88 0                   $self->{modules}->{'mod_perl.c'} = $vars->{libmodperl};
89              
90 0                   $cfg .= 'LoadModule ' . qq(perl_module "$vars->{libmodperl}"\n);
91                 }
92                 else {
93 0                   my $msg = "unable to locate $libname (could be a static build)\n";
94 0                   $cfg = "#$msg";
95 0                   debug $msg;
96                 }
97              
98 0               $self->preamble(IfModule => '!mod_perl.c', $cfg);
99              
100             }
101              
102             sub configure_inc {
103 0     0 0       my $self = shift;
104              
105 0               my $top = $self->{vars}->{top_dir};
106              
107 0               my $inc = $self->{inc};
108 0               my @trys = (catdir($top, qw(blib lib)),
109                             catdir($top, qw(blib arch)));
110              
111 0               for (@trys) {
112 0 0                 push @$inc, $_ if -d $_;
113                 }
114              
115             # spec: If PERL5LIB is defined, PERLLIB is not used.
116 0               for (qw(PERL5LIB PERLLIB)) {
117 0 0                 next unless exists $ENV{$_};
118 0                   push @$inc, split /$Config{path_sep}/, $ENV{$_};
119 0                   last;
120                 }
121              
122             # enable live testing of the Apache-Test dev modules if they are
123             # located at the project's root dir
124 0               my $apache_test_dev_dir = catfile($top, 'Apache-Test', 'lib');
125 0 0             unshift @$inc, $apache_test_dev_dir if -d $apache_test_dev_dir;
126             }
127              
128             sub write_pm_test {
129 0     0 0       my($self, $module, $sub, @base) = @_;
130              
131 0               my $dir = catfile $self->{vars}->{t_dir}, @base;
132 0               my $t = catfile $dir, "$sub.t";
133 0 0             return if -e $t;
134              
135 0               $self->gendir($dir);
136 0               my $fh = $self->genfile($t);
137              
138 0               my $path = Apache::TestRequest::module2path($module);
139              
140 0               print $fh <<EOF;
141             use Apache::TestRequest 'GET_BODY_ASSERT';
142             print GET_BODY_ASSERT "/$path";
143             EOF
144              
145 0 0             close $fh or die "close $t: $!";
146             }
147              
148             # propogate PerlPassEnv settings to the server
149             sub configure_env {
150 0     0 0       my $self = shift;
151 0               $self->preamble(IfModule => 'mod_perl.c',
152                                 [ qw(PerlPassEnv APACHE_TEST_TRACE_LEVEL
153             PerlPassEnv HARNESS_PERL_SWITCHES)
154                                 ]);
155             }
156              
157             sub startup_pl_code {
158 0     0 0       my $self = shift;
159 0               my $serverroot = $self->{vars}->{serverroot};
160              
161 0               my $cover = <<'EOF';
162             if (($ENV{HARNESS_PERL_SWITCHES}||'') =~ m/Devel::Cover/) {
163             eval {
164             # 0.48 is the first version of Devel::Cover that can
165             # really generate mod_perl coverage statistics
166             require Devel::Cover;
167             Devel::Cover->VERSION(0.48);
168            
169             # this ignores coverage data for some generated files
170             Devel::Cover->import('+inc' => 't/response/',);
171            
172             1;
173             } or die "Devel::Cover error: $@";
174             }
175             EOF
176              
177 0               return <<"EOF";
178             BEGIN {
179             use lib '$serverroot';
180             for my \$file (qw(modperl_inc.pl modperl_extra.pl)) {
181             eval { require "conf/\$file" } or
182             die if grep { -e "\$_/conf/\$file" } \@INC;
183             }
184            
185             $cover
186             }
187            
188             1;
189             EOF
190             }
191              
192             sub configure_startup_pl {
193 0     0 0       my $self = shift;
194              
195             #for 2.0 we could just use PerlSwitches -Mlib=...
196             #but this will work for both 2.0 and 1.xx
197 0 0             if (my $inc = $self->{inc}) {
198 0                   my $include_pl = catfile $self->{vars}->{t_conf}, 'modperl_inc.pl';
199 0                   my $fh = $self->genfile($include_pl);
200 0                   for (reverse @$inc) {
201 0 0                     next unless $_;
202 0                       print $fh "use lib '$_';\n";
203                     }
204 0                   my $tlib = catdir $self->{vars}->{t_dir}, 'lib';
205 0 0                 if (-d $tlib) {
206 0                       print $fh "use lib '$tlib';\n";
207                     }
208              
209             # if Apache::Test is used to develop a project, we want the
210             # project/lib directory to be first in @INC (loaded last)
211 0 0                 if ($ENV{APACHE_TEST_LIVE_DEV}) {
212 0                       my $dev_lib = catdir $self->{vars}->{top_dir}, "lib";
213 0 0                     print $fh "use lib '$dev_lib';\n" if -d $dev_lib;
214                     }
215              
216 0                   print $fh "1;\n";
217                 }
218              
219 0 0             if ($self->server->{rev} >= 2) {
220 0                   $self->postamble(IfModule => 'mod_perl.c',
221                                      "PerlSwitches -Mlib=$self->{vars}->{serverroot}\n");
222                 }
223              
224 0               my $startup_pl = catfile $self->{vars}->{t_conf}, 'modperl_startup.pl';
225              
226 0 0             unless (-e $startup_pl) {
227 0                   my $fh = $self->genfile($startup_pl);
228 0                   print $fh $self->startup_pl_code;
229 0                   close $fh;
230                 }
231              
232 0               $self->postamble(IfModule => 'mod_perl.c',
233                                  "PerlRequire $startup_pl\n");
234             }
235              
236             my %sethandler_modperl = (1 => 'perl-script', 2 => 'modperl');
237              
238             sub set_handler {
239 0     0 0       my($self, $module, $args) = @_;
240 0 0             return if grep { $_ eq 'SetHandler' } @$args;
  0            
241              
242 0               push @$args,
243                   SetHandler =>
244                     $self->server->version_of(\%sethandler_modperl);
245             }
246              
247             sub set_connection_handler {
248 0     0 0       my($self, $module, $args) = @_;
249 0               my $port = $self->new_vhost($module);
250 0               my $vars = $self->{vars};
251 0               $self->postamble(Listen => '0.0.0.0:' . $port);
252             }
253              
254             my %add_hook_config = (
255                 Response => \&set_handler,
256                 ProcessConnection => \&set_connection_handler,
257                 PreConnection => \&set_connection_handler,
258             );
259              
260             my %container_config = (
261                 ProcessConnection => \&vhost_container,
262                 PreConnection => \&vhost_container,
263             );
264              
265             sub location_container {
266 0     0 0       my($self, $module) = @_;
267 0               my $path = Apache::TestRequest::module2path($module);
268 0               Location => "/$path";
269             }
270              
271             sub vhost_container {
272 0     0 0       my($self, $module) = @_;
273 0               my $port = $self->{vhosts}->{$module}->{port};
274 0               my $namebased = $self->{vhosts}->{$module}->{namebased};
275              
276 0 0             VirtualHost => ($namebased ? '*' : '_default_') . ":$port";
277             }
278              
279             sub new_vhost {
280 0     0 0       my($self, $module, $namebased) = @_;
281 0               my($port, $servername, $vhost);
282              
283 0 0 0           unless ($namebased and exists $self->{vhosts}->{$module}) {
284 0                   $port = $self->server->select_next_port;
285 0                   $vhost = $self->{vhosts}->{$module} = {};
286              
287 0                   $vhost->{port} = $port;
288 0 0                 $vhost->{namebased} = $namebased ? 1 : 0;
289                 }
290                 else {
291 0                   $vhost = $self->{vhosts}->{$module};
292 0                   $port = $vhost->{port};
293             # remember the already configured Listen/NameVirtualHost
294 0                   $vhost->{namebased}++;
295                 }
296              
297 0               $servername = $self->{vars}->{servername};
298              
299 0               $vhost->{servername} = $servername;
300 0               $vhost->{name} = join ':', $servername, $port;
301 0               $vhost->{hostport} = $self->hostport($vhost, $module);
302              
303 0               $port;
304             }
305              
306             my %outside_container = map { $_, 1 } qw{
307             Alias AliasMatch AddType
308             PerlChildInitHandler PerlTransHandler PerlPostReadRequestHandler
309             PerlSwitches PerlRequire PerlModule
310             };
311              
312             my %strip_tags = map { $_ => 1} qw(base noautoconfig);
313              
314             #test .pm's can have configuration after the __DATA__ token
315             sub add_module_config {
316 0     0 0       my($self, $module, $args) = @_;
317 0               my $fh = Symbol::gensym();
318 0 0             open($fh, $module) or return;
319              
320 0               while (<$fh>) {
321 0 0                 last if /^(__(DATA|END)__|\#if CONFIG_FOR_HTTPD_TEST)/;
322                 }
323              
324 0               my %directives;
325              
326 0               while (<$fh>) {
327 0 0                 last if /^\#endif/; #for .c modules
328 0 0                 next unless /\S+/;
329 0                   chomp;
330 0                   s/^\s+//;
331 0                   $self->replace;
332 0 0                 if (/^#/) {
333             # preserve comments
334 0                       $self->postamble($_);
335 0                       next;
336                     }
337 0                   my($directive, $rest) = split /\s+/, $_, 2;
338 0 0                 $directives{$directive}++ unless $directive =~ /^</;
339 0 0                 $rest = '' unless defined $rest;
340              
341 0 0                 if ($outside_container{$directive}) {
    0          
    0          
342 0                       $self->postamble($directive => $rest);
343                     }
344                     elsif ($directive =~ /IfModule/) {
345 0                       $self->postamble($_);
346                     }
347                     elsif ($directive =~ m/^<(\w+)/) {
348             # strip special container directives like <Base> and </Base>
349 0 0                     my $strip_container = exists $strip_tags{lc $1} ? 1 : 0;
350              
351 0 0                     $directives{noautoconfig}++ if lc($1) eq 'noautoconfig';
352              
353 0                       my $indent = '';
354 0                       $self->process_container($_, $fh, lc($1),
355                                                  $strip_container, $indent);
356                     }
357                     else {
358 0                       push @$args, $directive, $rest;
359                     }
360                 }
361              
362 0               \%directives;
363             }
364              
365              
366             # recursively process the directives including nested containers,
367             # re-indent 4 and ucfirst the closing tags letter
368             sub process_container {
369 0     0 0       my($self, $first_line, $fh, $directive, $strip_container, $indent) = @_;
370              
371 0               my $new_indent = $indent;
372              
373 0 0             unless ($strip_container) {
374 0                   $new_indent .= " ";
375              
376 0                   local $_ = $first_line;
377 0                   s/^\s*//;
378 0                   $self->replace;
379              
380 0 0                 if (/<VirtualHost/) {
381 0                       $self->process_vhost_open_tag($_, $indent);
382                     }
383                     else {
384 0                       $self->postamble($indent . $_);
385                     }
386                 }
387              
388 0               $self->process_container_remainder($fh, $directive, $new_indent);
389              
390 0 0             unless ($strip_container) {
391 0                   $self->postamble($indent . "</\u$directive>");
392                 }
393              
394             }
395              
396              
397             # processes the body of the container without the last line, including
398             # the end tag
399             sub process_container_remainder {
400 0     0 0       my($self, $fh, $directive, $indent) = @_;
401              
402 0               my $end_tag = "</$directive>";
403              
404 0               while (<$fh>) {
405 0                   chomp;
406 0 0                 last if m|^\s*\Q$end_tag|i;
407 0                   s/^\s*//;
408 0                   $self->replace;
409              
410 0 0                 if (m/^\s*<(\w+)/) {
411 0                       $self->process_container($_, $fh, $1, 0, $indent);
412                     }
413                     else {
414 0                       $self->postamble($indent . $_);
415                     }
416                 }
417             }
418              
419             # does the necessary processing to create a vhost container header
420             sub process_vhost_open_tag {
421 0     0 0       my($self, $line, $indent) = @_;
422              
423 0               my $cfg = $self->parse_vhost($line);
424              
425 0 0             if ($cfg) {
426 0                   my $port = $cfg->{port};
427 0                   $cfg->{out_postamble}->();
428 0                   $self->postamble($cfg->{line});
429 0                   $cfg->{in_postamble}->();
430                 } else {
431 0                   $self->postamble("$indent$line");
432                 }
433             }
434              
435             #the idea for each group:
436             # Response: there will be many of these, mostly modules to test the API
437             # that plan tests => ... and output with ok()
438             # the naming allows grouping, making it easier to run an
439             # individual set of tests, e.g. t/TEST t/apr
440             # the PerlResponseHandler and SetHandler modperl is auto-configured
441             # Hooks: for testing the simpler Perl*Handlers
442             # auto-generates the Perl*Handler config
443             # Protocol: protocol modules need their own port/vhost to listen on
444              
445             #@INC is auto-modified so each test .pm can be found
446             #modules can add their own configuration using __DATA__
447              
448             my %hooks = map { $_, ucfirst $_ }
449                 qw(init trans headerparser access authen authz type fixup log);
450             $hooks{Protocol} = 'ProcessConnection';
451             $hooks{Filter}   = 'OutputFilter';
452              
453             my @extra_subdirs = qw(Response Protocol PreConnection Hooks Filter);
454              
455             # add the subdirs to @INC early, in case mod_perl is started earlier
456             sub configure_pm_tests_inc {
457 0     0 0       my $self = shift;
458 0               for my $subdir (@extra_subdirs) {
459 0                   my $dir = catfile $self->{vars}->{t_dir}, lc $subdir;
460 0 0                 next unless -d $dir;
461              
462 0                   push @{ $self->{inc} }, $dir;
  0            
463                 }
464             }
465              
466             # @status fields
467 6     6   142 use constant APACHE_TEST_CONFIGURE => 0;
  6         60  
  6         119  
468 6     6   136 use constant APACHE_TEST_CONFIG_ORDER => 1;
  6         103  
  6         80  
469              
470             sub configure_pm_tests_pick {
471 0     0 0       my($self, $entries) = @_;
472              
473 0               for my $subdir (@extra_subdirs) {
474 0                   my $dir = catfile $self->{vars}->{t_dir}, lc $subdir;
475 0 0                 next unless -d $dir;
476              
477                     finddepth(sub {
478 0 0   0                 return unless /\.pm$/;
479              
480 0                       my $file = catfile $File::Find::dir, $_;
481 0                       my $module = abs2rel $file, $dir;
482 0                       my $status = $self->run_apache_test_config_scan($file);
483 0                       push @$entries, [$file, $module, $subdir, $status];
484 0                   }, $dir);
485                 }
486             }
487              
488              
489             # a simple numerical order is performed and configuration sections are
490             # inserted using that order. If the test package specifies no special
491             # token that matches /APACHE_TEST_CONFIG_ORDER\s+([+-]?\d+)/ anywhere
492             # in the file, 0 is assigned as its order. If the token is specified,
493             # config section with negative values will be inserted first, with
494             # positive last. By using different values you can arrange for the
495             # test configuration sections to be inserted in any desired order
496             sub configure_pm_tests_sort {
497 0     0 0       my($self, $entries) = @_;
498              
499 0               @$entries = sort {
500 0                   $a->[3]->[APACHE_TEST_CONFIG_ORDER] <=>
501                     $b->[3]->[APACHE_TEST_CONFIG_ORDER]
502                 } @$entries;
503              
504             }
505              
506             sub configure_pm_tests {
507 0     0 0       my $self = shift;
508              
509 0               my @entries = ();
510 0               $self->configure_pm_tests_pick(\@entries);
511 0               $self->configure_pm_tests_sort(\@entries);
512              
513 0               for my $entry (@entries) {
514 0                   my ($file, $module, $subdir, $status) = @$entry;
515 0                   my @args = ();
516              
517 0                   my $directives = $self->add_module_config($file, \@args);
518 0                   $module =~ s,\.pm$,,;
519 0                   $module =~ s/^[a-z]://i; #strip drive if any
520 0                   $module = join '::', splitdir $module;
521              
522 0                   $self->run_apache_test_configure($file, $module, $status);
523              
524 0                   my @base =
525 0                       map { s/^test//i; $_ } split '::', $module;
  0            
526              
527 0                   my $sub = pop @base;
528              
529 0 0 0               my $hook = ($subdir eq 'Hooks' ? $hooks{$sub} : '')
      0        
530                         || $hooks{$subdir} || $subdir;
531              
532 0 0 0               if ($hook eq 'OutputFilter' and $module =~ /::i\w+$/) {
533             #XXX: tmp hack
534 0                       $hook = 'InputFilter';
535                     }
536              
537 0                   my $handler = join $hook, qw(Perl Handler);
538              
539 0 0 0               if ($self->server->{rev} < 2 and lc($hook) eq 'response') {
540 0                       $handler =~ s/response//i; #s/PerlResponseHandler/PerlHandler/
541                     }
542              
543 0                   debug "configuring $module";
544              
545 0 0                 if ($directives->{noautoconfig}) {
546 0                       $self->postamble(""); # which adds "\n"
547                     }
548                     else {
549 0 0                     if (my $cv = $add_hook_config{$hook}) {
550 0                           $self->$cv($module, \@args);
551                         }
552              
553 0   0                   my $container = $container_config{$hook} || \&location_container;
554              
555             #unless the .pm test already configured the Perl*Handler
556 0 0                     unless ($directives->{$handler}) {
557 0                           my @handler_cfg = ($handler => $module);
558              
559 0 0                         if ($outside_container{$handler}) {
560 0                               my $cfg = $self->massage_config_args(@handler_cfg);
561 0                               $self->postamble(IfModule => 'mod_perl.c', $cfg);
562                             } else {
563 0                               push @args, @handler_cfg;
564                             }
565                         }
566              
567 0 0                     if (@args) {
568 0                         my $cfg = $self->massage_config_args($self->$container($module), \@args);
569 0                         $self->postamble(IfModule => 'mod_perl.c', $cfg);
570                         }
571                     }
572              
573 0                   $self->write_pm_test($module, lc $sub, map { lc } @base);
  0            
574                 }
575             }
576              
577             # scan tests for interesting information
578             sub run_apache_test_config_scan {
579 0     0 0       my ($self, $file) = @_;
580              
581 0               my @status = ();
582 0               $status[APACHE_TEST_CONFIGURE] = 0;
583 0               $status[APACHE_TEST_CONFIG_ORDER] = 0;
584              
585 0               my $fh = Symbol::gensym();
586 0 0             if (open $fh, $file) {
587 0                   local $/;
588 0                   my $content = <$fh>;
589 0                   close $fh;
590             # XXX: optimize to match once?
591 0 0                 if ($content =~ /APACHE_TEST_CONFIGURE/m) {
592 0                       $status[APACHE_TEST_CONFIGURE] = 1;
593                     }
594 0 0                 if ($content =~ /APACHE_TEST_CONFIG_ORDER\s+([+-]?\d+)/m) {
595 0                       $status[APACHE_TEST_CONFIG_ORDER] = int $1;
596                     }
597                 }
598                 else {
599 0                   error "cannot open $file: $!";
600                 }
601              
602 0               return \@status;
603             }
604              
605             # We have to test whether tests have APACHE_TEST_CONFIGURE() in them
606             # and run it if found at this stage, so when the server starts
607             # everything is ready.
608             # XXX: however we cannot use a simple require() because some tests
609             # won't require() outside of mod_perl environment. Therefore we scan
610             # the slurped file in. and if APACHE_TEST_CONFIGURE has been found we
611             # require the file and run this function.
612             sub run_apache_test_configure {
613 0     0 0       my ($self, $file, $module, $status) = @_;
614              
615 0 0             return unless $status->[APACHE_TEST_CONFIGURE];
616              
617 0               eval { require $file };
  0            
618 0 0             warn $@ if $@;
619             # double check that it's a real sub
620 0 0             if ($module->can('APACHE_TEST_CONFIGURE')) {
621 0                   eval { $module->APACHE_TEST_CONFIGURE($self); };
  0            
622 0 0                 warn $@ if $@;
623                 }
624             }
625              
626              
627             1;
628