diff options
Diffstat (limited to 'debian/perl-framework/Apache-Test/lib/Apache/TestConfigPerl.pm')
| -rw-r--r-- | debian/perl-framework/Apache-Test/lib/Apache/TestConfigPerl.pm | 654 |
1 files changed, 654 insertions, 0 deletions
diff --git a/debian/perl-framework/Apache-Test/lib/Apache/TestConfigPerl.pm b/debian/perl-framework/Apache-Test/lib/Apache/TestConfigPerl.pm new file mode 100644 index 0000000..152ef58 --- /dev/null +++ b/debian/perl-framework/Apache-Test/lib/Apache/TestConfigPerl.pm @@ -0,0 +1,654 @@ +# 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 TestConfigPerl on purpose + +#things specific to mod_perl + +use strict; +use warnings FATAL => 'all'; +use File::Spec::Functions qw(catfile splitdir abs2rel file_name_is_absolute); +use File::Find qw(finddepth); +use Apache::TestTrace; +use Apache::TestRequest; +use Config; + +my %libmodperl = (1 => 'libperl.so', 2 => 'mod_perl.so'); + +sub configure_libmodperl { + my $self = shift; + + my $server = $self->{server}; + my $libname = $server->version_of(\%libmodperl); + my $vars = $self->{vars}; + + if ($vars->{libmodperl}) { + # if set, libmodperl was specified from the command line and + # should be used instead of the one that is looked up + + # resolve a non-absolute path + $vars->{libmodperl} = $self->find_apache_module($vars->{libmodperl}) + unless file_name_is_absolute($vars->{libmodperl}); + } + # $server->{rev} could be set to 2 as a fallback, even when + # the wanted version is 1. So check that we use mod_perl 2 + elsif ($server->{rev} >= 2 && IS_MOD_PERL_2) { + + if (my $build_config = $self->modperl_build_config()) { + if ($build_config->{MODPERL_LIB_SHARED}) { + $libname = $build_config->{MODPERL_LIB_SHARED}; + $vars->{libmodperl} ||= $self->find_apache_module($libname); + } else { + $vars->{libmodperl} ||= $self->find_apache_module('mod_perl.so'); + } + # XXX: we have a problem with several perl trees pointing + # to the same httpd tree. So it's possible that we + # configure the test suite to run with mod_perl.so built + # against perl which it wasn't built with. Should we use + # something like ldd to check the match? + # + # For now, we'll default to the first mod_perl.so found. + } + else { + # XXX: can we test whether mod_perl was linked statically + # so we don't need to preload it + # if (!linked statically) { + # die "can't find mod_perl built for perl version $]" + # } + error "can't find mod_perl.so built for perl version $]"; + } + # don't use find_apache_module or we may end up with the wrong + # shared object, built against different perl + } + else { + # mod_perl 1.0 + $vars->{libmodperl} ||= $self->find_apache_module($libname); + # XXX: how do we find out whether we have a static or dynamic + # mod_perl build? die if its dynamic and can't find the module + } + + my $cfg = ''; + + if ($vars->{libmodperl} && -e $vars->{libmodperl}) { + if (Apache::TestConfig::WIN32) { + my $lib = "$Config{installbin}\\$Config{libperl}"; + $lib =~ s/lib$/dll/; + $cfg = 'LoadFile ' . qq("$lib"\n) if -e $lib; + } + # add the module we found to the cached modules list + # otherwise have_module('mod_perl') doesn't work unless + # we have a LoadModule in our base config + $self->{modules}->{'mod_perl.c'} = $vars->{libmodperl}; + + $cfg .= 'LoadModule ' . qq(perl_module "$vars->{libmodperl}"\n); + } + else { + my $msg = "unable to locate $libname (could be a static build)\n"; + $cfg = "#$msg"; + debug $msg; + } + + $self->preamble(IfModule => '!mod_perl.c', $cfg); + +} + +sub configure_inc { + my $self = shift; + + my $top = $self->{vars}->{top_dir}; + + my $inc = $self->{inc}; + + for (catdir($top, qw(blib lib)), catdir($top, qw(blib arch))) { + if (-d $_) { + push @$inc, $_; + } + } + + # try ../blib as well for Apache::Reload & Co + for (catdir($top, qw(.. blib lib)), catdir($top, qw(.. blib arch))) { + push @$inc, $_ if -d $_; + } + + # spec: If PERL5LIB is defined, PERLLIB is not used. + for (qw(PERL5LIB PERLLIB)) { + next unless exists $ENV{$_}; + push @$inc, split /$Config{path_sep}/, $ENV{$_}; + last; + } + + # enable live testing of the Apache-Test dev modules if they are + # located at the project's root dir + my $apache_test_dev_dir = catfile($top, 'Apache-Test', 'lib'); + unshift @$inc, $apache_test_dev_dir if -d $apache_test_dev_dir; +} + +sub write_pm_test { + my($self, $module, $sub, @base) = @_; + + my $dir = catfile $self->{vars}->{t_dir}, @base; + my $t = catfile $dir, "$sub.t"; + return if -e $t; + + $self->gendir($dir); + my $fh = $self->genfile($t); + + my $path = Apache::TestRequest::module2path($module); + + print $fh <<EOF; +use Apache::TestRequest 'GET_BODY_ASSERT'; +print GET_BODY_ASSERT "/$path"; +EOF + + close $fh or die "close $t: $!"; +} + +# propogate PerlPassEnv settings to the server +sub configure_env { + my $self = shift; + $self->preamble(IfModule => 'mod_perl.c', + [ qw(PerlPassEnv APACHE_TEST_TRACE_LEVEL + PerlPassEnv HARNESS_PERL_SWITCHES + PerlPassEnv APACHE_TEST_NO_STICKY_PREFERENCES) + ]); +} + +sub startup_pl_code { + my $self = shift; + my $serverroot = $self->{vars}->{serverroot}; + + my $cover = <<'EOF'; + if (($ENV{HARNESS_PERL_SWITCHES}||'') =~ m/Devel::Cover/) { + eval { + # 0.48 is the first version of Devel::Cover that can + # really generate mod_perl coverage statistics + require Devel::Cover; + Devel::Cover->VERSION(0.48); + + # this ignores coverage data for some generated files + Devel::Cover->import('+inc' => 't/response/',); + + 1; + } or die "Devel::Cover error: $@"; + } +EOF + + return <<"EOF"; +BEGIN { + use lib '$serverroot'; + for my \$file (qw(modperl_inc.pl modperl_extra.pl)) { + eval { require "conf/\$file" } or + die if grep { -e "\$_/conf/\$file" } \@INC; + } + +$cover +} + +1; +EOF +} + +sub configure_startup_pl { + my $self = shift; + + #for 2.0 we could just use PerlSwitches -Mlib=... + #but this will work for both 2.0 and 1.xx + if (my $inc = $self->{inc}) { + my $include_pl = catfile $self->{vars}->{t_conf}, 'modperl_inc.pl'; + my $fh = $self->genfile($include_pl); + for (reverse @$inc) { + next unless $_; + print $fh "use lib '$_';\n"; + } + my $tlib = catdir $self->{vars}->{t_dir}, 'lib'; + if (-d $tlib) { + print $fh "use lib '$tlib';\n"; + } + + # directory for temp packages which can change during testing + # we use require here since a circular dependency exists + # between Apache::TestUtil and Apache::TestConfigPerl, so + # use does not work here + eval { require Apache::TestUtil; }; + if ($@) { + die "could not require Apache::TestUtil: $@"; + } else { + print $fh "use lib '" . Apache::TestUtil::_temp_package_dir() . "';\n"; + } + + # if Apache::Test is used to develop a project, we want the + # project/lib directory to be first in @INC (loaded last) + if ($ENV{APACHE_TEST_LIVE_DEV}) { + my $dev_lib = catdir $self->{vars}->{top_dir}, "lib"; + print $fh "use lib '$dev_lib';\n" if -d $dev_lib; + } + + print $fh "1;\n"; + } + + if ($self->server->{rev} >= 2) { + $self->postamble(IfModule => 'mod_perl.c', + "PerlSwitches -Mlib=$self->{vars}->{serverroot}\n"); + } + + my $startup_pl = catfile $self->{vars}->{t_conf}, 'modperl_startup.pl'; + + unless (-e $startup_pl) { + my $fh = $self->genfile($startup_pl); + print $fh $self->startup_pl_code; + close $fh; + } + + $self->postamble(IfModule => 'mod_perl.c', + "PerlRequire $startup_pl\n"); +} + +my %sethandler_modperl = (1 => 'perl-script', 2 => 'modperl'); + +sub set_handler { + my($self, $module, $args) = @_; + return if grep { $_ eq 'SetHandler' } @$args; + + push @$args, + SetHandler => + $self->server->version_of(\%sethandler_modperl); +} + +sub set_connection_handler { + my($self, $module, $args) = @_; + my $port = $self->new_vhost($module); + my $vars = $self->{vars}; + $self->postamble(Listen => '0.0.0.0:' . $port); +} + +my %add_hook_config = ( + Response => \&set_handler, + ProcessConnection => \&set_connection_handler, + PreConnection => \&set_connection_handler, +); + +my %container_config = ( + ProcessConnection => \&vhost_container, + PreConnection => \&vhost_container, +); + +sub location_container { + my($self, $module) = @_; + my $path = Apache::TestRequest::module2path($module); + Location => "/$path"; +} + +sub vhost_container { + my($self, $module) = @_; + my $port = $self->{vhosts}->{$module}->{port}; + my $namebased = $self->{vhosts}->{$module}->{namebased}; + + VirtualHost => ($namebased ? '*' : '_default_') . ":$port"; +} + +sub new_vhost { + my($self, $module, $namebased) = @_; + my($port, $servername, $vhost); + + unless ($namebased and exists $self->{vhosts}->{$module}) { + $port = $self->server->select_next_port; + $vhost = $self->{vhosts}->{$module} = {}; + + $vhost->{port} = $port; + $vhost->{namebased} = $namebased ? 1 : 0; + } + else { + $vhost = $self->{vhosts}->{$module}; + $port = $vhost->{port}; + # remember the already configured Listen/NameVirtualHost + $vhost->{namebased}++; + } + + $servername = $self->{vars}->{servername}; + + $vhost->{servername} = $servername; + $vhost->{name} = join ':', $servername, $port; + $vhost->{hostport} = $self->hostport($vhost, $module); + + $port; +} + +my %outside_container = map { $_, 1 } qw{ +Alias AliasMatch AddType +PerlChildInitHandler PerlTransHandler PerlPostReadRequestHandler +PerlSwitches PerlRequire PerlModule +}; + +my %strip_tags = map { $_ => 1} qw(base noautoconfig); + +#test .pm's can have configuration after the __DATA__ token +sub add_module_config { + my($self, $module, $args) = @_; + my $fh = Symbol::gensym(); + open($fh, $module) or return; + + while (<$fh>) { + last if /^(__(DATA|END)__|\#if CONFIG_FOR_HTTPD_TEST)/; + } + + my %directives; + + while (<$fh>) { + last if /^\#endif/; #for .c modules + next unless /\S+/; + chomp; + s/^\s+//; + $self->replace; + if (/^#/) { + # preserve comments + $self->postamble($_); + next; + } + my($directive, $rest) = split /\s+/, $_, 2; + $directives{$directive}++ unless $directive =~ /^</; + $rest = '' unless defined $rest; + + if ($outside_container{$directive}) { + $self->postamble($directive => $rest); + } + elsif ($directive =~ /IfModule/) { + $self->postamble($_); + } + elsif ($directive =~ m/^<(\w+)/) { + # strip special container directives like <Base> and </Base> + my $strip_container = exists $strip_tags{lc $1} ? 1 : 0; + + $directives{noautoconfig}++ if lc($1) eq 'noautoconfig'; + + my $indent = ''; + $self->process_container($_, $fh, lc($1), + $strip_container, $indent); + } + else { + push @$args, $directive, $rest; + } + } + + \%directives; +} + + +# recursively process the directives including nested containers, +# re-indent 4 and ucfirst the closing tags letter +sub process_container { + my($self, $first_line, $fh, $directive, $strip_container, $indent) = @_; + + my $new_indent = $indent; + + unless ($strip_container) { + $new_indent .= " "; + + local $_ = $first_line; + s/^\s*//; + $self->replace; + + if (/<VirtualHost/) { + $self->process_vhost_open_tag($_, $indent); + } + else { + $self->postamble($indent . $_); + } + } + + $self->process_container_remainder($fh, $directive, $new_indent); + + unless ($strip_container) { + $self->postamble($indent . "</\u$directive>"); + } + +} + + +# processes the body of the container without the last line, including +# the end tag +sub process_container_remainder { + my($self, $fh, $directive, $indent) = @_; + + my $end_tag = "</$directive>"; + + while (<$fh>) { + chomp; + last if m|^\s*\Q$end_tag|i; + s/^\s*//; + $self->replace; + + if (m/^\s*<(\w+)/) { + $self->process_container($_, $fh, $1, 0, $indent); + } + else { + $self->postamble($indent . $_); + } + } +} + +# does the necessary processing to create a vhost container header +sub process_vhost_open_tag { + my($self, $line, $indent) = @_; + + my $cfg = $self->parse_vhost($line); + + if ($cfg) { + my $port = $cfg->{port}; + $cfg->{out_postamble}->(); + $self->postamble($cfg->{line}); + $cfg->{in_postamble}->(); + } else { + $self->postamble("$indent$line"); + } +} + +#the idea for each group: +# Response: there will be many of these, mostly modules to test the API +# that plan tests => ... and output with ok() +# the naming allows grouping, making it easier to run an +# individual set of tests, e.g. t/TEST t/apr +# the PerlResponseHandler and SetHandler modperl is auto-configured +# Hooks: for testing the simpler Perl*Handlers +# auto-generates the Perl*Handler config +# Protocol: protocol modules need their own port/vhost to listen on + +#@INC is auto-modified so each test .pm can be found +#modules can add their own configuration using __DATA__ + +my %hooks = map { $_, ucfirst $_ } + qw(init trans headerparser access authen authz type fixup log); +$hooks{Protocol} = 'ProcessConnection'; +$hooks{Filter} = 'OutputFilter'; + +my @extra_subdirs = qw(Response Protocol PreConnection Hooks Filter); + +# add the subdirs to @INC early, in case mod_perl is started earlier +sub configure_pm_tests_inc { + my $self = shift; + for my $subdir (@extra_subdirs) { + my $dir = catfile $self->{vars}->{t_dir}, lc $subdir; + next unless -d $dir; + + push @{ $self->{inc} }, $dir; + } +} + +# @status fields +use constant APACHE_TEST_CONFIGURE => 0; +use constant APACHE_TEST_CONFIG_ORDER => 1; + +sub configure_pm_tests_pick { + my($self, $entries) = @_; + + for my $subdir (@extra_subdirs) { + my $dir = catfile $self->{vars}->{t_dir}, lc $subdir; + next unless -d $dir; + + finddepth(sub { + return unless /\.pm$/; + + my $file = catfile $File::Find::dir, $_; + my $module = abs2rel $file, $dir; + my $status = $self->run_apache_test_config_scan($file); + push @$entries, [$file, $module, $subdir, $status]; + }, $dir); + } +} + + +# a simple numerical order is performed and configuration sections are +# inserted using that order. If the test package specifies no special +# token that matches /APACHE_TEST_CONFIG_ORDER\s+([+-]?\d+)/ anywhere +# in the file, 0 is assigned as its order. If the token is specified, +# config section with negative values will be inserted first, with +# positive last. By using different values you can arrange for the +# test configuration sections to be inserted in any desired order +sub configure_pm_tests_sort { + my($self, $entries) = @_; + + @$entries = sort { + $a->[3]->[APACHE_TEST_CONFIG_ORDER] <=> + $b->[3]->[APACHE_TEST_CONFIG_ORDER] + } @$entries; + +} + +sub configure_pm_tests { + my $self = shift; + + my @entries = (); + $self->configure_pm_tests_pick(\@entries); + $self->configure_pm_tests_sort(\@entries); + + for my $entry (@entries) { + my ($file, $module, $subdir, $status) = @$entry; + my @args = (); + + my $file_display; + { + $file_display=$file; + my $topdir=$self->{vars}->{top_dir}; + $file_display=~s!^\Q$topdir\E(.)(?:\1)*!!; + } + $self->postamble("\n# included from $file_display"); + my $directives = $self->add_module_config($file, \@args); + $module =~ s,\.pm$,,; + $module =~ s/^[a-z]://i; #strip drive if any + $module = join '::', splitdir $module; + + $self->run_apache_test_configure($file, $module, $status); + + my @base = + map { s/^test//i; $_ } split '::', $module; + + my $sub = pop @base; + + my $hook = ($subdir eq 'Hooks' ? $hooks{$sub} : '') + || $hooks{$subdir} || $subdir; + + if ($hook eq 'OutputFilter' and $module =~ /::i\w+$/) { + #XXX: tmp hack + $hook = 'InputFilter'; + } + + my $handler = join $hook, qw(Perl Handler); + + if ($self->server->{rev} < 2 and lc($hook) eq 'response') { + $handler =~ s/response//i; #s/PerlResponseHandler/PerlHandler/ + } + + debug "configuring $module"; + + unless ($directives->{noautoconfig}) { + if (my $cv = $add_hook_config{$hook}) { + $self->$cv($module, \@args); + } + + my $container = $container_config{$hook} || \&location_container; + + #unless the .pm test already configured the Perl*Handler + unless ($directives->{$handler}) { + my @handler_cfg = ($handler => $module); + + if ($outside_container{$handler}) { + my $cfg = $self->massage_config_args(@handler_cfg); + $self->postamble(IfModule => 'mod_perl.c', $cfg); + } else { + push @args, @handler_cfg; + } + } + + if (@args) { + my $cfg = $self->massage_config_args($self->$container($module), \@args); + $self->postamble(IfModule => 'mod_perl.c', $cfg); + } + } + $self->postamble("# end of $file_display\n"); + + $self->write_pm_test($module, lc $sub, map { lc } @base); + } +} + +# scan tests for interesting information +sub run_apache_test_config_scan { + my ($self, $file) = @_; + + my @status = (); + $status[APACHE_TEST_CONFIGURE] = 0; + $status[APACHE_TEST_CONFIG_ORDER] = 0; + + my $fh = Symbol::gensym(); + if (open $fh, $file) { + local $/; + my $content = <$fh>; + close $fh; + # XXX: optimize to match once? + if ($content =~ /APACHE_TEST_CONFIGURE/m) { + $status[APACHE_TEST_CONFIGURE] = 1; + } + if ($content =~ /APACHE_TEST_CONFIG_ORDER\s+([+-]?\d+)/m) { + $status[APACHE_TEST_CONFIG_ORDER] = int $1; + } + } + else { + error "cannot open $file: $!"; + } + + return \@status; +} + +# We have to test whether tests have APACHE_TEST_CONFIGURE() in them +# and run it if found at this stage, so when the server starts +# everything is ready. +# XXX: however we cannot use a simple require() because some tests +# won't require() outside of mod_perl environment. Therefore we scan +# the slurped file in. and if APACHE_TEST_CONFIGURE has been found we +# require the file and run this function. +sub run_apache_test_configure { + my ($self, $file, $module, $status) = @_; + + return unless $status->[APACHE_TEST_CONFIGURE]; + + eval { require $file }; + warn $@ if $@; + # double check that it's a real sub + if ($module->can('APACHE_TEST_CONFIGURE')) { + eval { $module->APACHE_TEST_CONFIGURE($self); }; + warn $@ if $@; + } +} + + +1; |