# 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; use strict; use warnings FATAL => 'all'; use constant WIN32 => $^O eq 'MSWin32'; use constant OSX => $^O eq 'darwin'; use constant CYGWIN => $^O eq 'cygwin'; use constant NETWARE => $^O eq 'NetWare'; use constant SOLARIS => $^O eq 'solaris'; use constant AIX => $^O eq 'aix'; use constant WINFU => WIN32 || NETWARE; use constant COLOR => ($ENV{APACHE_TEST_COLOR} && -t STDOUT) ? 1 : 0; use constant DEFAULT_PORT => 8529; use constant IS_MOD_PERL_2 => eval { require mod_perl2 } || 0; use constant IS_MOD_PERL_2_BUILD => IS_MOD_PERL_2 && eval { require Apache2::Build && Apache2::Build::IS_MOD_PERL_BUILD() }; use constant IS_APACHE_TEST_BUILD => grep { -e "$_/lib/Apache/TestConfig.pm" } qw(Apache-Test . .. ../Apache-Test); use lib (); use File::Copy (); use File::Find qw(finddepth); use File::Basename qw(dirname); use File::Path (); use File::Spec::Functions qw(catfile abs2rel splitdir canonpath catdir file_name_is_absolute devnull); use Cwd qw(fastcwd); use Socket (); use Symbol (); use Apache::TestConfigPerl (); use Apache::TestConfigParse (); use Apache::TestTrace; use Apache::TestServer (); use Apache::TestRun (); use vars qw(%Usage); %Usage = ( top_dir => 'top-level directory (default is $PWD)', t_dir => 'the t/ test directory (default is $top_dir/t)', t_conf => 'the conf/ test directory (default is $t_dir/conf)', t_logs => 'the logs/ test directory (default is $t_dir/logs)', t_state => 'the state/ test directory (default is $t_dir/state)', t_pid_file => 'location of the pid file (default is $t_logs/httpd.pid)', t_conf_file => 'test httpd.conf file (default is $t_conf/httpd.conf)', src_dir => 'source directory to look for mod_foos.so', serverroot => 'ServerRoot (default is $t_dir)', documentroot => 'DocumentRoot (default is $ServerRoot/htdocs', port => 'Port [port_number|select] (default ' . DEFAULT_PORT . ')', servername => 'ServerName (default is localhost)', user => 'User to run test server as (default is $USER)', group => 'Group to run test server as (default is $GROUP)', bindir => 'Apache bin/ dir (default is apxs -q BINDIR)', sbindir => 'Apache sbin/ dir (default is apxs -q SBINDIR)', httpd => 'server to use for testing (default is $bindir/httpd)', target => 'name of server binary (default is apxs -q TARGET)', apxs => 'location of apxs (default is from Apache2::BuildConfig)', startup_timeout => 'seconds to wait for the server to start (default is 60)', httpd_conf => 'inherit config from this file (default is apxs derived)', httpd_conf_extra => 'inherit additional config from this file', minclients => 'minimum number of concurrent clients (default is 1)', maxclients => 'maximum number of concurrent clients (default is minclients+1)', threadsperchild => 'number of threads per child when using threaded MPMs (default is 10)', limitrequestline => 'global LimitRequestLine setting (default is 128)', perlpod => 'location of perl pod documents (for testing downloads)', proxyssl_url => 'url for testing ProxyPass / https (default is localhost)', sslca => 'location of SSL CA (default is $t_conf/ssl/ca)', sslcaorg => 'SSL CA organization to use for tests (default is asf)', sslproto => 'SSL/TLS protocol version(s) to test', libmodperl => 'path to mod_perl\'s .so (full or relative to LIBEXECDIR)', defines => 'values to add as -D defines (for example, "VAR1 VAR2")', (map { $_ . '_module_name', "$_ module name"} qw(cgi ssl thread access auth php)), ); my %filepath_conf_opts = map { $_ => 1 } qw(top_dir t_dir t_conf t_logs t_state t_pid_file t_conf_file src_dir serverroot documentroot bindir sbindir httpd apxs httpd_conf httpd_conf_extra perlpod sslca libmodperl); sub conf_opt_is_a_filepath { my $opt = shift; $opt && exists $filepath_conf_opts{$opt}; } sub usage { for my $hash (\%Usage) { for (sort keys %$hash){ printf " -%-18s %s\n", $_, $hash->{$_}; } } } sub filter_args { my($args, $wanted_args) = @_; my(@pass, %keep); my @filter = @$args; if (ref($filter[0])) { push @pass, shift @filter; } while (@filter) { my $key = shift @filter; # optinal - or -- prefix if (defined $key && $key =~ /^-?-?(.+)/ && exists $wanted_args->{$1}) { if (@filter) { $keep{$1} = shift @filter; } else { die "key $1 requires a matching value"; } } else { push @pass, $key; } } return (\@pass, \%keep); } my %passenv = map { $_,1 } qw{ APACHE_TEST_APXS APACHE_TEST_HTTPD APACHE_TEST_GROUP APACHE_TEST_USER APACHE_TEST_PORT }; sub passenv { \%passenv; } sub passenv_makestr { my @vars; for (sort keys %passenv) { push @vars, "$_=\$($_)"; } "@vars"; } sub server { shift->{server} } sub modperl_build_config { my $self = shift; my $server = ref $self ? $self->server : new_test_server(); # we can't do this if we're using httpd 1.3.X # even if mod_perl2 is installed on the box # similarly, we shouldn't be loading mp2 if we're not # absolutely certain we're in a 2.X environment yet # (such as mod_perl's own build or runtime environment) if (($server->{rev} && $server->{rev} == 2) || IS_MOD_PERL_2_BUILD || $ENV{MOD_PERL_API_VERSION}) { eval { require Apache2::Build; } or return; return Apache2::Build->build_config; } return; } sub new_test_server { my($self, $args) = @_; Apache::TestServer->new($args || $self) } # setup httpd-independent components # for httpd-specific call $self->httpd_config() sub new { my $class = shift; my $args; $args = shift if $_[0] and ref $_[0]; $args = $args ? {%$args} : {@_}; #copy #see Apache::TestMM::{filter_args,generate_script} #we do this so 'perl Makefile.PL' can be passed options such as apxs #without forcing regeneration of configuration and recompilation of c-modules #as 't/TEST apxs /path/to/apache/bin/apxs' would do while (my($key, $val) = each %Apache::TestConfig::Argv) { $args->{$key} = $val; } my $top_dir = fastcwd; $top_dir = pop_dir($top_dir, 't'); # untaint as we are going to use it a lot later on in -T sensitive # operations (.e.g @INC) $top_dir = $1 if $top_dir =~ /(.*)/; # make sure that t/conf/apache_test_config.pm is found # (unfortunately sometimes we get thrown into / by Apache so we # can't just rely on $top_dir lib->import($top_dir); my $thaw = {}; #thaw current config for (qw(conf t/conf)) { last if eval { require "$_/apache_test_config.pm"; $thaw = 'apache_test_config'->new; delete $thaw->{save}; #incase class that generated the config was #something else, which we can't be sure how to load bless $thaw, 'Apache::TestConfig'; }; } if ($args->{thaw} and ref($thaw) ne 'HASH') { #dont generate any new config $thaw->{vars}->{$_} = $args->{$_} for keys %$args; $thaw->{server} = $thaw->new_test_server; $thaw->add_inc; return $thaw; } #regenerating config, so forget old if ($args->{save}) { for (qw(vhosts inherit_config modules inc cmodules)) { delete $thaw->{$_} if exists $thaw->{$_}; } } my $self = bless { clean => {}, vhosts => {}, inherit_config => {}, modules => {}, inc => [], %$thaw, mpm => "", httpd_defines => {}, vars => $args, postamble => [], preamble => [], postamble_hooks => [], preamble_hooks => [], }, ref($class) || $class; my $vars = $self->{vars}; #things that can be overridden for (qw(save verbose)) { next unless exists $args->{$_}; $self->{$_} = delete $args->{$_}; } $vars->{top_dir} ||= $top_dir; $self->add_inc; #help to find libmodperl.so unless ($vars->{src_dir}) { my $src_dir = catfile $vars->{top_dir}, qw(.. src modules perl); if (-d $src_dir) { $vars->{src_dir} = $src_dir; } else { $src_dir = catfile $vars->{top_dir}, qw(src modules perl); $vars->{src_dir} = $src_dir if -d $src_dir; } } $vars->{t_dir} ||= catfile $vars->{top_dir}, 't'; $vars->{serverroot} ||= $vars->{t_dir}; $vars->{documentroot} ||= catfile $vars->{serverroot}, 'htdocs'; $vars->{perlpod} ||= $self->find_in_inc('pods') || $self->find_in_inc('pod'); $vars->{perl} ||= $^X; $vars->{t_conf} ||= catfile $vars->{serverroot}, 'conf'; $vars->{sslca} ||= catfile $vars->{t_conf}, 'ssl', 'ca'; $vars->{sslcaorg} ||= 'asf'; if (!defined($vars->{sslproto}) and eval { require Apache::TestSSLCA; 1; }) { $vars->{sslproto} = Apache::TestSSLCA::sslproto(); } else { $vars->{sslproto} ||= 'all'; } $vars->{t_logs} ||= catfile $vars->{serverroot}, 'logs'; $vars->{t_state} ||= catfile $vars->{serverroot}, 'state'; $vars->{t_conf_file} ||= catfile $vars->{t_conf}, 'httpd.conf'; $vars->{t_pid_file} ||= catfile $vars->{t_logs}, 'httpd.pid'; if (WINFU) { for (keys %$vars) { $vars->{$_} =~ s|\\|\/|g if defined $vars->{$_}; } } $vars->{scheme} ||= 'http'; $vars->{servername} ||= $self->default_servername; $vars->{port} = $self->select_first_port; $vars->{remote_addr} ||= $self->our_remote_addr; $vars->{user} ||= $self->default_user; $vars->{group} ||= $self->default_group; $vars->{serveradmin} ||= $self->default_serveradmin; $vars->{threadsperchild} ||= 10; $vars->{minclients} ||= 1; $vars->{maxclients_preset} = $vars->{maxclients} || 0; # if maxclients wasn't explicitly passed try to # prevent 'server reached MaxClients setting' errors $vars->{maxclients} ||= $vars->{minclients} + 1; # if a preset maxclients valus is smaller than minclients, # maxclients overrides minclients if ($vars->{maxclients_preset} && $vars->{maxclients_preset} < $vars->{minclients}) { $vars->{minclients} = $vars->{maxclients_preset}; } if ($vars->{minclients} < 2) { $vars->{maxspare} = 2; } else { $vars->{maxspare} = $vars->{minclients}; } if ($vars->{maxclients} < $vars->{maxspare} + 1) { $vars->{maxclients} = $vars->{maxspare} + 1; } # for threaded mpms MinClients and MaxClients must be a # multiple of ThreadsPerChild { use integer; $vars->{minclientsthreadedmpm} = ($vars->{minclients} + $vars->{threadsperchild} - 1) / $vars->{threadsperchild} * $vars->{threadsperchild}; $vars->{maxclientsthreadedmpm} = ($vars->{maxclients} + $vars->{threadsperchild} - 1) / $vars->{threadsperchild} * $vars->{threadsperchild}; $vars->{maxsparethreadedmpm} = ($vars->{maxspare} + $vars->{threadsperchild} - 1) / $vars->{threadsperchild} * $vars->{threadsperchild}; $vars->{startserversthreadedmpm} = $vars->{minclientsthreadedmpm} / $vars->{threadsperchild}; } if ($vars->{maxsparethreadedmpm} < 2 * $vars->{threadsperchild}) { $vars->{maxsparethreadedmpm} = 2 * $vars->{threadsperchild}; } if ($vars->{maxclientsthreadedmpm} < $vars->{maxsparethreadedmpm} + $vars->{threadsperchild}) { $vars->{maxclientsthreadedmpm} = $vars->{maxsparethreadedmpm} + $vars->{threadsperchild}; } $vars->{limitrequestline} ||= 128; $vars->{limitrequestlinex2} = 2 * $vars->{limitrequestline}; $vars->{proxy} ||= 'off'; $vars->{proxyssl_url} ||= ''; $vars->{defines} ||= ''; $self->{hostport} = $self->hostport; $self->{server} = $self->new_test_server; return $self; } # figure out where httpd is and run extra config hooks which require # knowledge of where httpd is sub httpd_config { my $self = shift; $self->configure_apxs; $self->configure_httpd; my $vars = $self->{vars}; unless ($vars->{httpd} or $vars->{apxs}) { # mod_perl 2.0 build (almost) always knows the right httpd # location (and optionally apxs). if we get here we can't # continue because the interactive config can't work with # mod_perl 2.0 build (by design) if (IS_MOD_PERL_2_BUILD){ my $mp2_build = $self->modperl_build_config(); # if mod_perl 2 was built against the httpd source it # doesn't know where to find apxs/httpd, so in this case # fall back to interactive config unless ($mp2_build->{MP_APXS}) { die "mod_perl 2 was built against Apache sources, we " . "don't know where httpd/apxs executables are, therefore " . "skipping the test suite execution" } # not sure what else could go wrong but we can't continue die "something is wrong, mod_perl 2.0 build should have " . "supplied all the needed information to run the tests. " . "Please post lib/Apache2/BuildConfig.pm along with the " . "bug report"; } $self->clean(1); error "You must explicitly specify -httpd and/or -apxs options, " . "or set \$ENV{APACHE_TEST_HTTPD} and \$ENV{APACHE_TEST_APXS}, " . "or set your \$PATH to include the httpd and apxs binaries."; Apache::TestRun::exit_perl(1); } else { debug "Using httpd: $vars->{httpd}"; } $self->inherit_config; #see TestConfigParse.pm $self->configure_httpd_eapi; #must come after inherit_config $self->default_module(cgi => [qw(mod_cgi mod_cgid)]); $self->default_module(thread => [qw(worker threaded)]); $self->default_module(ssl => [qw(mod_ssl)]); $self->default_module(access => [qw(mod_access mod_authz_host)]); $self->default_module(auth => [qw(mod_auth mod_auth_basic)]); $self->default_module(php => [qw(sapi_apache2 mod_php4 mod_php5)]); $self->{server}->post_config; return $self; } sub default_module { my($self, $name, $choices) = @_; my $mname = $name . '_module_name'; unless ($self->{vars}->{$mname}) { ($self->{vars}->{$mname}) = grep { $self->{modules}->{"$_.c"}; } @$choices; $self->{vars}->{$mname} ||= $choices->[0]; } $self->{vars}->{$name . '_module'} = $self->{vars}->{$mname} . '.c' } sub configure_apxs { my $self = shift; $self->{APXS} = $self->default_apxs; return unless $self->{APXS}; $self->{APXS} =~ s{/}{\\}g if WIN32; my $vars = $self->{vars}; $vars->{bindir} ||= $self->apxs('BINDIR', 1); $vars->{sbindir} ||= $self->apxs('SBINDIR'); $vars->{target} ||= $self->apxs('TARGET'); $vars->{conf_dir} ||= $self->apxs('SYSCONFDIR'); if ($vars->{conf_dir}) { $vars->{httpd_conf} ||= catfile $vars->{conf_dir}, 'httpd.conf'; } } sub configure_httpd { my $self = shift; my $vars = $self->{vars}; debug "configuring httpd"; $vars->{target} ||= (WIN32 ? 'Apache.EXE' : 'httpd'); unless ($vars->{httpd}) { #sbindir should be bin/ with the default layout #but its eaiser to workaround apxs than fix apxs for my $dir (map { $vars->{$_} } qw(sbindir bindir)) { next unless defined $dir; my $httpd = catfile $dir, $vars->{target}; next unless -x $httpd; $vars->{httpd} = $httpd; last; } $vars->{httpd} ||= $self->default_httpd; } if ($vars->{httpd}) { my @chunks = splitdir $vars->{httpd}; #handle both $prefix/bin/httpd and $prefix/Apache.exe for (1,2) { pop @chunks; last unless @chunks; $self->{httpd_basedir} = catfile @chunks; last if -d "$self->{httpd_basedir}/bin"; } } #cleanup httpd droppings my $sem = catfile $vars->{t_logs}, 'apache_runtime_status.sem'; unless (-e $sem) { $self->clean_add_file($sem); } } sub configure_httpd_eapi { my $self = shift; my $vars = $self->{vars}; #deal with EAPI_MM_CORE_PATH if defined. if (defined($self->{httpd_defines}->{EAPI_MM_CORE_PATH})) { my $path = $self->{httpd_defines}->{EAPI_MM_CORE_PATH}; #ensure the directory exists my @chunks = splitdir $path; pop @chunks; #the file component of the path $path = catdir @chunks; unless (file_name_is_absolute $path) { $path = catdir $vars->{serverroot}, $path; } $self->gendir($path); } } sub configure_proxy { my $self = shift; my $vars = $self->{vars}; #if we proxy to ourselves, must bump the maxclients if ($vars->{proxy} =~ /^on$/i) { unless ($vars->{maxclients_preset}) { $vars->{minclients}++; $vars->{maxclients}++; $vars->{maxspare}++; $vars->{startserversthreadedmpm} ++; $vars->{minclientsthreadedmpm} += $vars->{threadsperchild}; $vars->{maxclientsthreadedmpm} += $vars->{threadsperchild}; $vars->{maxsparethreadedmpm} += $vars->{threadsperchild}; #In addition allow for some backend processes #in keep-alive state. For threaded MPMs we #already should be fine. $vars->{maxclients} += 3; } $vars->{proxy} = $self->{vhosts}->{'mod_proxy'}->{hostport}; return $vars->{proxy}; } return undef; } # adds the config to the head of the group instead of the tail # XXX: would be even better to add to a different sub-group # (e.g. preamble_first) of only those that want to be first and then, # make sure that they are dumped to the config file first in the same # group (e.g. preamble) sub add_config_first { my $self = shift; my $where = shift; unshift @{ $self->{$where} }, $self->massage_config_args(@_); } sub add_config_last { my $self = shift; my $where = shift; push @{ $self->{$where} }, $self->massage_config_args(@_); } sub massage_config_args { my $self = shift; my($directive, $arg, $data) = @_; my $args = ""; if ($data) { $args = "<$directive $arg>\n"; if (ref($data) eq 'HASH') { while (my($k,$v) = each %$data) { $args .= " $k $v\n"; } } elsif (ref($data) eq 'ARRAY') { # balanced (key=>val) list my $pairs = @$data / 2; for my $i (0..($pairs-1)) { $args .= sprintf " %s %s\n", $data->[$i*2], $data->[$i*2+1]; } } else { $data=~s/\n(?!\z)/\n /g; $args .= " $data"; } $args .= "\n"; } elsif (ref($directive) eq 'ARRAY') { $args = join "\n", @$directive; } else { $args = join " ", grep length($_), $directive, (ref($arg) && (ref($arg) eq 'ARRAY') ? "@$arg" : $arg || ""); } return $args; } sub postamble_first { shift->add_config_first(postamble => @_); } sub postamble { shift->add_config_last(postamble => @_); } sub preamble_first { shift->add_config_first(preamble => @_); } sub preamble { shift->add_config_last(preamble => @_); } sub postamble_register { push @{ shift->{postamble_hooks} }, @_; } sub preamble_register { push @{ shift->{preamble_hooks} }, @_; } sub add_config_hooks_run { my($self, $where, $out) = @_; for (@{ $self->{"${where}_hooks"} }) { if ((ref($_) and ref($_) eq 'CODE') or $self->can($_)) { $self->$_(); } else { error "cannot run configure hook: `$_'"; } } for (@{ $self->{$where} }) { $self->replace; s/\n?$/\n/; print $out "$_"; } } sub postamble_run { shift->add_config_hooks_run(postamble => @_); } sub preamble_run { shift->add_config_hooks_run(preamble => @_); } sub default_group { return if WINFU; my $gid = $); #use only first value if $) contains more than one $gid =~ s/^(\d+).*$/$1/; my $group = $ENV{APACHE_TEST_GROUP} || (getgrgid($gid) || "#$gid"); if ($group eq 'root') { # similar to default_user, we want to avoid perms problems, # when the server is started with group 'root'. When running # under group root it may fail to create dirs and files, # writable only by user my $user = default_user(); my $gid = $user ? (getpwnam($user))[3] : ''; $group = (getgrgid($gid) || "#$gid") if $gid; } $group; } sub default_user { return if WINFU; my $uid = $>; my $user = $ENV{APACHE_TEST_USER} || (getpwuid($uid) || "#$uid"); if ($user eq 'root') { my $other = (getpwnam('nobody'))[0]; if ($other) { $user = $other; } else { die "cannot run tests as User root"; #XXX: prompt for another username } } return $user; } sub default_serveradmin { my $vars = shift->{vars}; join '@', ($vars->{user} || 'unknown'), $vars->{servername}; } sub default_apxs { my $self = shift; return $self->{vars}->{apxs} if $self->{vars}->{apxs}; if (my $build_config = $self->modperl_build_config()) { return $build_config->{MP_APXS}; } if ($ENV{APACHE_TEST_APXS}) { return $ENV{APACHE_TEST_APXS}; } # look in PATH as a last resort if (my $apxs = which('apxs')) { return $apxs; } elsif ($apxs = which('apxs2')) { return $apxs; } return; } sub default_httpd { my $self = shift; my $vars = $self->{vars}; if (my $build_config = $self->modperl_build_config()) { if (my $p = $build_config->{MP_AP_PREFIX}) { for my $bindir (qw(bin sbin)) { my $httpd = catfile $p, $bindir, $vars->{target}; return $httpd if -e $httpd; # The executable on Win32 in Apache/2.2 is httpd.exe, # so try that if Apache.exe doesn't exist if (WIN32) { $httpd = catfile $p, $bindir, 'httpd.EXE'; if (-e $httpd) { $vars->{target} = 'httpd.EXE'; return $httpd; } } } } } if ($ENV{APACHE_TEST_HTTPD}) { return $ENV{APACHE_TEST_HTTPD}; } # look in PATH as a last resort if (my $httpd = which('httpd')) { return $httpd; } elsif ($httpd = which('httpd2')) { return $httpd; } elsif ($httpd = which('apache')) { return $httpd; } elsif ($httpd = which('apache2')) { return $httpd; } return; } my $localhost; sub default_localhost { my $localhost_addr = pack('C4', 127, 0, 0, 1); gethostbyaddr($localhost_addr, Socket::AF_INET()) || 'localhost'; } sub default_servername { my $self = shift; $localhost ||= $self->default_localhost; die "Can't figure out the default localhost's server name" unless $localhost; } # memoize the selected value (so we make sure that the same port is used # via select). The problem is that select_first_port() is called 3 times after # -clean, and it's possible that a lower port will get released # between calls, leading to various places in the test suite getting a # different base port selection. # # XXX: There is still a problem if two t/TEST's configure at the same # time, so they both see the same port free, but only the first one to # bind() will actually get the port. So there is a need in another # check and reconfiguration just before the server starts. # my $port_memoized; sub select_first_port { my $self = shift; my $port ||= $port_memoized || $ENV{APACHE_TEST_PORT} || $self->{vars}{port} || DEFAULT_PORT; # memoize $port_memoized = $port; return $port unless $port eq 'select'; # port select mode: try to find another available port, take into # account that each instance of the test suite may use more than # one port for virtual hosts, therefore try to check ports in big # steps (20?). my $step = 20; my $tries = 20; $port = DEFAULT_PORT; until (Apache::TestServer->port_available($port)) { unless (--$tries) { error "no ports available"; error "tried ports @{[DEFAULT_PORT]} - $port in $step increments"; return 0; } $port += $step; } info "the default base port is used, using base port $port instead" unless $port == DEFAULT_PORT; # memoize $port_memoized = $port; return $port; } my $remote_addr; sub our_remote_addr { my $self = shift; my $name = $self->default_servername; my $iaddr = (gethostbyname($name))[-1]; unless (defined $iaddr) { error "Can't resolve host: '$name' (check /etc/hosts)"; exit 1; } $remote_addr ||= Socket::inet_ntoa($iaddr); } sub default_loopback { '127.0.0.1'; } sub port { my($self, $module) = @_; unless ($module) { my $vars = $self->{vars}; return $self->select_first_port() unless $vars->{scheme} eq 'https'; $module = $vars->{ssl_module_name}; } return $self->{vhosts}->{$module}->{port}; } sub hostport { my $self = shift; my $vars = shift || $self->{vars}; my $module = shift || ''; my $name = $vars->{servername}; join ':', $name , $self->port($module || ''); } #look for mod_foo.so sub find_apache_module { my($self, $module) = @_; die "find_apache_module: module name argument is required" unless $module; my $vars = $self->{vars}; my $sroot = $vars->{serverroot}; my @trys = grep { $_ } ($vars->{src_dir}, $self->apxs('LIBEXECDIR'), catfile($sroot, 'modules'), catfile($sroot, 'libexec')); for (@trys) { my $file = catfile $_, $module; if (-e $file) { debug "found $module => $file"; return $file; } } # if the module wasn't found try to lookup in the list of modules # inherited from the system-wide httpd.conf my $name = $module; $name =~ s/\.s[ol]$/.c/; #mod_info.so => mod_info.c $name =~ s/^lib/mod_/; #libphp4.so => mod_php4.c return $self->{modules}->{$name} if $self->{modules}->{$name}; } #generate files and directories my %warn_style = ( html => sub { "" }, c => sub { "/* @_ */" }, php => sub { "" }, default => sub { join '', grep {s/^/\# /gm} @_ }, ); my %file_ext = ( map({$_ => 'html'} qw(htm html)), map({$_ => 'c' } qw(c h)), map({$_ => 'php' } qw(php)), ); # return the passed file's extension or '' if there is no one # note: that '/foo/bar.conf.in' returns an extension: 'conf.in'; # note: a hidden file .foo will be recognized as an extension 'foo' sub filename_ext { my ($self, $filename) = @_; my $ext = (File::Basename::fileparse($filename, '\..*'))[2] || ''; $ext =~ s/^\.(.*)/lc $1/e; $ext; } sub warn_style_sub_ref { my ($self, $filename) = @_; my $ext = $self->filename_ext($filename); return $warn_style{ $file_ext{$ext} || 'default' }; } sub genwarning { my($self, $filename, $from_filename) = @_; return unless $filename; my $time = scalar localtime; my $warning = "WARNING: this file is generated"; $warning .= " (from $from_filename)" if defined $from_filename; $warning .= ", do not edit\n"; $warning .= "generated on $time\n"; $warning .= calls_trace(); return $self->warn_style_sub_ref($filename)->($warning); } sub calls_trace { my $frame = 1; my $trace = ''; while (1) { my($package, $filename, $line) = caller($frame); last unless $filename; $trace .= sprintf "%02d: %s:%d\n", $frame, $filename, $line; $frame++; } return $trace; } sub clean_add_file { my($self, $file) = @_; $self->{clean}->{files}->{ rel2abs($file) } = 1; } sub clean_add_path { my($self, $path) = @_; $path = rel2abs($path); # remember which dirs were created and should be cleaned up while (1) { $self->{clean}->{dirs}->{$path} = 1; $path = dirname $path; last if -e $path; } } sub genfile_trace { my($self, $file, $from_file) = @_; my $name = abs2rel $file, $self->{vars}->{t_dir}; my $msg = "generating $name"; $msg .= " from $from_file" if defined $from_file; debug $msg; } sub genfile_warning { my($self, $file, $from_file, $fh) = @_; if (my $msg = $self->genwarning($file, $from_file)) { print $fh $msg, "\n"; } } # $from_file == undef if there was no templates used sub genfile { my($self, $file, $from_file, $nowarning) = @_; # create the parent dir if it doesn't exist yet my $dir = dirname $file; $self->makepath($dir); $self->genfile_trace($file, $from_file); my $fh = Symbol::gensym(); open $fh, ">$file" or die "open $file: $!"; $self->genfile_warning($file, $from_file, $fh) unless $nowarning; $self->clean_add_file($file); return $fh; } # gen + write file sub writefile { my($self, $file, $content, $nowarning) = @_; my $fh = $self->genfile($file, undef, $nowarning); print $fh $content if $content; close $fh; } sub perlscript_header { require FindBin; my @dirs = (); # mp2 needs its modper-2.0/lib before blib was created if (IS_MOD_PERL_2_BUILD || $ENV{APACHE_TEST_LIVE_DEV}) { # the live 'lib/' dir of the distro # (e.g. modperl-2.0/ModPerl-Registry/lib) my $dir = canonpath catdir $FindBin::Bin, "lib"; push @dirs, $dir if -d $dir; # the live dir of the top dir if any (e.g. modperl-2.0/lib) if (-e catfile($FindBin::Bin, "..", "Makefile.PL")) { my $dir = canonpath catdir $FindBin::Bin, "..", "lib"; push @dirs, $dir if -d $dir; } } for (qw(. ..)) { my $dir = canonpath catdir $FindBin::Bin, $_ , "Apache-Test", "lib"; if (-d $dir) { push @dirs, $dir; last; } } { my $dir = canonpath catdir $FindBin::Bin, "t", "lib"; push @dirs, $dir if -d $dir; } push @dirs, canonpath $FindBin::Bin; my $dirs = join("\n ", '', @dirs) . "\n";; return <<"EOF"; use strict; use warnings FATAL => 'all'; use lib qw($dirs); EOF } # gen + write executable perl script file sub write_perlscript { my($self, $file, $content) = @_; my $fh = $self->genfile($file, undef, 1); my $shebang = make_shebang(); print $fh $shebang; $self->genfile_warning($file, undef, $fh); print $fh $content if $content; close $fh; chmod 0755, $file; } sub make_shebang { # if perlpath is longer than 62 chars, some shells on certain # platforms won't be able to run the shebang line, so when seeing # a long perlpath use the eval workaround. # see: http://en.wikipedia.org/wiki/Shebang # http://homepages.cwi.nl/~aeb/std/shebang/ my $shebang = length $Config{perlpath} < 62 ? "#!$Config{perlpath}\n" : <clean_add_file($to); } sub symlink { my($self, $from, $to) = @_; CORE::symlink($from, $to); $self->clean_add_file($to); } sub gendir { my($self, $dir) = @_; $self->makepath($dir); } # returns a list of dirs successfully created sub makepath { my($self, $path) = @_; return if !defined($path) || -e $path; $self->clean_add_path($path); return File::Path::mkpath($path, 0, 0755); } sub open_cmd { my($self, $cmd) = @_; # untaint some %ENV fields local @ENV{ qw(IFS CDPATH ENV BASH_ENV) }; local $ENV{PATH} = untaint_path($ENV{PATH}); # launder for -T $cmd = $1 if $cmd =~ /(.*)/; my $handle = Symbol::gensym(); open $handle, "$cmd|" or die "$cmd failed: $!"; return $handle; } sub clean { my $self = shift; $self->{clean_level} = shift || 2; #2 == really clean, 1 == reconfigure $self->new_test_server->clean; $self->cmodules_clean; $self->sslca_clean; for (sort keys %{ $self->{clean}->{files} }) { if (-e $_) { debug "unlink $_"; unlink $_; } else { debug "unlink $_: $!"; } } # if /foo comes before /foo/bar, /foo will never be removed # hence ensure that sub-dirs are always treated before a parent dir for (reverse sort keys %{ $self->{clean}->{dirs} }) { if (-d $_) { my $dh = Symbol::gensym(); opendir($dh, $_); my $notempty = grep { ! /^\.{1,2}$/ } readdir $dh; closedir $dh; next if $notempty; debug "rmdir $_"; rmdir $_; } } } my %special_tokens = ( nextavailableport => sub { shift->server->select_next_port } ); sub replace { my $self = shift; my $file = $Apache::TestConfig::File ? "in file $Apache::TestConfig::File" : ''; s[@(\w+)@] [ my $key = lc $1; if (my $callback = $special_tokens{$key}) { $self->$callback; } elsif (exists $self->{vars}->{$key}) { $self->{vars}->{$key}; } else { die "invalid token: \@$1\@ $file\n"; } ]ge; } #need to configure the vhost port for redirects and $ENV{SERVER_PORT} #to have the correct values my %servername_config = ( 0 => sub { my($name, $port) = @_; [ServerName => ''], [Port => 0]; }, 1 => sub { my($name, $port) = @_; [ServerName => $name], [Port => $port]; }, 2 => sub { my($name, $port) = @_; [ServerName => "$name:$port"]; }, ); sub servername_config { my $self = shift; $self->server->version_of(\%servername_config)->(@_); } sub parse_vhost { my($self, $line) = @_; my($indent, $module, $namebased); if ($line =~ /^(\s*)\s*$/) { $indent = $1 || ""; $namebased = $2 || ""; $module = $3; } else { return undef; } my $vars = $self->{vars}; my $mods = $self->{modules}; my $have_module = "$module.c"; my $ssl_module = $vars->{ssl_module}; #if module ends with _ssl and it is not the module that implements ssl, #then assume this module is a vhost with SSLEngine On (or similar) #see mod_echo in extra.conf.in for example if ($module =~ /^(mod_\w+)_ssl$/ and $have_module ne $ssl_module) { $have_module = "$1.c"; #e.g. s/mod_echo_ssl.c/mod_echo.c/ return undef unless $mods->{$ssl_module}; } #don't allocate a port if this module is not configured #assumes the configuration is inside an if ($module =~ /^mod_/ and not $mods->{$have_module}) { return undef; } #allocate a port and configure this module into $self->{vhosts} my $port = $self->new_vhost($module, $namebased); #extra config that should go *inside* the my @in_config = $self->servername_config($namebased ? $namebased : $vars->{servername}, $port); my @out_config = (); if ($self->{vhosts}->{$module}->{namebased} < 2) { #extra config that should go *outside* the @out_config = ([Listen => '0.0.0.0:' . $port]); if ($self->{vhosts}->{$module}->{namebased}) { push @out_config => ["\n". "${indent}${indent}NameVirtualHost" => "*:$port\n${indent}"]; } } $self->{vars}->{$module . '_port'} = $port; #there are two ways of building a vhost #first is when we parse test .pm and .c files #second is when we scan *.conf.in my $form_postamble = sub { my $indent = shift; for my $pair (@_) { $self->postamble("$indent@$pair"); } }; my $form_string = sub { my $indent = shift; join "\n", map { "$indent@$_\n" } @_; }; my $double_indent = $indent ? $indent x 2 : ' ' x 4; return { port => $port, #used when parsing .pm and .c test modules in_postamble => sub { $form_postamble->($double_indent, @in_config) }, out_postamble => sub { $form_postamble->($indent, @out_config) }, #used when parsing *.conf.in files in_string => $form_string->($double_indent, @in_config), out_string => $form_string->($indent, @out_config), line => "$indent", }; } sub find_and_load_module { my ($self, $name) = @_; my $mod_path = $self->find_apache_module($name) or return; my ($sym) = $name =~ m/mod_(\w+)\./; if ($mod_path && -e $mod_path) { $self->preamble(IfModule => "!mod_$sym.c", qq{LoadModule ${sym}_module "$mod_path"\n}); } return 1; } sub replace_vhost_modules { my $self = shift; if (my $cfg = $self->parse_vhost($_)) { $_ = ''; for my $key (qw(out_string line in_string)) { next unless $cfg->{$key}; $_ .= "$cfg->{$key}\n"; } } } sub replace_vars { my($self, $in, $out) = @_; local $_; while (<$in>) { $self->replace; $self->replace_vhost_modules; print $out $_; } } sub index_html_template { my $self = shift; return "welcome to $self->{server}->{name}\n"; } sub generate_index_html { my $self = shift; my $dir = $self->{vars}->{documentroot}; $self->gendir($dir); my $file = catfile $dir, 'index.html'; return if -e $file; my $fh = $self->genfile($file); print $fh $self->index_html_template; } sub types_config_template { return <find_and_load_module('mod_mime.so'); unless ($self->{inherit_config}->{TypesConfig}) { my $types = catfile $self->{vars}->{t_conf}, 'mime.types'; unless (-e $types) { my $fh = $self->genfile($types); print $fh $self->types_config_template; close $fh; } $self->postamble(< TypesConfig "$types" EOI } } # various dup bugs in older perl and perlio in perl < 5.8.4 need a # workaround to explicitly rewind the dupped DATA fh before using it my $DATA_pos = tell DATA; sub httpd_conf_template { my($self, $try) = @_; my $in = Symbol::gensym(); if (open $in, $try) { return $in; } else { my $dup = Symbol::gensym(); open $dup, "<&DATA" or die "Can't dup DATA: $!"; seek $dup, $DATA_pos, 0; # rewind to the beginning return $dup; # so we don't close DATA } } #certain variables may not be available until certain config files #are generated. for example, we don't know the ssl port until ssl.conf.in #is parsed. ssl port is needed for proxyssl testing sub check_vars { my $self = shift; my $vars = $self->{vars}; unless ($vars->{proxyssl_url}) { my $ssl = $self->{vhosts}->{ $vars->{ssl_module_name} }; if ($ssl) { $vars->{proxyssl_url} ||= $ssl->{hostport}; } if ($vars->{proxyssl_url}) { unless ($vars->{maxclients_preset}) { $vars->{minclients}++; $vars->{maxclients}++; $vars->{maxspare}++; $vars->{startserversthreadedmpm} ++; $vars->{minclientsthreadedmpm} += $vars->{threadsperchild}; $vars->{maxclientsthreadedmpm} += $vars->{threadsperchild}; $vars->{maxsparethreadedmpm} += $vars->{threadsperchild}; #In addition allow for some backend processes #in keep-alive state. For threaded MPMs we #already should be fine. $vars->{maxclients} += 3; } } } } sub extra_conf_files_needing_update { my $self = shift; my @need_update = (); finddepth(sub { return unless /\.in$/; (my $generated = $File::Find::name) =~ s/\.in$//; push @need_update, $generated unless -e $generated && -M $generated < -M $File::Find::name; }, $self->{vars}->{t_conf}); return @need_update; } sub generate_extra_conf { my $self = shift; my(@extra_conf, @conf_in, @conf_files); finddepth(sub { return unless /\.in$/; push @conf_in, catdir $File::Find::dir, $_; }, $self->{vars}->{t_conf}); #make ssl port always be 8530 when available for my $file (@conf_in) { if (basename($file) =~ /^ssl/) { unshift @conf_files, $file; } else { push @conf_files, $file; } } for my $file (@conf_files) { (my $generated = $file) =~ s/\.in$//; debug "Will 'Include' $generated config file"; push @extra_conf, $generated; } # regenerate .conf files for my $file (@conf_files) { local $Apache::TestConfig::File = $file; my $in = Symbol::gensym(); open($in, $file) or next; (my $generated = $file) =~ s/\.in$//; my $out = $self->genfile($generated, $file); $self->replace_vars($in, $out); close $in; close $out; $self->check_vars; } #we changed order to give ssl the first port after DEFAULT_PORT #but we want extra.conf Included first so vhosts inherit base config #such as LimitRequest* return [ sort @extra_conf ]; } sub sslca_can { my($self, $check) = @_; my $vars = $self->{vars}; return 0 unless $self->{modules}->{ $vars->{ssl_module} }; return 0 unless -d "$vars->{t_conf}/ssl"; require Apache::TestSSLCA; if ($check) { my $openssl = Apache::TestSSLCA::openssl(); if (which($openssl)) { return 1; } error "cannot locate '$openssl' program required to generate SSL CA"; exit(1); } return 1; } sub sslca_generate { my $self = shift; my $ca = $self->{vars}->{sslca}; return if $ca and -d $ca; #t/conf/ssl/ca return unless $self->sslca_can(1); Apache::TestSSLCA::generate($self); } sub sslca_clean { my $self = shift; # XXX: httpd config is required, for now just skip ssl clean if # there is none. should probably add some flag which will tell us # when httpd_config was already run return unless $self->{vars}->{httpd} && $self->{vars}->{ssl_module}; return unless $self->sslca_can; Apache::TestSSLCA::clean($self); } #XXX: just a quick hack to support t/TEST -ssl #outside of httpd-test/perl-framework sub generate_ssl_conf { my $self = shift; my $vars = $self->{vars}; my $conf = "$vars->{t_conf}/ssl"; my $httpd_test_ssl = "../httpd-test/perl-framework/t/conf/ssl"; my $ssl_conf = "$vars->{top_dir}/$httpd_test_ssl"; if (-d $ssl_conf and not -d $conf) { $self->gendir($conf); for (qw(ssl.conf.in)) { $self->cpfile("$ssl_conf/$_", "$conf/$_"); } for (qw(certs keys crl)) { $self->symlink("$ssl_conf/$_", "$conf/$_"); } } } sub find_in_inc { my($self, $dir) = @_; for my $path (@INC) { my $location = "$path/$dir"; return $location if -d $location; } return ""; } sub prepare_t_conf { my $self = shift; $self->gendir($self->{vars}->{t_conf}); } my %aliases = ( "perl-pod" => "perlpod", "binary-httpd" => "httpd", "binary-perl" => "perl", ); sub generate_httpd_conf { my $self = shift; my $vars = $self->{vars}; #generated httpd.conf depends on these things to exist $self->generate_types_config; $self->generate_index_html; $self->gendir($vars->{t_logs}); $self->gendir($vars->{t_state}); $self->gendir($vars->{t_conf}); my @very_last_postamble = (); if (my $extra_conf = $self->generate_extra_conf) { for my $file (@$extra_conf) { my $entry; if ($file =~ /\.conf$/) { next if $file =~ m|/httpd\.conf$|; $entry = qq(Include "$file"); } elsif ($file =~ /\.pl$/) { $entry = qq(\n PerlRequire "$file"\n\n); } else { next; } # put the .last includes very last if ($file =~ /\.last\.(conf|pl)$/) { push @very_last_postamble, $entry; } else { $self->postamble($entry); } } } $self->configure_proxy; my $conf_file = $vars->{t_conf_file}; my $conf_file_in = join '.', $conf_file, 'in'; my $in = $self->httpd_conf_template($conf_file_in); my $out = $self->genfile($conf_file); $self->find_and_load_module('mod_alias.so'); $self->preamble_run($out); for my $name (qw(user group)) { #win32 if ($vars->{$name}) { print $out qq[\u$name "$vars->{$name}"\n]; } } #2.0: ServerName $ServerName:$Port #1.3: ServerName $ServerName # Port $Port my @name_cfg = $self->servername_config($vars->{servername}, $vars->{port}); for my $pair (@name_cfg) { print $out "@$pair\n"; } $self->replace_vars($in, $out); # handle the case when mod_alias is built as a shared object # but wasn't included in the system-wide httpd.conf print $out "\n"; for (sort keys %aliases) { next unless $vars->{$aliases{$_}}; print $out " Alias /getfiles-$_ $vars->{$aliases{$_}}\n"; } print $out "\n"; print $out "\n"; $self->postamble_run($out); print $out join "\n", @very_last_postamble; close $in; close $out or die "close $conf_file: $!"; } sub need_reconfiguration { my($self, $conf_opts) = @_; my @reasons = (); my $vars = $self->{vars}; # if '-port select' we need to check from scratch which ports are # available if (my $port = $conf_opts->{port} || $Apache::TestConfig::Argv{port}) { if ($port eq 'select') { push @reasons, "'-port $port' requires reconfiguration"; } } my $exe = $vars->{apxs} || $vars->{httpd} || ''; # if httpd.conf is older than executable push @reasons, "$exe is newer than $vars->{t_conf_file}" if -e $exe && -e $vars->{t_conf_file} && -M $exe < -M $vars->{t_conf_file}; # any .in files are newer than their derived versions? if (my @files = $self->extra_conf_files_needing_update) { # invalidate the vhosts cache, since a different port could be # assigned on reparse $self->{vhosts} = {}; for my $file (@files) { push @reasons, "$file.in is newer than $file"; } } # if special env variables are used (since they can change any time) # XXX: may be we could check whether they have changed since the # last run and thus avoid the reconfiguration? { my $passenv = passenv(); if (my @env_vars = sort grep { $ENV{$_} } keys %$passenv) { push @reasons, "environment variables (@env_vars) are set"; } } # if the generated config was created with a version of Apache-Test # less than the current version { my $current = Apache::Test->VERSION; my $config = $self->{apache_test_version}; if (! $config || $config < $current) { push @reasons, "configuration generated with old Apache-Test"; } } return @reasons; } sub error_log { my($self, $rel) = @_; my $file = catfile $self->{vars}->{t_logs}, 'error_log'; my $rfile = abs2rel $file, $self->{vars}->{top_dir}; return wantarray ? ($file, $rfile) : $rel ? $rfile : $file; } #utils #For Win32 systems, stores the extensions used for executable files #They may be . prefixed, so we will strip the leading periods. my @path_ext = (); if (WIN32) { if ($ENV{PATHEXT}) { push @path_ext, split ';', $ENV{PATHEXT}; for my $ext (@path_ext) { $ext =~ s/^\.*(.+)$/$1/; } } else { #Win9X: doesn't have PATHEXT push @path_ext, qw(com exe bat); } } sub which { my $program = shift; return undef unless $program; # No need to search PATH components # if $program already contains a path return $program if !OSX and !WINFU and $program =~ /\// and -f $program and -x $program; my @dirs = File::Spec->path(); require Config; my $perl_bin = $Config::Config{bin} || ''; push @dirs, $perl_bin if $perl_bin and -d $perl_bin; for my $base (map { catfile $_, $program } @dirs) { if ($ENV{HOME} and not WIN32) { # only works on Unix, but that's normal: # on Win32 the shell doesn't have special treatment of '~' $base =~ s/~/$ENV{HOME}/o; } return $base if -x $base && -f _; if (WIN32) { for my $ext (@path_ext) { return "$base.$ext" if -x "$base.$ext" && -f _; } } } } sub apxs { my($self, $q, $ok_fail) = @_; return unless $self->{APXS}; my $val; unless (exists $self->{_apxs}{$q}) { local @ENV{ qw(IFS CDPATH ENV BASH_ENV) }; local $ENV{PATH} = untaint_path($ENV{PATH}); my $devnull = devnull(); my $apxs = shell_ready($self->{APXS}); $val = qx($apxs -q $q 2>$devnull); chomp $val if defined $val; # apxs post-2.0.40 adds a new line if ($val) { $self->{_apxs}{$q} = $val; } unless ($val) { if ($ok_fail) { return ""; } else { warn "APXS ($self->{APXS}) query for $q failed\n"; return $val; } } } $self->{_apxs}{$q}; } # return an untainted PATH sub untaint_path { my $path = shift; return '' unless defined $path; ($path) = ( $path =~ /(.*)/ ); # win32 uses ';' for a path separator, assume others use ':' my $sep = WIN32 ? ';' : ':'; # -T disallows relative and empty directories in the PATH return join $sep, grep File::Spec->file_name_is_absolute($_), grep length($_), split /$sep/, $path; } sub pop_dir { my $dir = shift; my @chunks = splitdir $dir; while (my $remove = shift) { pop @chunks if $chunks[-1] eq $remove; } catfile @chunks; } sub add_inc { my $self = shift; return if $ENV{MOD_PERL}; #already setup by mod_perl require lib; # make sure that Apache-Test/lib will be first in @INC, # followed by modperl-2.0/lib (or some other project's lib/), # followed by blib/ and finally system-wide libs. my $top_dir = $self->{vars}->{top_dir}; my @dirs = map { catdir $top_dir, "blib", $_ } qw(lib arch); my $apache_test_dir = catdir $top_dir, "Apache-Test"; unshift @dirs, $apache_test_dir if -d $apache_test_dir; lib::->import(@dirs); if ($ENV{APACHE_TEST_LIVE_DEV}) { # add lib/ in a separate call to ensure that it'll end up on # top of @INC my $lib_dir = catdir $top_dir, "lib"; lib::->import($lib_dir) if -d $lib_dir; } #print join "\n", "add_inc", @INC, ""; } #freeze/thaw so other processes can access config sub thaw { my $class = shift; $class->new({thaw => 1, @_}); } sub freeze { require Data::Dumper; local $Data::Dumper::Terse = 1; my $data = Data::Dumper::Dumper(shift); chomp $data; $data; } sub sync_vars { my $self = shift; return if $self->{save}; #this is not a cached config my $changed = 0; my $thaw = $self->thaw; my $tvars = $thaw->{vars}; my $svars = $self->{vars}; for my $key (@_) { for my $v ($tvars, $svars) { if (exists $v->{$key} and not defined $v->{$key}) { $v->{$key} = ''; #rid undef } } next if exists $tvars->{$key} and exists $svars->{$key} and $tvars->{$key} eq $svars->{$key}; $tvars->{$key} = $svars->{$key}; $changed = 1; } return unless $changed; $thaw->{save} = 1; $thaw->save; } sub save { my($self) = @_; return unless $self->{save}; # add in the Apache-Test version for later comparisions $self->{apache_test_version} = Apache::Test->VERSION; my $name = 'apache_test_config'; my $file = catfile $self->{vars}->{t_conf}, "$name.pm"; my $fh = $self->genfile($file); debug "saving config data to $name.pm"; (my $obj = $self->freeze) =~ s/^/ /; print $fh <new({thaw=>1}); # XXX: need to run httpd config to get the value of httpd if (my $httpd = $test_config->{vars}->{httpd}) { $httpd = shell_ready($httpd); $command = "$httpd -V"; $cfg .= "\n*** $command\n"; $cfg .= qx{$command}; $cfg .= ldd_as_string($httpd); } else { $cfg .= "\n\n*** The httpd binary was not found\n"; } # perl opts my $perl = shell_ready($^X); $command = "$perl -V"; $cfg .= "\n\n*** $command\n"; $cfg .= qx{$command}; return $cfg; } sub ldd_as_string { my $httpd = shift; my $command; if (OSX) { my $otool = which('otool'); $command = "$otool -L $httpd" if $otool; } elsif (!WIN32) { my $ldd = which('ldd'); $command = "$ldd $httpd" if $ldd; } my $cfg = ''; if ($command) { $cfg .= "\n*** $command\n"; $cfg .= qx{$command}; } return $cfg; } # make a string suitable for feed to shell calls (wrap in quotes and # escape quotes) sub shell_ready { my $arg = shift; $arg =~ s!\\?"!\\"!g; return qq["$arg"]; } 1; =head1 NAME Apache::TestConfig -- Test Configuration setup module =head1 SYNOPSIS use Apache::TestConfig; my $cfg = Apache::TestConfig->new(%args) my $fh = $cfg->genfile($file); $cfg->writefile($file, $content); $cfg->gendir($dir); ... =head1 DESCRIPTION C is used in creating the C configuration files. =head1 FUNCTIONS =over =item genwarning() my $warn = $cfg->genwarning($filename) genwarning() returns a warning string as a comment, saying that the file was autogenerated and that it's not a good idea to modify this file. After the warning a perl trace of calls to this this function is appended. This trace is useful for finding what code has created the file. my $warn = $cfg->genwarning($filename, $from_filename) If C<$from_filename> is specified it'll be used in the warning to tell which file it was generated from. genwarning() automatically recognizes the comment type based on the file extension. If the extension is not recognized, the default C<#> style is used. Currently it support C!-- --E>, C and C<#> styles. =item genfile() my $fh = $cfg->genfile($file); genfile() creates a new file C<$file> for writing and returns a file handle. If parent directories of C<$file> don't exist they will be automagically created. The file C<$file> and any created parent directories (if found empty) will be automatically removed on cleanup. A comment with a warning and calls trace is added to the top of this file. See genwarning() for more info about this comment. my $fh = $cfg->genfile($file, $from_file); If C<$from_filename> is specified it'll be used in the warning to tell which file it was generated from. my $fh = $cfg->genfile($file, $from_file, $nowarning); If C<$nowarning> is true, the warning won't be added. If using this optional argument and there is no C<$from_file> you must pass undef as in: my $fh = $cfg->genfile($file, undef, $nowarning); =item writefile() $cfg->writefile($file, $content, [$nowarning]); writefile() creates a new file C<$file> with the content of C<$content>. A comment with a warning and calls trace is added to the top of this file unless C<$nowarnings> is passed and set to a true value. See genwarning() for more info about this comment. If parent directories of C<$file> don't exist they will be automagically created. The file C<$file> and any created parent directories (if found empty) will be automatically removed on cleanup. =item write_perlscript() $cfg->write_perlscript($filename, @lines); Similar to writefile() but creates an executable Perl script with correctly set shebang line. =item gendir() $cfg->gendir($dir); gendir() creates a new directory C<$dir>. If parent directories of C<$dir> don't exist they will be automagically created. The directory C<$dir> and any created parent directories will be automatically removed on cleanup if found empty. =back =head1 Environment Variables The following environment variables affect the configuration and the run-time of the C framework: =head2 APACHE_TEST_COLOR To aid visual control over the configuration process and the run-time phase, C uses coloured fonts when the environment variable C is set to a true value. =head2 APACHE_TEST_LIVE_DEV When using C during the project development phase, it's often convenient to have the I (live) directory appearing first in C<@INC> so any changes to the Perl modules, residing in it, immediately affect the server, without a need to rerun C to update I. When the environment variable C is set to a true value during the configuration phase (C, C will automatically unshift the I directory into C<@INC>, via the autogenerated I file. =head1 Special Placeholders When generating configuration files from the I<*.in> templates, special placeholder variables get substituted. To embed a placeholder use the C<@foo@> syntax. For example in I you can write: Include @ServerRoot@/conf/myconfig.conf When I is generated, C<@ServerRoot@> will get replaced with the location of the server root. Placeholders are case-insensitive. Available placeholders: =head2 Configuration Options All configuration variables that can be passed to C, such as C, C, C, etc. To see the complete list run: % t/TEST --help and you will find them in the C sections. =head2 NextAvailablePort Every time this placeholder is encountered it'll be replaced with the next available port. This is very useful if you need to allocate a special port, but not hardcode it. Later when running: % t/TEST -port=select it's possible to run several concurrent test suites on the same machine, w/o having port collisions. =head1 AUTHOR =head1 SEE ALSO perl(1), Apache::Test(3) =cut __DATA__ Listen 0.0.0.0:@Port@ ServerRoot "@ServerRoot@" DocumentRoot "@DocumentRoot@" PidFile @t_pid_file@ ErrorLog @t_logs@/error_log LogLevel debug 2.4.1> DefaultRunTimeDir "@t_logs@" LogLevel trace8 2.4.34> DefaultStateDir "@t_state@" TransferLog @t_logs@/access_log ScriptSock @t_logs@/cgisock ServerAdmin @ServerAdmin@ #needed for http/1.1 testing KeepAlive On HostnameLookups Off Options FollowSymLinks AllowOverride None LockFile @t_logs@/accept.lock StartServers @StartServersThreadedMPM@ MinSpareThreads @ThreadsPerChild@ MaxSpareThreads @MaxSpareThreadedMPM@ ThreadsPerChild @ThreadsPerChild@ MaxClients @MaxClientsThreadedMPM@ MaxRequestsPerChild 0 LockFile @t_logs@/accept.lock NumServers 1 StartThreads @MinClients@ MinSpareThreads 1 MaxSpareThreads @MaxSpare@ MaxThreadsPerChild @MaxClients@ MaxRequestsPerChild 0 LockFile @t_logs@/accept.lock StartServers @MinClients@ MinSpareServers 1 MaxSpareServers @MaxSpare@ MaxClients @MaxClients@ MaxRequestsPerChild 0 LockFile @t_logs@/accept.lock StartServers @MinClients@ MinSpareServers 1 MaxSpareServers @MaxSpare@ MaxClients @MaxClients@ MaxRequestsPerChild 0 ThreadsPerChild 50 MaxRequestsPerChild 0 SetHandler server-info SetHandler server-status