| # Licensed to the Apache Software Foundation (ASF) under one or more |
| # contributor license agreements. See the NOTICE file distributed with |
| # this work for additional information regarding copyright ownership. |
| # The ASF licenses this file to You under the Apache License, Version 2.0 |
| # (the "License"); you may not use this file except in compliance with |
| # the License. You may obtain a copy of the License at |
| # |
| # http://www.apache.org/licenses/LICENSE-2.0 |
| # |
| # Unless required by applicable law or agreed to in writing, software |
| # distributed under the License is distributed on an "AS IS" BASIS, |
| # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. |
| # See the License for the specific language governing permissions and |
| # limitations under the License. |
| # |
| package Apache::TestConfig; #not TestConfigParse on purpose |
| |
| #dont really want/need a full-blown parser |
| #but do want something somewhat generic |
| |
| use strict; |
| use warnings FATAL => 'all'; |
| |
| use Apache::TestTrace; |
| |
| use File::Spec::Functions qw(rel2abs splitdir file_name_is_absolute); |
| use File::Basename qw(dirname basename); |
| |
| sub strip_quotes { |
| local $_ = shift || $_; |
| s/^\"//; s/\"$//; $_; |
| } |
| |
| my %wanted_config = ( |
| TAKE1 => {map { $_, 1 } qw(ServerRoot ServerAdmin TypesConfig DocumentRoot)}, |
| TAKE2 => {map { $_, 1 } qw(LoadModule LoadFile)}, |
| ); |
| |
| my %spec_init = ( |
| TAKE1 => sub { shift->{+shift} = "" }, |
| TAKE2 => sub { shift->{+shift} = [] }, |
| ); |
| |
| my %spec_apply = ( |
| TypesConfig => \&inherit_server_file, |
| ServerRoot => sub {}, #dont override $self->{vars}->{serverroot} |
| DocumentRoot => \&inherit_directive_var, |
| LoadModule => \&inherit_load_module, |
| LoadFile => \&inherit_load_file, |
| ); |
| |
| #where to add config, default is preamble |
| my %spec_postamble = map { $_, 'postamble' } qw(TypesConfig); |
| |
| # need to enclose the following directives into <IfModule |
| # mod_foo.c>..</IfModule>, since mod_foo might be unavailable |
| my %ifmodule = ( |
| TypesConfig => 'mod_mime.c', |
| ); |
| |
| sub spec_add_config { |
| my($self, $directive, $val) = @_; |
| |
| my $where = $spec_postamble{$directive} || 'preamble'; |
| |
| if (my $ifmodule = $ifmodule{TypesConfig}) { |
| $self->postamble(<<EOI); |
| <IfModule $ifmodule> |
| $directive $val |
| </IfModule> |
| EOI |
| } |
| else { |
| $self->$where($directive => $val); |
| } |
| } |
| |
| # resolve relative files like Apache->server_root_relative |
| # this function doesn't test whether the resolved file exists |
| sub server_file_rel2abs { |
| my($self, $file, $base) = @_; |
| |
| my ($serverroot, $result) = (); |
| |
| # order search sequence |
| my @tries = ([ $base, |
| 'user-supplied $base' ], |
| [ $self->{inherit_config}->{ServerRoot}, |
| 'httpd.conf inherited ServerRoot' ], |
| [ $self->apxs('PREFIX', 1), |
| 'apxs-derived ServerRoot' ]); |
| |
| # remove surrounding quotes if any |
| # e.g. Include "/tmp/foo.html" |
| $file =~ s/^\s*["']?//; |
| $file =~ s/["']?\s*$//; |
| |
| if (file_name_is_absolute($file)) { |
| debug "$file is already absolute"; |
| $result = $file; |
| } |
| else { |
| foreach my $try (@tries) { |
| next unless defined $try->[0]; |
| |
| if (-d $try->[0]) { |
| $serverroot = $try->[0]; |
| debug "using $try->[1] to resolve $file"; |
| last; |
| } |
| } |
| |
| if ($serverroot) { |
| $result = rel2abs $file, $serverroot; |
| } |
| else { |
| warning "unable to resolve $file - cannot find a suitable ServerRoot"; |
| warning "please specify a ServerRoot in your httpd.conf or use apxs"; |
| |
| # return early, skipping file test below |
| return $file; |
| } |
| } |
| |
| my $dir = dirname $result; |
| # $file might not exist (e.g. if it's a glob pattern like |
| # "conf/*.conf" but what we care about here is to check whether |
| # the base dir was successfully resolved. we don't check whether |
| # the file exists at all. it's the responsibility of the caller to |
| # do this check |
| if (defined $dir && -e $dir && -d _) { |
| if (-e $result) { |
| debug "$file successfully resolved to existing file $result"; |
| } |
| else { |
| debug "base dir of '$file' successfully resolved to $dir"; |
| } |
| |
| } |
| else { |
| $dir ||= ''; |
| warning "dir '$dir' does not exist (while resolving '$file')"; |
| |
| # old behavior was to return the resolved but non-existent |
| # file. preserve that behavior and return $result anyway. |
| } |
| |
| return $result; |
| } |
| |
| sub server_file { |
| my $f = shift->server_file_rel2abs(@_); |
| return qq("$f"); |
| } |
| |
| sub inherit_directive_var { |
| my($self, $c, $directive) = @_; |
| |
| $self->{vars}->{"inherit_\L$directive"} = $c->{$directive}; |
| } |
| |
| sub inherit_server_file { |
| my($self, $c, $directive) = @_; |
| |
| $self->spec_add_config($directive, |
| $self->server_file($c->{$directive})); |
| } |
| |
| #so we have the same names if these modules are linked static or shared |
| my %modname_alias = ( |
| 'mod_pop.c' => 'pop_core.c', |
| 'mod_proxy_ajp.c' => 'proxy_ajp.c', |
| 'mod_proxy_http.c' => 'proxy_http.c', |
| 'mod_proxy_ftp.c' => 'proxy_ftp.c', |
| 'mod_proxy_balancer.c' => 'proxy_balancer.c', |
| 'mod_proxy_connect.c' => 'proxy_connect.c', |
| 'mod_modperl.c' => 'mod_perl.c', |
| ); |
| |
| # Block modules which inhibit testing: |
| # - mod_jk requires JkWorkerFile or JkWorker to be configured |
| # skip it for now, tomcat has its own test suite anyhow. |
| # - mod_casp2 requires other settings in addition to LoadModule |
| # - mod_bwshare and mod_evasive20 block fast requests that tests are doing |
| # - mod_fcgid causes https://rt.cpan.org/Public/Bug/Display.html?id=54476 |
| # - mod_modnss.c and mod_rev.c require further configuration |
| my @autoconfig_skip_module = qw(mod_jk.c mod_casp2.c mod_bwshare.c |
| mod_fcgid.c mod_evasive20.c mod_modnss.c mod_rev.c); |
| |
| # add modules to be not inherited from the existing config. |
| # e.g. prevent from LoadModule perl_module to be included twice, when |
| # mod_perl already configures LoadModule and it's certainly found in |
| # the existing httpd.conf installed system-wide. |
| sub autoconfig_skip_module_add { |
| push @autoconfig_skip_module, @_; |
| } |
| |
| sub should_skip_module { |
| my($self, $name) = @_; |
| |
| for (@autoconfig_skip_module) { |
| if (UNIVERSAL::isa($_, 'Regexp')) { |
| return 1 if $name =~ /$_/; |
| } |
| else { |
| return 1 if $name eq $_; |
| } |
| } |
| return 0; |
| } |
| |
| #inherit LoadModule |
| sub inherit_load_module { |
| my($self, $c, $directive) = @_; |
| |
| for my $args (@{ $c->{$directive} }) { |
| my $modname = $args->[0]; |
| my $file = $self->server_file_rel2abs($args->[1]); |
| |
| unless (-e $file) { |
| debug "$file does not exist, skipping LoadModule"; |
| next; |
| } |
| |
| my $name = basename $args->[1]; |
| $name =~ s/\.(s[ol]|dll)$/.c/; #mod_info.so => mod_info.c |
| $name =~ s/^lib/mod_/; #libphp4.so => mod_php4.c |
| |
| $name = $modname_alias{$name} if $modname_alias{$name}; |
| |
| # remember all found modules |
| $self->{modules}->{$name} = $file; |
| debug "Found: $modname => $name"; |
| |
| if ($self->should_skip_module($name)) { |
| debug "Skipping LoadModule of $name"; |
| next; |
| } |
| |
| debug "LoadModule $modname $name"; |
| |
| # sometimes people have broken system-wide httpd.conf files, |
| # which include LoadModule of modules, which are built-in, but |
| # won't be skipped above if they are found in the modules/ |
| # directory. this usually happens when httpd is built once |
| # with its modules built as shared objects and then again with |
| # static ones: the old httpd.conf still has the LoadModule |
| # directives, even though the modules are now built-in |
| # so we try to workaround this problem using <IfModule> |
| $self->preamble(IfModule => "!$name", |
| qq{LoadModule $modname "$file"\n}); |
| } |
| } |
| |
| #inherit LoadFile |
| sub inherit_load_file { |
| my($self, $c, $directive) = @_; |
| |
| for my $args (@{ $c->{$directive} }) { |
| my $file = $self->server_file_rel2abs($args->[0]); |
| |
| unless (-e $file) { |
| debug "$file does not exist, skipping LoadFile"; |
| next; |
| } |
| |
| if ($self->should_skip_module($args->[0])) { |
| debug "Skipping LoadFile of $args->[0]"; |
| next; |
| } |
| |
| # remember all found modules |
| push @{$self->{load_file}}, $file; |
| |
| debug "LoadFile $file"; |
| |
| $self->preamble_first(qq{LoadFile "$file"\n}); |
| } |
| } |
| |
| sub parse_take1 { |
| my($self, $c, $directive) = @_; |
| $c->{$directive} = strip_quotes; |
| } |
| |
| sub parse_take2 { |
| my($self, $c, $directive) = @_; |
| push @{ $c->{$directive} }, [map { strip_quotes } split]; |
| } |
| |
| sub apply_take1 { |
| my($self, $c, $directive) = @_; |
| |
| if (exists $self->{vars}->{lc $directive}) { |
| #override replacement @Variables@ |
| $self->{vars}->{lc $directive} = $c->{$directive}; |
| } |
| else { |
| $self->spec_add_config($directive, qq("$c->{$directive}")); |
| } |
| } |
| |
| sub apply_take2 { |
| my($self, $c, $directive) = @_; |
| |
| for my $args (@{ $c->{$directive} }) { |
| $self->spec_add_config($directive => [map { qq("$_") } @$args]); |
| } |
| } |
| |
| sub inherit_config_file_or_directory { |
| my ($self, $item) = @_; |
| |
| if (-d $item) { |
| my $dir = $item; |
| debug "descending config directory: $dir"; |
| |
| for my $entry (glob "$dir/*") { |
| $self->inherit_config_file_or_directory($entry); |
| } |
| return; |
| } |
| |
| my $file = $item; |
| debug "inheriting config file: $file"; |
| |
| my $fh = Symbol::gensym(); |
| open($fh, $file) or return; |
| |
| my $c = $self->{inherit_config}; |
| while (<$fh>) { |
| s/^\s*//; s/\s*$//; s/^\#.*//; |
| next if /^$/; |
| |
| # support continuous config lines (which use \ to break the line) |
| while (s/\\$//) { |
| my $cont = <$fh>; |
| $cont =~ s/^\s*//; |
| $cont =~ s/\s*$//; |
| $_ .= $cont; |
| } |
| |
| (my $directive, $_) = split /\s+/, $_, 2; |
| |
| if ($directive eq "Include" or $directive eq "IncludeOptional") { |
| foreach my $include (glob($self->server_file_rel2abs($_))) { |
| $self->inherit_config_file_or_directory($include); |
| } |
| } |
| |
| #parse what we want |
| while (my($spec, $wanted) = each %wanted_config) { |
| next unless $wanted->{$directive}; |
| my $method = "parse_\L$spec"; |
| $self->$method($c, $directive); |
| } |
| } |
| |
| close $fh; |
| } |
| |
| sub inherit_config { |
| my $self = shift; |
| |
| $self->get_httpd_static_modules; |
| $self->get_httpd_defines; |
| |
| #may change after parsing httpd.conf |
| $self->{vars}->{inherit_documentroot} = |
| catfile $self->{httpd_basedir}, 'htdocs'; |
| |
| my $file = $self->{vars}->{httpd_conf}; |
| my $extra_file = $self->{vars}->{httpd_conf_extra}; |
| |
| unless ($file and -e $file) { |
| if (my $base = $self->{httpd_basedir}) { |
| my $default_conf = $self->{httpd_defines}->{SERVER_CONFIG_FILE}; |
| $default_conf ||= catfile qw(conf httpd.conf); |
| $file = catfile $base, $default_conf; |
| |
| # SERVER_CONFIG_FILE might be an absolute path |
| unless (-e $file) { |
| if (-e $default_conf) { |
| $file = $default_conf; |
| } |
| else { |
| # try a little harder |
| if (my $root = $self->{httpd_defines}->{HTTPD_ROOT}) { |
| debug "using HTTPD_ROOT to resolve $default_conf"; |
| $file = catfile $root, $default_conf; |
| } |
| } |
| } |
| } |
| } |
| |
| unless ($extra_file and -e $extra_file) { |
| if ($extra_file and my $base = $self->{httpd_basedir}) { |
| my $default_conf = catfile qw(conf $extra_file); |
| $extra_file = catfile $base, $default_conf; |
| # SERVER_CONFIG_FILE might be an absolute path |
| $extra_file = $default_conf if !-e $extra_file and -e $default_conf; |
| } |
| } |
| |
| return unless $file or $extra_file; |
| |
| my $c = $self->{inherit_config}; |
| |
| #initialize array refs and such |
| while (my($spec, $wanted) = each %wanted_config) { |
| for my $directive (keys %$wanted) { |
| $spec_init{$spec}->($c, $directive); |
| } |
| } |
| |
| $self->inherit_config_file_or_directory($file) if $file; |
| $self->inherit_config_file_or_directory($extra_file) if $extra_file; |
| |
| #apply what we parsed |
| while (my($spec, $wanted) = each %wanted_config) { |
| for my $directive (keys %$wanted) { |
| next unless $c->{$directive}; |
| my $cv = $spec_apply{$directive} || |
| $self->can("apply_\L$directive") || |
| $self->can("apply_\L$spec"); |
| $cv->($self, $c, $directive); |
| } |
| } |
| } |
| |
| sub get_httpd_static_modules { |
| my $self = shift; |
| |
| my $httpd = $self->{vars}->{httpd}; |
| return unless $httpd; |
| |
| $httpd = shell_ready($httpd); |
| my $cmd = "$httpd -l"; |
| my $list = $self->open_cmd($cmd); |
| |
| while (<$list>) { |
| s/\s+$//; |
| next unless /\.c$/; |
| chomp; |
| s/^\s+//; |
| $self->{modules}->{$_} = 1; |
| } |
| |
| close $list; |
| } |
| |
| sub get_httpd_defines { |
| my $self = shift; |
| |
| my $httpd = $self->{vars}->{httpd}; |
| return unless $httpd; |
| |
| $httpd = shell_ready($httpd); |
| my $cmd = "$httpd -V"; |
| |
| my $httpdconf = $self->{vars}->{httpd_conf}; |
| $cmd .= " -f $httpdconf" if $httpdconf; |
| |
| my $serverroot = $self->{vars}->{serverroot}; |
| $cmd .= " -d $serverroot" if $serverroot; |
| |
| my $proc = $self->open_cmd($cmd); |
| |
| while (<$proc>) { |
| chomp; |
| if( s/^\s*-D\s*//) { |
| s/\s+$//; |
| my($key, $val) = split '=', $_, 2; |
| $self->{httpd_defines}->{$key} = $val ? strip_quotes($val) : 1; |
| debug "isolated httpd_defines $key = " . $self->{httpd_defines}->{$key}; |
| } |
| elsif (/(version|built|module magic number|server mpm):\s+(.*)/i) { |
| my $val = $2; |
| (my $key = uc $1) =~ s/\s/_/g; |
| $self->{httpd_info}->{$key} = $val; |
| debug "isolated httpd_info $key = " . $val; |
| } |
| } |
| |
| close $proc; |
| |
| if (my $mmn = $self->{httpd_info}->{MODULE_MAGIC_NUMBER}) { |
| @{ $self->{httpd_info} } |
| {qw(MODULE_MAGIC_NUMBER_MAJOR |
| MODULE_MAGIC_NUMBER_MINOR)} = split ':', $mmn; |
| } |
| |
| # get the mpm information where available |
| # lowercase for consistency across the two extraction methods |
| # XXX or maybe consider making have_apache_mpm() case-insensitive? |
| if (my $mpm = $self->{httpd_info}->{SERVER_MPM}) { |
| # 2.1 |
| $self->{mpm} = lc $mpm; |
| } |
| elsif (my $mpm_dir = $self->{httpd_defines}->{APACHE_MPM_DIR}) { |
| # 2.0 |
| $self->{mpm} = lc basename $mpm_dir; |
| } |
| else { |
| # Apache 1.3 - no mpm to speak of |
| $self->{mpm} = ''; |
| } |
| |
| my $version = $self->{httpd_info}->{VERSION} || ''; |
| |
| if ($version =~ qr,Apache/2,) { |
| # PHP 4.x on httpd-2.x needs a special modname alias: |
| $modname_alias{'mod_php4.c'} = 'sapi_apache2.c'; |
| } |
| |
| unless ($version =~ qr,Apache/(2.0|1.3),) { |
| # for 2.1 and later, mod_proxy_* are really called mod_proxy_* |
| delete @modname_alias{grep {/^mod_proxy_/} keys %modname_alias}; |
| } |
| } |
| |
| sub httpd_version { |
| my $self = shift; |
| |
| my $httpd = $self->{vars}->{httpd}; |
| return unless $httpd; |
| |
| my $version; |
| $httpd = shell_ready($httpd); |
| my $cmd = "$httpd -v"; |
| |
| my $v = $self->open_cmd($cmd); |
| |
| local $_; |
| while (<$v>) { |
| next unless s/^Server\s+version:\s*//i; |
| chomp; |
| my @parts = split; |
| foreach (@parts) { |
| next unless /^Apache\//; |
| $version = $_; |
| last; |
| } |
| $version ||= $parts[0]; |
| last; |
| } |
| |
| close $v; |
| |
| return $version; |
| } |
| |
| sub httpd_mpm { |
| return shift->{mpm}; |
| } |
| |
| 1; |
