diff options
Diffstat (limited to 'debian/perl-framework/Apache-Test/lib/Apache/TestConfigParse.pm')
| -rw-r--r-- | debian/perl-framework/Apache-Test/lib/Apache/TestConfigParse.pm | 558 |
1 files changed, 558 insertions, 0 deletions
diff --git a/debian/perl-framework/Apache-Test/lib/Apache/TestConfigParse.pm b/debian/perl-framework/Apache-Test/lib/Apache/TestConfigParse.pm new file mode 100644 index 0000000..60e12e3 --- /dev/null +++ b/debian/perl-framework/Apache-Test/lib/Apache/TestConfigParse.pm @@ -0,0 +1,558 @@ +# 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; |