558 lines
16 KiB
Perl
558 lines
16 KiB
Perl
# 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;
|