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