File Coverage

blib/lib/Apache/TestConfigParse.pm
Criterion Covered Total %
statement 189 228 82.9
branch 50 90 55.6
condition 18 41 43.9
subroutine 22 24 91.7
pod 0 19 0.0
total 279 402 69.4


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 TestConfigParse on purpose
17              
18             #dont really want/need a full-blown parser
19             #but do want something somewhat generic
20              
21 6     6   101 use strict;
  6         58  
  6         99  
22 6     6   91 use warnings FATAL => 'all';
  6         84  
  6         105  
23              
24 6     6   98 use Apache::TestTrace;
  6         55  
  6         129  
25              
26 6     6   104 use File::Spec::Functions qw(rel2abs splitdir file_name_is_absolute);
  6         56  
  6         483  
27 6     6   144 use File::Basename qw(dirname basename);
  6         57  
  6         113  
28              
29             sub strip_quotes {
30 90   66 90 0 1393     local $_ = shift || $_;
31 90         1451     s/^\"//; s/\"$//; $_;
  90         1073  
  90         1666  
32             }
33              
34             my %wanted_config = (
35                 TAKE1 => {map { $_, 1 } qw(ServerRoot ServerAdmin TypesConfig DocumentRoot)},
36                 TAKE2 => {map { $_, 1 } qw(LoadModule)},
37             );
38              
39             my %spec_init = (
40                 TAKE1 => sub { shift->{+shift} = "" },
41                 TAKE2 => sub { shift->{+shift} = [] },
42             );
43              
44             my %spec_apply = (
45                 TypesConfig => \&inherit_server_file,
46                 ServerRoot => sub {}, #dont override $self->{vars}->{serverroot}
47                 DocumentRoot => \&inherit_directive_var,
48                 LoadModule => \&inherit_load_module,
49             );
50              
51             #where to add config, default is preamble
52             my %spec_postamble = map { $_, 'postamble' } qw(TypesConfig);
53              
54             # need to enclose the following directives into <IfModule
55             # mod_foo.c>..</IfModule>, since mod_foo might be unavailable
56             my %ifmodule = (
57                 TypesConfig => 'mod_mime.c',
58             );
59              
60             sub spec_add_config {
61 6     6 0 69     my($self, $directive, $val) = @_;
62              
63 6   50     86     my $where = $spec_postamble{$directive} || 'preamble';
64              
65 6 50       95     if (my $ifmodule = $ifmodule{TypesConfig}) {
66 6         2518         $self->postamble(<<EOI);
67             <IfModule $ifmodule>
68             $directive $val
69             </IfModule>
70             EOI
71                 }
72                 else {
73 0         0         $self->$where($directive => $val);
74                 }
75             }
76              
77             # resolve relative files like Apache->server_root_relative
78             # this function doesn't test whether the resolved file exists
79             sub server_file_rel2abs {
80 18     18 0 336     my($self, $file, $base) = @_;
81              
82 18         169     my ($serverroot, $result) = ();
83              
84             # order search sequence
85 18         787     my @tries = ([ $base,
86                                    'user-supplied $base' ],
87                              [ $self->{inherit_config}->{ServerRoot},
88                                    'httpd.conf inherited ServerRoot' ],
89                              [ $self->apxs('PREFIX'),
90                                    'apxs-derived ServerRoot' ]);
91              
92             # remove surrounding quotes if any
93             # e.g. Include "/tmp/foo.html"
94 18         338     $file =~ s/^\s*["']?//;
95 18         416     $file =~ s/["']?\s*$//;
96              
97 18 100       588     if (file_name_is_absolute($file)) {
98 12         471         debug "$file is already absolute";
99 12         118         $result = $file;
100                 }
101                 else {
102 6         1255         foreach my $try (@tries) {
103 12 100       165             next unless defined $try->[0];
104              
105 6 50       554             if (-d $try->[0]) {
106 6         63                 $serverroot = $try->[0];
107 6         122                 debug "using $try->[1] to resolve $file";
108 6         67                 last;
109                         }
110                     }
111              
112 6 50       73         if ($serverroot) {
113 6         281             $result = rel2abs $file, $serverroot;
114                     }
115                     else {
116 0         0             warning "unable to resolve $file - cannot find a suitable ServerRoot";
117 0         0             warning "please specify a ServerRoot in your httpd.conf or use apxs";
118              
119             # return early, skipping file test below
120 0         0             return $file;
121                     }
122                 }
123              
124 18         397     my $dir = dirname $result;
125             # $file might not exist (e.g. if it's a glob pattern like
126             # "conf/*.conf" but what we care about here is to check whether
127             # the base dir was successfully resolved. we don't check whether
128             # the file exists at all. it's the responsibility of the caller to
129             # do this check
130 18 100 66     4722     if (defined $dir && -e $dir && -d _) {
      66        
131 12 50       330         if (-e $result) {
132 12         170             debug "$file successfully resolved to existing file $result";
133                     }
134                     else {
135 0         0             debug "base dir of '$file' successfully resolved to $dir";
136                     }
137              
138                 }
139                 else {
140 6   50     78         $dir ||= '';
141 6         240         warning "dir '$dir' does not exist (while resolving '$file')";
142              
143             # old behavior was to return the resolved but non-existent
144             # file. preserve that behavior and return $result anyway.
145                 }
146              
147 18         835     return $result;
148             }
149              
150             sub server_file {
151 6     6 0 189     my $f = shift->server_file_rel2abs(@_);
152 6         105     return qq("$f");
153             }
154              
155             sub inherit_directive_var {
156 6     6 0 233     my($self, $c, $directive) = @_;
157              
158 6         97     $self->{vars}->{"inherit_\L$directive"} = $c->{$directive};
159             }
160              
161             sub inherit_server_file {
162 6     6 0 75     my($self, $c, $directive) = @_;
163              
164 6         202     $self->spec_add_config($directive,
165                                        $self->server_file($c->{$directive}));
166             }
167              
168             #so we have the same names if these modules are linked static or shared
169             my %modname_alias = (
170                 'mod_pop.c' => 'pop_core.c',
171                 'mod_proxy_ajp.c' => 'proxy_ajp.c',
172                 'mod_proxy_http.c' => 'proxy_http.c',
173                 'mod_proxy_ftp.c' => 'proxy_ftp.c',
174                 'mod_proxy_balancer.c' => 'proxy_balancer.c',
175                 'mod_proxy_connect.c' => 'proxy_connect.c',
176                 'mod_modperl.c' => 'mod_perl.c',
177             );
178              
179             #XXX mod_jk requires JkWorkerFile or JkWorker to be configured
180             #skip it for now, tomcat has its own test suite anyhow.
181             #XXX: mod_casp2.so requires other settings in addition to LoadModule
182             my @autoconfig_skip_module = qw(mod_jk.c mod_casp2.c);
183              
184             # add modules to be not inherited from the existing config.
185             # e.g. prevent from LoadModule perl_module to be included twice, when
186             # mod_perl already configures LoadModule and it's certainly found in
187             # the existing httpd.conf installed system-wide.
188             sub autoconfig_skip_module_add {
189 0     0 0 0     push @autoconfig_skip_module, @_;
190             }
191              
192             sub should_skip_module {
193 6     6 0 68     my($self, $name) = @_;
194              
195 6         200     for (@autoconfig_skip_module) {
196 12 50       192         if (UNIVERSAL::isa($_, 'Regexp')) {
197 0 0       0             return 1 if $name =~ /$_/;
198                     }
199                     else {
200 12 50       147             return 1 if $name eq $_;
201                     }
202                 }
203 6         175     return 0;
204             }
205              
206             #inherit LoadModule
207             sub inherit_load_module {
208 6     6 0 69     my($self, $c, $directive) = @_;
209              
210 6         59     for my $args (@{ $c->{$directive} }) {
  6         241  
211 6         67         my $modname = $args->[0];
212 6         120         my $file = $self->server_file_rel2abs($args->[1]);
213              
214 6 50       156         unless (-e $file) {
215 0         0             debug "$file does not exist, skipping LoadModule";
216 0         0             next;
217                     }
218              
219 6         82         my $name = basename $args->[1];
220 6         887         $name =~ s/\.(s[ol]|dll)$/.c/; #mod_info.so => mod_info.c
221 6         73         $name =~ s/^lib/mod_/; #libphp4.so => mod_php4.c
222              
223 6 50       84         $name = $modname_alias{$name} if $modname_alias{$name};
224              
225             # remember all found modules
226 6         102         $self->{modules}->{$name} = $file;
227 6         97         debug "Found: $modname => $name";
228              
229 6 50       234         if ($self->should_skip_module($name)) {
230 0         0             debug "Skipping LoadModule of $name";
231 0         0             next;
232                     }
233              
234 6         99         debug "LoadModule $modname $name";
235              
236             # sometimes people have broken system-wide httpd.conf files,
237             # which include LoadModule of modules, which are built-in, but
238             # won't be skipped above if they are found in the modules/
239             # directory. this usually happens when httpd is built once
240             # with its modules built as shared objects and then again with
241             # static ones: the old httpd.conf still has the LoadModule
242             # directives, even though the modules are now built-in
243             # so we try to workaround this problem using <IfModule>
244 6         369         $self->preamble(IfModule => "!$name",
245                                     qq{LoadModule $modname "$file"\n});
246                 }
247             }
248              
249             sub parse_take1 {
250 24     24 0 509     my($self, $c, $directive) = @_;
251 24         251     $c->{$directive} = strip_quotes;
252             }
253              
254             sub parse_take2 {
255 6     6 0 85     my($self, $c, $directive) = @_;
256 6         61     push @{ $c->{$directive} }, [map { strip_quotes } split];
  6         197  
  12         127  
257             }
258              
259             sub apply_take1 {
260 6     6 0 97     my($self, $c, $directive) = @_;
261              
262 6 50       93     if (exists $self->{vars}->{lc $directive}) {
263             #override replacement @Variables@
264 6         94         $self->{vars}->{lc $directive} = $c->{$directive};
265                 }
266                 else {
267 0         0         $self->spec_add_config($directive, qq("$c->{$directive}"));
268                 }
269             }
270              
271             sub apply_take2 {
272 0     0 0 0     my($self, $c, $directive) = @_;
273              
274 0         0     for my $args (@{ $c->{$directive} }) {
  0         0  
275 0         0         $self->spec_add_config($directive => [map { qq("$_") } @$args]);
  0         0  
276                 }
277             }
278              
279             sub inherit_config_file_or_directory {
280 12     12 0 156     my ($self, $item) = @_;
281              
282 12 50       507     if (-d $item) {
283 0         0         my $dir = $item;
284 0         0         debug "descending config directory: $dir";
285              
286 0         0         for my $entry (glob "$dir/*") {
287 0         0             $self->inherit_config_file_or_directory($entry);
288                     }
289 0         0         return;
290                 }
291              
292 12         121     my $file = $item;
293 12         200     debug "inheriting config file: $file";
294              
295 12         458     my $fh = Symbol::gensym();
296 12 100       1167     open($fh, $file) or return;
297              
298 6         89     my $c = $self->{inherit_config};
299 6         489     while (<$fh>) {
300 6762         81137         s/^\s*//; s/\s*$//; s/^\#.*//;
  6762         134580  
  6762         77239  
301 6762 100       110954         next if /^$/;
302              
303             # support continuous config lines (which use \ to break the line)
304 1248         15874         while (s/\\$//) {
305 6         198             my $cont = <$fh>;
306 6         278             $cont =~ s/^\s*//;
307 6         107             $cont =~ s/\s*$//;
308 6         79             $_ .= $cont;
309                     }
310              
311 1248         39941         (my $directive, $_) = split /\s+/, $_, 2;
312              
313 1248 100       19895         if ($directive eq "Include") {
314 6         488             foreach my $include (glob($self->server_file_rel2abs($_))) {
315 6         2788                 $self->inherit_config_file_or_directory($include);
316                         }
317                     }
318              
319             #parse what we want
320 1248         20938         while (my($spec, $wanted) = each %wanted_config) {
321 2496 100       47746             next unless $wanted->{$directive};
322 30         337             my $method = "parse_\L$spec";
323 30         1120             $self->$method($c, $directive);
324                     }
325                 }
326              
327 6         94     close $fh;
328             }
329              
330             sub inherit_config {
331 6     6 0 136     my $self = shift;
332              
333 6         236     $self->get_httpd_static_modules;
334 6         996     $self->get_httpd_defines;
335              
336             #may change after parsing httpd.conf
337 6         1034     $self->{vars}->{inherit_documentroot} =
338                   catfile $self->{httpd_basedir}, 'htdocs';
339              
340 6         92     my $file = $self->{vars}->{httpd_conf};
341 6         81     my $extra_file = $self->{vars}->{httpd_conf_extra};
342              
343 6 50 33     751     unless ($file and -e $file) {
344 0 0       0         if (my $base = $self->{httpd_basedir}) {
345 0         0             my $default_conf = $self->{httpd_defines}->{SERVER_CONFIG_FILE};
346 0   0     0             $default_conf ||= catfile qw(conf httpd.conf);
347 0         0             $file = catfile $base, $default_conf;
348              
349             # SERVER_CONFIG_FILE might be an absolute path
350 0 0       0             unless (-e $file) {
351 0 0       0                 if (-e $default_conf) {
352 0         0                     $file = $default_conf;
353                             }
354                             else {
355             # try a little harder
356 0 0       0                     if (my $root = $self->{httpd_defines}->{HTTPD_ROOT}) {
357 0         0                         debug "using HTTPD_ROOT to resolve $default_conf";
358 0         0                         $file = catfile $root, $default_conf;
359                                 }
360                             }
361                         }
362                     }
363                 }
364              
365 6 50 33     124     unless ($extra_file and -e $extra_file) {
366 6 50 33     84         if ($extra_file and my $base = $self->{httpd_basedir}) {
367 0         0             my $default_conf = catfile qw(conf $extra_file);
368 0         0             $extra_file = catfile $base, $default_conf;
369             # SERVER_CONFIG_FILE might be an absolute path
370 0 0 0     0             $extra_file = $default_conf if !-e $extra_file and -e $default_conf;
371                     }
372                 }
373              
374 6 50 33     100     return unless $file or $extra_file;
375              
376 6         111     my $c = $self->{inherit_config};
377              
378             #initialize array refs and such
379 6         102     while (my($spec, $wanted) = each %wanted_config) {
380 12         305         for my $directive (keys %$wanted) {
381 30         608             $spec_init{$spec}->($c, $directive);
382                     }
383                 }
384              
385 6 50       454     $self->inherit_config_file_or_directory($file) if $file;
386 6 50       117     $self->inherit_config_file_or_directory($extra_file) if $extra_file;
387              
388             #apply what we parsed
389 6         125     while (my($spec, $wanted) = each %wanted_config) {
390 12         195         for my $directive (keys %$wanted) {
391 30 50       341             next unless $c->{$directive};
392 30   66     1902             my $cv = $spec_apply{$directive} ||
      66        
393                                  $self->can("apply_\L$directive") ||
394                                  $self->can("apply_\L$spec");
395 30         492             $cv->($self, $c, $directive);
396                     }
397                 }
398             }
399              
400             sub get_httpd_static_modules {
401 6     6 0 72     my $self = shift;
402              
403 6         100     my $httpd = $self->{vars}->{httpd};
404 6 50       99     return unless $httpd;
405              
406 6         311     $httpd = shell_ready($httpd);
407 6         84     my $cmd = "$httpd -l";
408 6         329     my $list = $self->open_cmd($cmd);
409              
410 6         89189     while (<$list>) {
411 162         2396         s/\s+$//;
412 162 100       1979         next unless /\.c$/;
413 156         2176         chomp;
414 156         2759         s/^\s+//;
415 156         3044         $self->{modules}->{$_} = 1;
416                 }
417              
418 6         307     close $list;
419             }
420              
421             sub get_httpd_defines {
422 6     6 0 166     my $self = shift;
423              
424 6         116     my $httpd = $self->{vars}->{httpd};
425 6 50       121     return unless $httpd;
426              
427 6         393     $httpd = shell_ready($httpd);
428 6         123     my $cmd = "$httpd -V";
429 6         212     my $proc = $self->open_cmd($cmd);
430              
431 6         27209     while (<$proc>) {
432 132         1397         chomp;
433 132 100       2809         if( s/^\s*-D\s*//) {
    100          
434 102         2786             s/\s+$//;
435 102         4069             my($key, $val) = split '=', $_, 2;
436 102 100       2522             $self->{httpd_defines}->{$key} = $val ? strip_quotes($val) : 1;
437 102         3872             debug "isolated httpd_defines $key = " . $self->{httpd_defines}->{$key};
438                     }
439                     elsif (/(version|built|module magic number|server mpm):\s+(.*)/i) {
440 18         1987             my $val = $2;
441 18         765             (my $key = uc $1) =~ s/\s/_/g;
442 18         557             $self->{httpd_info}->{$key} = $val;
443 18         1126             debug "isolated httpd_info $key = " . $val;
444                     }
445                 }
446              
447 6         473     close $proc;
448              
449 6 50       180     if (my $mmn = $self->{httpd_info}->{MODULE_MAGIC_NUMBER}) {
450 6         242         @{ $self->{httpd_info} }
  6         164  
451                       {qw(MODULE_MAGIC_NUMBER_MAJOR
452             MODULE_MAGIC_NUMBER_MINOR)} = split ':', $mmn;
453                 }
454              
455             # get the mpm information where available
456             # lowercase for consistency across the two extraction methods
457             # XXX or maybe consider making have_apache_mpm() case-insensitive?
458 6 50       181     if (my $mpm = $self->{httpd_info}->{SERVER_MPM}) {
    50          
459             # 2.1
460 0         0         $self->{mpm} = lc $mpm;
461                 }
462                 elsif (my $mpm_dir = $self->{httpd_defines}->{APACHE_MPM_DIR}) {
463             # 2.0
464 6         572         $self->{mpm} = lc basename $mpm_dir;
465                 }
466                 else {
467             # Apache 1.3 - no mpm to speak of
468 0         0         $self->{mpm} = '';
469                 }
470              
471 6   50     2246     my $version = $self->{httpd_info}->{VERSION} || '';
472              
473 6 50       491     if ($version =~ qr,Apache/2,) {
474             # PHP 4.x on httpd-2.x needs a special modname alias:
475 6         378         $modname_alias{'mod_php4.c'} = 'sapi_apache2.c';
476                 }
477              
478 6 50       153     unless ($version =~ qr,Apache/(2.0|1.3),) {
479             # for 2.1 and later, mod_proxy_* are really called mod_proxy_*
480 0         0         delete @modname_alias{grep {/^mod_proxy_/} keys %modname_alias};
  0         0  
481                 }
482             }
483              
484             sub httpd_version {
485 6     6 0 60     my $self = shift;
486              
487 6         70     my $httpd = $self->{vars}->{httpd};
488 6 50       84     return unless $httpd;
489              
490 6         53     my $version;
491 6         272     $httpd = shell_ready($httpd);
492 6         91     my $cmd = "$httpd -v";
493              
494 6         83     my $v = $self->open_cmd($cmd);
495              
496 6         1701     local $_;
497 6         66842     while (<$v>) {
498 6 50       2939         next unless s/^Server\s+version:\s*//i;
499 6         240         chomp;
500 6         340         my @parts = split;
501 6         164         foreach (@parts) {
502 6 50       410             next unless /^Apache\//;
503 6         210             $version = $_;
504 6         121             last;
505                     }
506 6   50     298         $version ||= $parts[0];
507 6         111         last;
508                 }
509              
510 6         510     close $v;
511              
512 6         230     return $version;
513             }
514              
515             sub httpd_mpm {
516 6     6 0 260     return shift->{mpm};
517             }
518              
519             1;
520