diff options
Diffstat (limited to 'debian/perl-framework/Apache-Test/lib/Apache')
32 files changed, 15480 insertions, 0 deletions
diff --git a/debian/perl-framework/Apache-Test/lib/Apache/Test.pm b/debian/perl-framework/Apache-Test/lib/Apache/Test.pm new file mode 100644 index 0000000..b3263c6 --- /dev/null +++ b/debian/perl-framework/Apache-Test/lib/Apache/Test.pm @@ -0,0 +1,1214 @@ +# 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::Test; + +use strict; +use warnings FATAL => 'all'; + +use Exporter (); +use Config; +use Apache::TestConfig (); +use Test qw/ok skip/; + +BEGIN { + # Apache::Test loads a bunch of mp2 stuff while getting itself + # together. because we need to choose one of mp1 or mp2 to load + # check first (and we choose mp2) $mod_perl::VERSION == 2.0 + # just because someone loaded Apache::Test. This Is Bad. so, + # let's try to correct for that here by removing mod_perl from + # %INC after the above use() statements settle in. nobody + # should be relying on us loading up mod_perl.pm anyway... + + delete $INC{'mod_perl.pm'}; +} + +use vars qw(@ISA @EXPORT %EXPORT_TAGS $VERSION %SubTests @SkipReasons); + +$VERSION = '1.42'; + +my @need = qw(need_lwp need_http11 need_cgi need_access need_auth + need_module need_apache need_min_apache_version need_min_apache_fix + need_apache_version need_perl need_min_perl_version + need_min_module_version need_threads need_fork need_apache_mpm + need_php need_php4 need_ssl need_imagemap need_cache_disk); + +my @have = map { (my $need = $_) =~ s/need/have/; $need } @need; + +@ISA = qw(Exporter); +@EXPORT = (qw(sok plan skip_reason under_construction need), + @need, @have); + +%SubTests = (); +@SkipReasons = (); + +sub cp { + my @l; + for( my $i=1; (@l=caller $i)[0] eq __PACKAGE__; $i++ ) {}; + return wantarray ? @l : $l[0]; +} + +my $Config; +my %wtm; +sub import { + my $class=$_[0]; + my $wtm=0; + my @base_exp; + my @exp; + my %my_exports; + undef @my_exports{@EXPORT}; + + my ($caller,$f,$l)=cp; + + for( my $i=1; $i<@_; $i++ ) { + if( $_[$i] eq '-withtestmore' ) { + $wtm=1; + } + elsif( $_[$i] eq ':DEFAULT' ) { + push @exp, $_[$i]; + push @base_exp, $_[$i]; + } + elsif( $_[$i] eq '!:DEFAULT' ) { + push @exp, $_[$i]; + push @base_exp, $_[$i]; + } + elsif( $_[$i]=~m@^[:/!]@ ) { + warn("Ignoring import spec $_[$i] ". + "at $f line $l\n") + } + elsif( exists $my_exports{$_[$i]} ) { + push @exp, $_[$i]; + } + else { + push @base_exp, $_[$i]; + } + } + if (!@exp and @base_exp) { + @exp=('!:DEFAULT'); + } + elsif (@exp and !@base_exp) { + @base_exp=('!:DEFAULT'); + } + + $wtm{$caller}=[$wtm,$f,$l] unless exists $wtm{$caller}; + + warn("Ignoring -withtestmore due to a previous call ". + "($wtm{$caller}->[1]:$wtm{$caller}->[2]) without it ". + "at $f line $l\n") + if $wtm{$caller}->[0]==0 and $wtm==1; + + $class->export_to_level(1, $class, @exp); + + push @base_exp, '!plan'; + if( $wtm{$caller}->[0] ) { # -withtestmore + eval <<"EVAL" +package $caller; +#line $l $f +use Test::More import=>\\\@base_exp; +EVAL + } + else { # -withouttestmore + eval <<"EVAL"; +package $caller; +#line $l $f +use Test \@base_exp; +EVAL + } + die $@ if $@; +} + +sub config { + $Config ||= Apache::TestConfig->thaw->httpd_config; +} + +my $Basic_config; + +# config bits which doesn't require httpd to be found +sub basic_config { + $Basic_config ||= Apache::TestConfig->thaw(); +} + +sub vars { + @_ ? @{ config()->{vars} }{ @_ } : config()->{vars}; +} + +sub sok (&;$) { + my $sub = shift; + my $nok = shift || 1; #allow sok to have 'ok' within + + my ($caller,$f,$l)=cp; + + if (exists $wtm{$caller} and $wtm{$caller}->[0]==1) { # -withtestmore + require Test::Builder; + my $tb=Test::Builder->new; + + if (%SubTests and not $SubTests{ 1+$tb->current_test }) { + $tb->skip("skipping this subtest") for (1..$nok); + return; + } + + # trick ok() into reporting the caller filename/line when a + # sub-test fails in sok() + return eval <<EOE; +#line $l $f + Test::More::ok(\$sub->()); +EOE + } + else { + if (%SubTests and not $SubTests{ $Test::ntest }) { + skip("skipping this subtest", 0) for (1..$nok); + return; + } + + # trick ok() into reporting the caller filename/line when a + # sub-test fails in sok() + return eval <<EOE; +#line $l $f + Test::ok(\$sub->()); +EOE + } +} + +#so Perl's Test.pm can be run inside mod_perl +sub test_pm_refresh { + my ($caller,$f,$l)=cp; + + if (exists $wtm{$caller} and $wtm{$caller}->[0]==1) { # -withtestmore + require Test::Builder; + my $builder = Test::Builder->new; + + $builder->reset; + + $builder->output(\*STDOUT); + $builder->todo_output(\*STDOUT); + + # this is STDOUT because Test::More seems to put + # most of the stuff we want on STDERR, so it ends + # up in the error_log instead of where the user can + # see it. consider leaving it alone based on + # later user reports. + $builder->failure_output(\*STDOUT); + } + else { # -withouttestmore + unless (exists $wtm{$caller}) { + warn "You forgot to 'use Apache::Test' in package $caller\n"; + $wtm{$caller}=[0,$f,$l]; + } + if (defined &Test::_reset_globals) { + Test::_reset_globals(); + # Test.pm uses $TESTOUT=*STDOUT{IO}. We cannot do that + # due to the way SetupEnv works. + $Test::TESTOUT = \*STDOUT; + } + else { + $Test::TESTOUT = \*STDOUT; + $Test::planned = 0; + $Test::ntest = 1; + %Test::todo = (); + } + } +} + +sub init_test_pm { + my $r = shift; + + # needed to load Apache2::RequestRec::TIEHANDLE + eval {require Apache2::RequestIO}; + if (defined &Apache2::RequestRec::TIEHANDLE) { + untie *STDOUT; + tie *STDOUT, $r; + require Apache2::RequestRec; # $r->pool + require APR::Pool; + $r->pool->cleanup_register(sub { untie *STDOUT }); + } + else { + $r->send_http_header; #1.xx + } + + $r->content_type('text/plain'); +} + +sub plan { + init_test_pm(shift) if ref $_[0]; + test_pm_refresh(); + + # extending Test::plan's functionality, by using the optional + # single value in @_ coming after a ballanced %hash which + # Test::plan expects + if (@_ % 2) { + my $condition = pop @_; + my $ref = ref $condition; + my $meets_condition = 0; + if ($ref) { + if ($ref eq 'CODE') { + #plan tests $n, \&has_lwp + $meets_condition = $condition->(); + } + elsif ($ref eq 'ARRAY') { + #plan tests $n, [qw(php4 rewrite)]; + $meets_condition = need_module($condition); + } + else { + die "don't know how to handle a condition of type $ref"; + } + } + else { + # we have the verdict already: true/false + $meets_condition = $condition ? 1 : 0; + } + + # trying to emulate a dual variable (ala errno) + unless ($meets_condition) { + my $reason = join ', ', + @SkipReasons ? @SkipReasons : "no reason given"; + print "1..0 # skipped: $reason\n"; + @SkipReasons = (); # reset + exit; #XXX: Apache->exit + } + } + @SkipReasons = (); # reset + + my ($caller,$f,$l)=cp; + + %SubTests=(); + if (my $subtests=$ENV{HTTPD_TEST_SUBTESTS}) { + %SubTests=map { $_, 1 } split /\s+/, $subtests; + } + + if (exists $wtm{$caller} and $wtm{$caller}->[0]==1) { # -withtestmore + Test::More::plan(@_); + } + else { # -withouttestmore + unless (exists $wtm{$caller}) { + warn "You forgot to 'use Apache::Test' in package $caller\n"; + $wtm{$caller}=[0,$f,$l]; + } + Test::plan(@_); + } + + # add to Test.pm verbose output + print "# Using Apache/Test.pm version $VERSION\n"; +} + +sub need_http11 { + require Apache::TestRequest; + if (Apache::TestRequest::install_http11()) { + return 1; + } + else { + push @SkipReasons, + "LWP version 5.60+ required for HTTP/1.1 support"; + return 0; + } +} + +sub need_ssl { + my $vars = vars(); + need_module([$vars->{ssl_module_name}, 'IO::Socket::SSL']); +} + +sub need_lwp { + require Apache::TestRequest; + if (Apache::TestRequest::has_lwp()) { + return 1; + } + else { + push @SkipReasons, "libwww-perl is not installed"; + return 0; + } +} + +sub need { + my $need_all = 1; + for my $cond (@_) { + if (ref $cond eq 'HASH') { + while (my($reason, $value) = each %$cond) { + $value = $value->() if ref $value eq 'CODE'; + next if $value; + push @SkipReasons, $reason; + $need_all = 0; + } + } + elsif ($cond =~ /^(0|1)$/) { + $need_all = 0 if $cond == 0; + } + else { + $need_all = 0 unless need_module($cond); + } + } + return $need_all; + +} + +sub need_module { + my $cfg = config(); + + my @modules = grep defined $_, + ref($_[0]) eq 'ARRAY' ? @{ $_[0] } : @_; + + my @reasons = (); + for (@modules) { + if (/^[a-z0-9_.]+$/) { + my $mod = $_; + $mod .= '.c' unless $mod =~ /\.c$/; + next if $cfg->{modules}->{$mod}; + $mod = 'mod_' . $mod unless $mod =~ /^mod_/; + next if $cfg->{modules}->{$mod}; + if (exists $cfg->{cmodules_disabled}->{$mod}) { + push @reasons, $cfg->{cmodules_disabled}->{$mod}; + next; + } + } + die "bogus module name $_" unless /^[\w:.]+$/; + + # if the module was explicitly passed with a .c extension, + # do not try to eval it as a Perl module + my $not_found = 1; + unless (/\.c$/) { + eval "require $_"; + $not_found = 0 unless $@; + #print $@ if $@; + } + push @reasons, "cannot find module '$_'" if $not_found; + + } + if (@reasons) { + push @SkipReasons, @reasons; + return 0; + } + else { + return 1; + } +} + +sub need_min_perl_version { + my $version = shift; + + return 1 if $] >= $version; + + push @SkipReasons, "perl >= $version is required"; + return 0; +} + +# currently supports only perl modules +sub need_min_module_version { + my($module, $version) = @_; + + # need_module requires the perl module + return 0 unless need_module($module); + + # support dev versions like 0.18_01 + return 1 + if eval { no warnings qw(numeric); $module->VERSION($version) }; + + push @SkipReasons, "$module version $version or higher is required"; + return 0; +} + +sub need_cgi { + return _need_multi(qw(cgi.c cgid.c)); +} + +sub need_cache_disk { + return _need_multi(qw(cache_disk.c disk_cache.c)); +} + + +sub need_php { + return _need_multi(qw(php4 php5 sapi_apache2.c)); +} + +sub need_php4 { + return _need_multi(qw(php4 sapi_apache2.c)); +} + +sub need_access { + return _need_multi(qw(access authz_host)); +} + +sub need_auth { + return _need_multi(qw(auth auth_basic)); +} + +sub need_imagemap { + return need_module("imagemap") || need_module("imap"); +} + +sub _need_multi { + + my @check = @_; + + my $rc = 0; + + { + local @SkipReasons; + + foreach my $module (@check) { + $rc ||= need_module($module); + } + } + + my $reason = join ' or ', @check; + + push @SkipReasons, "cannot find one of $reason" + unless $rc; + + return $rc; +} + +sub need_apache { + my $version = shift; + my $cfg = Apache::Test::config(); + my $rev = $cfg->{server}->{rev}; + + if ($rev == $version) { + return 1; + } + else { + push @SkipReasons, + "apache version $version required, this is version $rev"; + return 0; + } +} + +sub need_min_apache_version { + my $wanted = shift; + my $cfg = Apache::Test::config(); + (my $current) = $cfg->{server}->{version} =~ m:^Apache/(\d\.\d+\.\d+):; + + if (normalize_vstring($current) < normalize_vstring($wanted)) { + push @SkipReasons, + "apache version $wanted or higher is required," . + " this is version $current"; + return 0; + } + else { + return 1; + } +} + +sub need_min_apache_fix { + my @wantlevels = @_; + my $cfg = Apache::Test::config(); + (my $current) = $cfg->{server}->{version} =~ m:^Apache/((\d)\.(\d+)\.(\d+)):; + my $current_major = $2; + my $current_minor = $3; + my $current_micro = $4; + + foreach(@wantlevels) { + if ($_ =~ m/(\d)\.(\d+)\.(\d+)/) { + my $wanted_major = $1; + my $wanted_minor = $2; + my $wanted_micro = $3; + if ($wanted_major eq $current_major && $wanted_minor eq $current_minor) { + if ($wanted_micro > $current_micro) { + push @SkipReasons, + "apache version $_ or higher is required," . + " this is version $current"; + return 0; + } + else { + return 1; + } + } + } + } + + # We didn't match major+minor, run the test and let the author sort it out + return 1; +} + +sub need_apache_version { + my $wanted = shift; + my $cfg = Apache::Test::config(); + (my $current) = $cfg->{server}->{version} =~ m:^Apache/(\d\.\d+\.\d+):; + + if (normalize_vstring($current) != normalize_vstring($wanted)) { + push @SkipReasons, + "apache version $wanted or higher is required," . + " this is version $current"; + return 0; + } + else { + return 1; + } +} + +sub need_apache_mpm { + my $wanted = shift; + my $cfg = Apache::Test::config(); + my $current = $cfg->{server}->{mpm}; + + if ($current ne $wanted) { + push @SkipReasons, + "apache $wanted mpm is required," . + " this is the $current mpm"; + return 0; + } + else { + return 1; + } +} + +sub config_enabled { + my $key = shift; + defined $Config{$key} and $Config{$key} eq 'define'; +} + +sub need_perl_iolayers { + if (my $ext = $Config{extensions}) { + #XXX: better test? might need to test patchlevel + #if support depends bugs fixed in bleedperl + return $ext =~ m:PerlIO/scalar:; + } + 0; +} + +sub need_perl { + my $thing = shift; + #XXX: $thing could be a version + my $config; + + my $have = \&{"need_perl_$thing"}; + if (defined &$have) { + return 1 if $have->(); + } + else { + for my $key ($thing, "use$thing") { + if (exists $Config{$key}) { + $config = $key; + return 1 if config_enabled($key); + } + } + } + + push @SkipReasons, $config ? + "Perl was not built with $config enabled" : + "$thing is not available with this version of Perl"; + + return 0; +} + +sub need_threads { + my $status = 1; + + # check APR support + my $build_config = Apache::TestConfig->modperl_build_config; + + if ($build_config) { + my $apr_config = $build_config->get_apr_config(); + unless ($apr_config->{HAS_THREADS}) { + $status = 0; + push @SkipReasons, "Apache/APR was built without threads support"; + } + } + + # check Perl's useithreads + my $key = 'useithreads'; + unless (exists $Config{$key} and config_enabled($key)) { + $status = 0; + push @SkipReasons, "Perl was not built with 'ithreads' enabled"; + } + + return $status; +} + +sub need_fork { + my $have_fork = $Config{d_fork} || + $Config{d_pseudofork} || + (($^O eq 'MSWin32' || $^O eq 'NetWare') && + $Config{useithreads} && + $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/); + + if (!$have_fork) { + push @SkipReasons, 'The fork function is unimplemented'; + return 0; + } + else { + return 1; + } +} + +sub under_construction { + push @SkipReasons, "This test is under construction"; + return 0; +} + +sub skip_reason { + my $reason = shift || 'no reason specified'; + push @SkipReasons, $reason; + return 0; +} + +# normalize Apache-style version strings (2.0.48, 0.9.4) +# for easy numeric comparison. note that 2.1 and 2.1.0 +# are considered equivalent. +sub normalize_vstring { + + my @digits = shift =~ m/(\d+)\.?(\d*)\.?(\d*)/; + + return join '', map { sprintf("%03d", $_ || 0) } @digits; +} + +# have_ functions are the same as need_ but they don't populate +# @SkipReasons +for my $func (@have) { + no strict 'refs'; + (my $real_func = $func) =~ s/^have_/need_/; + *$func = sub { + # be nice to poor souls calling functions with $_ argument in + # the foreach loop, etc.! + local $_; + local @SkipReasons; + return $real_func->(@_); + }; +} + +package Apache::TestToString; + +Apache::Test->import('!:DEFAULT'); + +sub TIEHANDLE { + my $string = ""; + bless \$string; +} + +sub PRINT { + my $string = shift; + $$string .= join '', @_; +} + +sub start { + tie *STDOUT, __PACKAGE__; + Apache::Test::test_pm_refresh(); +} + +sub finish { + my $s; + { + my $o = tied *STDOUT; + $s = $$o; + } + untie *STDOUT; + $s; +} + +1; +__END__ + + +=head1 NAME + +Apache::Test - Test.pm wrapper with helpers for testing Apache + +=head1 SYNOPSIS + + use Apache::Test; + +=head1 DESCRIPTION + +B<Apache::Test> is a wrapper around the standard C<Test.pm> with +helpers for testing an Apache server. + +=head1 FUNCTIONS + +=over 4 + +=item plan + +This function is a wrapper around C<Test::plan>: + + plan tests => 3; + +just like using Test.pm, plan 3 tests. + +If the first argument is an object, such as an C<Apache::RequestRec> +object, C<STDOUT> will be tied to it. The C<Test.pm> global state will +also be refreshed by calling C<Apache::Test::test_pm_refresh>. For +example: + + plan $r, tests => 7; + +ties STDOUT to the request object C<$r>. + +If there is a last argument that doesn't belong to C<Test::plan> +(which expects a balanced hash), it's used to decide whether to +continue with the test or to skip it all-together. This last argument +can be: + +=over + +=item * a C<SCALAR> + +the test is skipped if the scalar has a false value. For example: + + plan tests => 5, 0; + +But this won't hint the reason for skipping therefore it's better to +use need(): + + plan tests => 5, + need 'LWP', + { "not Win32" => sub { $^O eq 'MSWin32'} }; + +see C<need()> for more info. + +=item * an C<ARRAY> reference + +need_module() is called for each value in this array. The test is +skipped if need_module() returns false (which happens when at least +one C or Perl module from the list cannot be found). + +Watch out for case insensitive file systems or duplicate modules +with the same name. I.E. If you mean mod_env.c + need_module('mod_env.c') +Not + need_module('env') + +=item * a C<CODE> reference + +the tests will be skipped if the function returns a false value. For +example: + + plan tests => 5, need_lwp; + +the test will be skipped if LWP is not available + +=back + +All other arguments are passed through to I<Test::plan> as is. + +=item ok + +Same as I<Test::ok>, see I<Test.pm> documentation. + +=item sok + +Allows to skip a sub-test, controlled from the command line. The +argument to sok() is a CODE reference or a BLOCK whose return value +will be passed to ok(). By default behaves like ok(). If all sub-tests +of the same test are written using sok(), and a test is executed as: + + % ./t/TEST -v skip_subtest 1 3 + +only sub-tests 1 and 3 will be run, the rest will be skipped. + +=item skip + +Same as I<Test::skip>, see I<Test.pm> documentation. + +=item test_pm_refresh + +Normally called by I<Apache::Test::plan>, this function will refresh +the global state maintained by I<Test.pm>, allowing C<plan> and +friends to be called more than once per-process. This function is not +exported. + +=back + +Functions that can be used as a last argument to the extended plan(). +Note that for each C<need_*> function there is a C<have_*> equivalent +that performs the exact same function except that it is designed to +be used outside of C<plan()>. C<need_*> functions have the side effect +of generating skip messages, if the test is skipped. C<have_*> functions +don't have this side effect. In other words, use C<need_apache()> +with C<plan()> to decide whether a test will run, but C<have_apache()> +within test logic to adjust expectations based on older or newer +server versions. + +=over + +=item need_http11 + + plan tests => 5, need_http11; + +Require HTTP/1.1 support. + +=item need_ssl + + plan tests => 5, need_ssl; + +Require SSL support. + +Not exported by default. + +=item need_lwp + + plan tests => 5, need_lwp; + +Require LWP support. + +=item need_cgi + + plan tests => 5, need_cgi; + +Requires mod_cgi or mod_cgid to be installed. + +=item need_cache_disk + + plan tests => 5, need_cache_disk + +Requires mod_cache_disk or mod_disk_cache to be installed. + + +=item need_php + + plan tests => 5, need_php; + +Requires a PHP module to be installed (version 4 or 5). + +=item need_php4 + + plan tests => 5, need_php4; + +Requires a PHP version 4 module to be installed. + +=item need_imagemap + + plan tests => 5, need_imagemap; + +Requires a mod_imagemap or mod_imap be installed + +=item need_apache + + plan tests => 5, need_apache 2; + +Requires Apache 2nd generation httpd-2.x.xx + + plan tests => 5, need_apache 1; + +Requires Apache 1st generation (apache-1.3.xx) + +See also C<need_min_apache_version()>. + +=item need_min_apache_version + +Used to require a minimum version of Apache. + +For example: + + plan tests => 5, need_min_apache_version("2.0.40"); + +requires Apache 2.0.40 or higher. + +=item need_apache_version + +Used to require a specific version of Apache. + +For example: + + plan tests => 5, need_apache_version("2.0.40"); + +requires Apache 2.0.40. + +=item need_min_apache_fix + +Used to require a particular micro version from corresponding minor release + +For example: + + plan tests => 5, need_min_apache_fix("2.0.40", "2.2.30", "2.4.18"); + +requires Apache 2.0.40 or higher. + +=item need_apache_mpm + +Used to require a specific Apache Multi-Processing Module. + +For example: + + plan tests => 5, need_apache_mpm('prefork'); + +requires the prefork MPM. + +=item need_perl + + plan tests => 5, need_perl 'iolayers'; + plan tests => 5, need_perl 'ithreads'; + +Requires a perl extension to be present, or perl compiled with certain +capabilities. + +The first example tests whether C<PerlIO> is available, the second +whether: + + $Config{useithread} eq 'define'; + +=item need_min_perl_version + +Used to require a minimum version of Perl. + +For example: + + plan tests => 5, need_min_perl_version("5.008001"); + +requires Perl 5.8.1 or higher. + +=item need_fork + +Requires the perl built-in function C<fork> to be implemented. + +=item need_module + + plan tests => 5, need_module 'CGI'; + plan tests => 5, need_module qw(CGI Find::File); + plan tests => 5, need_module ['CGI', 'Find::File', 'cgid']; + +Requires Apache C and Perl modules. The function accept a list of +arguments or a reference to a list. + +In case of C modules, depending on how the module name was passed it +may pass through the following completions: + +=over + +=item 1 need_module 'proxy_http.c' + +If there is the I<.c> extension, the module name will be looked up as +is, i.e. I<'proxy_http.c'>. + +=item 2 need_module 'mod_cgi' + +The I<.c> extension will be appended before the lookup, turning it into +I<'mod_cgi.c'>. + +=item 3 need_module 'cgi' + +The I<.c> extension and I<mod_> prefix will be added before the +lookup, turning it into I<'mod_cgi.c'>. + +=back + +=item need_min_module_version + +Used to require a minimum version of a module + +For example: + + plan tests => 5, need_min_module_version(CGI => 2.81); + +requires C<CGI.pm> version 2.81 or higher. + +Currently works only for perl modules. + +=item need + + plan tests => 5, + need 'LWP', + { "perl >= 5.8.0 and w/ithreads is required" => + ($Config{useperlio} && $] >= 5.008) }, + { "not Win32" => sub { $^O eq 'MSWin32' }, + "foo is disabled" => \&is_foo_enabled, + }, + 'cgid'; + +need() is more generic function which can impose multiple requirements +at once. All requirements must be satisfied. + +need()'s argument is a list of things to test. The list can include +scalars, which are passed to need_module(), and hash references. If +hash references are used, the keys, are strings, containing a reason +for a failure to satisfy this particular entry, the values are the +condition, which are satisfaction if they return true. If the value is +0 or 1, it used to decide whether the requirements very satisfied, so +you can mix special C<need_*()> functions that return 0 or 1. For +example: + + plan tests => 1, need 'Compress::Zlib', 'deflate', + need_min_apache_version("2.0.49"); + +If the scalar value is a string, different from 0 or 1, it's passed to +I<need_module()>. If the value is a code reference, it gets executed +at the time of check and its return value is used to check the +condition. If the condition check fails, the provided (in a key) +reason is used to tell user why the test was skipped. + +In the presented example, we require the presence of the C<LWP> Perl +module, C<mod_cgid>, that we run under perl E<gt>= 5.7.3 on Win32. + +It's possible to put more than one requirement into a single hash +reference, but be careful that the keys will be different. + +It's also important to mention to avoid using: + + plan tests => 1, requirement1 && requirement2; + +technique. While test-wise that technique is equivalent to: + + plan tests => 1, need requirement1, requirement2; + +since the test will be skipped, unless all the rules are satisfied, +it's not equivalent for the end users. The second technique, deploying +C<need()> and a list of requirements, always runs all the requirement +checks and reports all the missing requirements. In the case of the +first technique, if the first requirement fails, the second is not +run, and the missing requirement is not reported. So let's say all the +requirements are missing Apache modules, and a user wants to satisfy +all of these and run the test suite again. If all the unsatisfied +requirements are reported at once, she will need to rebuild Apache +once. If only one requirement is reported at a time, she will have to +rebuild Apache as many times as there are elements in the C<&&> +statement. + +Also see plan(). + +=item under_construction + + plan tests => 5, under_construction; + +skip all tests, noting that the tests are under construction + +=item skip_reason + + plan tests => 5, skip_reason('my custom reason'); + +skip all tests. the reason you specify will be given at runtime. +if no reason is given a default reason will be used. + +=back + +=head1 Additional Configuration Variables + +=over 4 + +=item basic_config + + my $basic_cfg = Apache::Test::basic_config(); + $basic_cfg->write_perlscript($file, $content); + +C<basic_config()> is similar to C<config()>, but doesn't contain any +httpd-specific information and should be used for operations that +don't require any httpd-specific knowledge. + +=item config + + my $cfg = Apache::Test::config(); + my $server_rev = $cfg->{server}->{rev}; + ... + +C<config()> gives an access to the configuration object. + +=item vars + + my $serverroot = Apache::Test::vars->{serverroot}; + my $serverroot = Apache::Test::vars('serverroot'); + my($top_dir, $t_dir) = Apache::Test::vars(qw(top_dir t_dir)); + +C<vars()> gives an access to the configuration variables, otherwise +accessible as: + + $vars = Apache::Test::config()->{vars}; + +If no arguments are passed, the reference to the variables hash is +returned. If one or more arguments are passed the corresponding values +are returned. + +=back + +=head1 Test::More Integration + +There are a few caveats if you want to use I<Apache::Test> with +I<Test::More> instead of the default I<Test> backend. The first is +that I<Test::More> requires you to use its own C<plan()> function +and not the one that ships with I<Apache::Test>. I<Test::More> also +defines C<ok()> and C<skip()> functions that are different, and +simply C<use>ing both modules in your test script will lead to redefined +warnings for these subroutines. + +To assist I<Test::More> users we have created a special I<Apache::Test> +import tag, C<:withtestmore>, which will export all of the standard +I<Apache::Test> symbols into your namespace except the ones that collide +with I<Test::More>. + + use Apache::Test qw(:withtestmore); + use Test::More; + + plan tests => 1; # Test::More::plan() + + ok ('yes', 'testing ok'); # Test::More::ok() + +Now, while this works fine for standard client-side tests +(such as C<t/basic.t>), the more advanced features of I<Apache::Test> +require using I<Test::More> as the sole driver behind the scenes. + +Should you choose to use I<Test::More> as the backend for +server-based tests (such as C<t/response/TestMe/basic.pm>) you will +need to use the C<-withtestmore> action tag: + + use Apache::Test qw(-withtestmore); + + sub handler { + + my $r = shift; + + plan $r, tests => 1; # Test::More::plan() with + # Apache::Test features + + ok ('yes', 'testing ok'); # Test::More::ok() + } + +C<-withtestmore> tells I<Apache::Test> to use I<Test::More> +instead of I<Test.pm> behind the scenes. Note that you are not +required to C<use Test::More> yourself with the C<-withtestmore> +option and that the C<use Test::More tests =E<gt> 1> syntax +may have unexpected results. + +Note that I<Test::More> version 0.49, available within the +I<Test::Simple> 0.49 distribution on CPAN, or greater is required +to use this feature. + +Because I<Apache:Test> was initially developed using I<Test> as +the framework driver, complete I<Test::More> integration is +considered experimental at this time - it is supported as best as +possible but is not guaranteed to be as stable as the default I<Test> +interface at this time. + +=head1 Apache::TestToString Class + +The I<Apache::TestToString> class is used to capture I<Test.pm> output +into a string. Example: + + Apache::TestToString->start; + + plan tests => 4; + + ok $data eq 'foo'; + + ... + + # $tests will contain the Test.pm output: 1..4\nok 1\n... + my $tests = Apache::TestToString->finish; + +=head1 SEE ALSO + +The Apache-Test tutorial: +L<http://perl.apache.org/docs/general/testing/testing.html>. + +L<Apache::TestRequest|Apache::TestRequest> subclasses LWP::UserAgent and +exports a number of useful functions for sending request to the Apache test +server. You can then test the results of those requests. + +Use L<Apache::TestMM|Apache::TestMM> in your F<Makefile.PL> to set up your +distribution for testing. + +=head1 AUTHOR + +Doug MacEachern with contributions from Geoffrey Young, Philippe +M. Chiasson, Stas Bekman and others. + +Questions can be asked at the test-dev <at> httpd.apache.org list +For more information see: http://httpd.apache.org/test/. + +=cut diff --git a/debian/perl-framework/Apache-Test/lib/Apache/Test5005compat.pm b/debian/perl-framework/Apache-Test/lib/Apache/Test5005compat.pm new file mode 100644 index 0000000..8f59a88 --- /dev/null +++ b/debian/perl-framework/Apache-Test/lib/Apache/Test5005compat.pm @@ -0,0 +1,85 @@ +# 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::Test5005compat; + +use strict; +use Symbol (); +use File::Basename; +use File::Path; + +$Apache::Test5005compat::VERSION = '0.01'; + +my %compat_files = ( + 'lib/warnings.pm' => \&warnings_pm, +); + +sub import { + if ($] >= 5.006) { + #make sure old compat stubs dont wipe out installed versions + unlink for keys %compat_files; + return; + } + + eval { require File::Spec::Functions; } or + die "this is only Perl $], you need to install File-Spec from CPAN"; + + my $min_version = 0.82; + unless ($File::Spec::VERSION >= $min_version) { + die "you need to install File-Spec-$min_version or higher from CPAN"; + } + + while (my($file, $sub) = each %compat_files) { + $sub->($file); + } +} + +sub open_file { + my $file = shift; + + unless (-d 'lib') { + $file = "Apache-Test/$file"; + } + + my $dir = dirname $file; + + unless (-d $dir) { + mkpath([$dir], 0, 0755); + } + + my $fh = Symbol::gensym(); + print "creating $file\n"; + open $fh, ">$file" or die "open $file: $!"; + + return $fh; +} + +sub warnings_pm { + return if eval { require warnings }; + + my $fh = open_file(shift); + + print $fh <<'EOF'; +package warnings; + +sub import {} + +1; +EOF + + close $fh; +} + +1; diff --git a/debian/perl-framework/Apache-Test/lib/Apache/TestBuild.pm b/debian/perl-framework/Apache-Test/lib/Apache/TestBuild.pm new file mode 100644 index 0000000..f0004e6 --- /dev/null +++ b/debian/perl-framework/Apache-Test/lib/Apache/TestBuild.pm @@ -0,0 +1,699 @@ +# 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::TestBuild; + +use strict; +use warnings FATAL => 'all'; + +use subs qw(system chdir + info warning); + +use Config; +use File::Spec::Functions; +use File::Path (); +use Cwd (); + +use constant DRYRUN => 0; + +my @min_modules = qw(access auth log-config env mime setenvif + mime autoindex dir alias); + +my %shared_modules = ( + min => join(' ', @min_modules), +); + +my %configs = ( + all => { + 'apache-1.3' => [], + 'httpd-2.0' => enable20(qw(modules=all proxy)), + }, + most => { + 'apache-1.3' => [], + 'httpd-2.0' => enable20(qw(modules=most)), + }, + min => { + 'apache-1.3' => [], + 'httpd-2.0' => enable20(@min_modules), + }, + exp => { + 'apache-1.3' => [], + 'httpd-2.0' => enable20(qw(example case_filter + case_filter_in cache + echo deflate bucketeer)), + }, +); + +my %builds = ( + default => { + cflags => '-Wall', + config => { + 'apache-1.3' => [], + 'httpd-2.0' => [], + }, + }, + debug => { + cflags => '-g', + config => { + 'apache-1.3' => [], + 'httpd-2.0' => [qw(--enable-maintainer-mode)], + }, + }, + prof => { + cflags => '-pg -DGPROF', + }, + shared => { + config => { + 'apache-1.3' => [], + 'httpd-2.0' => enable20_shared('all'), + }, + }, + mostshared => { + config => { + 'apache-1.3' => [], + 'httpd-2.0' => enable20_shared('most'), + }, + }, + minshared => { + config => { + 'apache-1.3' => [], + 'httpd-2.0' => enable20_shared('min'), + }, + }, + static => { + }, +); + +my %mpms = ( + default => [qw(prefork worker)], + MSWin32 => [qw(winnt)], +); + +my @cvs = qw(httpd-2.0 apache-1.3); + +my @dirs = qw(build tar src install); + +sub enable20 { + [ map { "--enable-$_" } @_ ]; +} + +sub enable20_shared { + my $name = shift; + my $modules = $shared_modules{$name} || $name; + enable20(qq(mods-shared="$modules")); +} + +sub default_mpms { + $mpms{ $^O } || $mpms{'default'}; +} + +sub default_dir { + my($self, $dir) = @_; + $self->{$dir} ||= catdir $self->{prefix}, $dir, +} + +sub new { + my $class = shift; + + #XXX: not generating a BUILD script yet + #this way we can run: + #perl Apache-Test/lib/Apache/TestBuild.pm --cvsroot=anon --foo=... + + require Apache::TestConfig; + require Apache::TestTrace; + Apache::TestTrace->import; + + my $self = bless { + prefix => '/usr/local/apache', + cwd => Cwd::cwd(), + cvsroot => 'cvs.apache.org:/home/cvs', + cvs => \@cvs, + cvstag => "", + ssldir => "", + mpms => default_mpms(), + make => $Config{make}, + builds => {}, + name => "", + extra_config => { + 'httpd-2.0' => [], + }, + @_, + }, $class; + + #XXX + if (my $c = $self->{extra_config}->{'2.0'}) { + $self->{extra_config}->{'httpd-2.0'} = $c; + } + + for my $dir (@dirs) { + $self->default_dir($dir); + } + + if ($self->{ssldir}) { + push @{ $self->{extra_config}->{'httpd-2.0'} }, + '--enable-ssl', "--with-ssl=$self->{ssldir}"; + } + + $self; +} + +sub init { + my $self = shift; + + for my $dir (@dirs) { + mkpath($self->{$dir}); + } +} + +use subs qw(symlink unlink); +use File::Basename; +use File::Find; + +sub symlink_tree { + my $self = shift; + + my $httpd = 'httpd'; + my $install = "$self->{install}/bin/$httpd"; + my $source = "$self->{build}/.libs/$httpd"; + + unlink $install; + symlink $source, $install; + + my %dir = (apr => 'apr', + aprutil => 'apr-util'); + + for my $libname (qw(apr aprutil)) { + my $lib = "lib$libname.so.0.0.0"; + my $install = "$self->{install}/lib/$lib"; + my $source = "$self->{build}/srclib/$dir{$libname}/.libs/$lib"; + + unlink $install; + symlink $source, $install; + } + + $install = "$self->{install}/modules"; + $source = "$self->{build}/modules"; + + for (<$install/*.so>) { + unlink $_; + } + + finddepth(sub { + return unless /\.so$/; + my $file = "$File::Find::dir/$_"; + symlink $file, "$install/$_"; + }, $source); +} + +sub unlink { + my $file = shift; + + if (-e $file) { + print "unlink $file\n"; + } + else { + print "$file does not exist\n"; + } + CORE::unlink($file); +} + +sub symlink { + my($from, $to) = @_; + print "symlink $from => $to\n"; + unless (-e $from) { + print "source $from does not exist\n"; + } + my $base = dirname $to; + unless (-e $base) { + print "target dir $base does not exist\n"; + } + CORE::symlink($from, $to) or die $!; +} + +sub cvs { + my $self = shift; + + my $cmd = "cvs -d $self->{cvsroot} @_"; + + if (DRYRUN) { + info "$cmd"; + } + else { + system $cmd; + } +} + +my %cvs_names = ( + '2.0' => 'httpd-2.0', + '1.3' => 'apache-1.3', +); + +my %cvs_snames = ( + '2.0' => 'httpd', + '1.3' => 'apache', +); + +sub cvs_up { + my($self, $version) = @_; + + my $name = $cvs_names{$version}; + + my $dir = $self->srcdir($version); + + if ($self->{cvsroot} eq 'anon') { + $self->{cvsroot} = ':pserver:anoncvs@cvs.apache.org:/home/cvspublic'; + unless (-d $dir) { + #XXX do something better than doesn't require prompt if + #we already have an entry in ~/.cvspass + #$self->cvs('login'); + + warning "may need to run the following command ", + "(password is 'anoncvs')"; + warning "cvs -d $self->{cvsroot} login"; + } + } + + if (-d $dir) { + chdir $dir; + $self->cvs(up => "-dP $self->{cvstag}"); + return; + } + + my $co = checkout($name); + $self->$co($name, $dir); + + my $post = post_checkout($name); + $self->$post($name, $dir); +} + +sub checkout_httpd_2_0 { + my($self, $name, $dir) = @_; + + my $tag = $self->{cvstag}; + + $self->cvs(co => "-d $dir $tag $name"); + chdir "$dir/srclib"; + $self->cvs(co => "$tag apr apr-util"); +} + +sub checkout_apache_1_3 { + my($self, $name, $dir) = @_; + + $self->cvs(co => "-d $dir $self->{cvstag} $name"); +} + +sub post_checkout_httpd_2_0 { + my($self, $name, $dir) = @_; +} + +sub post_checkout_apache_1_3 { +} + +sub canon { + my $name = shift; + return $name unless $name; + $name =~ s/[.-]/_/g; + $name; +} + +sub checkout { + my $name = canon(shift); + \&{"checkout_$name"}; +} + +sub post_checkout { + my $name = canon(shift); + \&{"post_checkout_$name"}; +} + +sub cvs_update { + my $self = shift; + + my $cvs = shift || $self->{cvs}; + + chdir $self->{src}; + + for my $name (@$cvs) { + $self->cvs_up($name); + } +} + +sub merge_build { + my($self, $version, $builds, $configs) = @_; + + my $b = { + cflags => $builds{default}->{cflags}, + config => [ @{ $builds{default}->{config}->{$version} } ], + }; + + for my $name (@$builds) { + next if $name eq 'default'; #already have this + + if (my $flags = $builds{$name}->{cflags}) { + $b->{cflags} .= " $flags"; + } + if (my $cfg = $builds{$name}->{config}) { + if (my $vcfg = $cfg->{$version}) { + push @{ $b->{config} }, @$vcfg; + } + } + } + + for my $name (@$configs) { + my $cfg = $configs{$name}->{$version}; + next unless $cfg; + push @{ $b->{config} }, @$cfg; + } + + if (my $ex = $self->{extra_config}->{$version}) { + push @{ $b->{config} }, @$ex; + } + + if (my $ex = $self->{extra_cflags}->{$version}) { + $b->{config} .= " $ex"; + } + + $b; +} + +my @srclib_dirs = qw( + apr apr-util apr-util/xml/expat pcre +); + +sub install_name { + my($self, $builds, $configs, $mpm) = @_; + + return $self->{name} if $self->{name}; + + my $name = join '-', $mpm, @$builds, @$configs; + + if (my $tag = $self->cvs_name) { + $name .= "-$tag"; + } + + $name; +} + +#currently the httpd-2.0 build does not properly support static linking +#of ssl libs, force the issue +sub add_ssl_libs { + my $self = shift; + + my $ssldir = $self->{ssldir}; + + return unless $ssldir and -d $ssldir; + + my $name = $self->{current_install_name}; + + my $ssl_mod = "$name/modules/ssl"; + info "editing $ssl_mod/modules.mk"; + + if (DRYRUN) { + return; + } + + my $ssl_mk = "$self->{build}/$ssl_mod/modules.mk"; + + open my $fh, $ssl_mk or die "open $ssl_mk: $!"; + my @lines = <$fh>; + close $fh; + + for (@lines) { + next unless /SH_LINK/; + chomp; + $_ .= " -L$ssldir -lssl -lcrypto\n"; + info 'added ssl libs'; + last; + } + + open $fh, '>', $ssl_mk or die $!; + print $fh join "\n", @lines; + close $fh; +} + +sub cvs_name { + my $self = shift; + + if (my $tag = $self->{cvstag}) { + $tag =~ s/^-[DAr]//; + $tag =~ s/\"//g; + $tag =~ s,[/ :],_,g; #-D"03/29/02 07:00pm" + return $tag; + } + + return ""; +} + +sub srcdir { + my($self, $src) = @_; + + my $prefix = ""; + if ($src =~ s/^(apache|httpd)-//) { + $prefix = $1; + } + else { + $prefix = $cvs_snames{$src}; + } + + if ($src =~ /^\d\.\d$/) { + #release version will be \d\.\d\.\d+ + if (my $tag = $self->cvs_name) { + $src .= "-$tag"; + } + $src .= '-cvs'; + } + + join '-', $prefix, $src; +} + +sub configure_httpd_2_0 { + my($self, $src, $builds, $configs, $mpm) = @_; + + $src = $self->srcdir($src); + + chdir $self->{build}; + + my $name = $self->install_name($builds, $configs, $mpm); + + $self->{current_install_name} = $name; + + $self->{builds}->{$name} = 1; + + if ($self->{fresh}) { + rmtree($name); + } + else { + if (-e "$name/.DONE") { + warning "$name already configured"; + warning "rm $name/.DONE to force"; + return; + } + } + + my $build = $self->merge_build('httpd-2.0', $builds, $configs); + + $ENV{CFLAGS} = $build->{cflags}; + info "CFLAGS=$ENV{CFLAGS}"; + + my $prefix = "$self->{install}/$name"; + + rmtree($prefix) if $self->{fresh}; + + my $source = "$self->{src}/$src"; + + my @args = ("--prefix=$prefix", + "--with-mpm=$mpm", + "--srcdir=$source", + @{ $build->{config} }); + + chdir $source; + system "./buildconf"; + + my $cmd = "$source/configure @args"; + + chdir $self->{build}; + + mkpath($name); + chdir $name; + + for my $dir (@srclib_dirs) { + mkpath("srclib/$dir"); + } + + for my $dir (qw(build docs/conf)) { + mkpath($dir); + } + + system $cmd; + + open FH, ">.DONE" or die "open .DONE: $!"; + print FH scalar localtime; + close FH; + + chdir $self->{prefix}; + + $self->add_ssl_libs; +} + +sub make { + my($self, @cmds) = @_; + + push @cmds, 'all' unless @cmds; + + for my $name (keys %{ $self->{builds} }) { + chdir "$self->{build}/$name"; + for my $cmd (@cmds) { + system "$self->{make} $cmd"; + } + } +} + +sub system { + my $cmd = "@_"; + + info $cmd; + return if DRYRUN; + + unless (CORE::system($cmd) == 0) { + my $status = $? >> 8; + die "system $cmd failed (exit status=$status)"; + } +} + +sub chdir { + my $dir = shift; + info "chdir $dir"; + CORE::chdir $dir; +} + +sub mkpath { + my $dir = shift; + + return if -d $dir; + info "mkpath $dir"; + + return if DRYRUN; + File::Path::mkpath([$dir], 1, 0755); +} + +sub rmtree { + my $dir = shift; + + return unless -d $dir; + info "rmtree $dir"; + + return if DRYRUN; + File::Path::rmtree([$dir], 1, 1); +} + +sub generate_script { + my($class, $file) = @_; + + $file ||= catfile 't', 'BUILD'; + + my $content = join '', <DATA>; + + Apache::Test::basic_config()->write_perlscript($file, $content); +} + +unless (caller) { + $INC{'Apache/TestBuild.pm'} = __FILE__; + eval join '', <DATA>; + die $@ if $@; +} + +1; +__DATA__ +use strict; +use warnings FATAL => 'all'; + +use lib qw(Apache-Test/lib); +use Apache::TestBuild (); +use Getopt::Long qw(GetOptions); +use Cwd (); + +my %options = ( + prefix => "checkout/build/install prefix", + ssldir => "enable ssl with given directory", + cvstag => "checkout with given cvs tag", + cvsroot => "use 'anon' for anonymous cvs", + version => "apache version (e.g. '2.0')", + mpms => "MPMs to build (e.g. 'prefork')", + flavor => "build flavor (e.g. 'debug shared')", + modules => "enable modules (e.g. 'all exp')", + name => "change name of the build/install directory", +); + +my %opts; + +Getopt::Long::Configure(qw(pass_through)); +#XXX: could be smarter here, being lazy for the moment +GetOptions(\%opts, map "$_=s", sort keys %options); + +if (@ARGV) { + print "passing extra args to configure: @ARGV\n"; +} + +my $home = $ENV{HOME}; + +$opts{prefix} ||= join '/', Cwd::cwd(), 'farm'; +#$opts{ssldir} ||= ''; +#$opts{cvstag} ||= ''; +#$opts{cvsroot} ||= ''; +$opts{version} ||= '2.0'; +$opts{mpms} ||= 'prefork'; +$opts{flavor} ||= 'debug-shared'; +$opts{modules} ||= 'all-exp'; + +#my @versions = qw(2.0); + +#my @mpms = qw(prefork worker perchild); + +#my @flavors = ([qw(debug shared)], [qw(prof shared)], +# [qw(debug static)], [qw(prof static)]); + +#my @modules = ([qw(all exp)]); + +my $split = sub { split '-', delete $opts{ $_[0] } }; + +my @versions = $opts{version}; + +my @mpms = $split->('mpms'); + +my @flavors = ([ $split->('flavor') ]); + +my @modules = ([ $split->('modules') ]); + +my $tb = Apache::TestBuild->new(fresh => 1, + %opts, + extra_config => { + $opts{version} => \@ARGV, + }); + +$tb->init; + +for my $version (@versions) { + $tb->cvs_update([ $version ]); + + for my $mpm (@mpms) { + for my $flavor (@flavors) { + for my $mods (@modules) { + $tb->configure_httpd_2_0($version, $flavor, + $mods, $mpm); + $tb->make(qw(all install)); + } + } + } +} diff --git a/debian/perl-framework/Apache-Test/lib/Apache/TestClient.pm b/debian/perl-framework/Apache-Test/lib/Apache/TestClient.pm new file mode 100644 index 0000000..bd2d328 --- /dev/null +++ b/debian/perl-framework/Apache-Test/lib/Apache/TestClient.pm @@ -0,0 +1,203 @@ +# 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::TestClient; + +#this module provides some fallback for when libwww-perl is not installed +#it is by no means an LWP replacement, just enough for very simple requests + +#this module does not and will never support certain features such as: +#file upload, http/1.1 (byteranges, keepalive, etc.), following redirects, +#authentication, GET body callbacks, SSL, etc. + +use strict; +use warnings FATAL => 'all'; + +use Apache::TestRequest (); + +my $CRLF = "\015\012"; + +sub request { + my($method, $url, @headers) = @_; + + my @real_headers = (); + my $content; + + for (my $i = 0; $i < scalar @headers; $i += 2) { + if ($headers[$i] =~ /^content$/i) { + $content = $headers[$i+1]; + } + else { + push @real_headers, ($headers[$i], $headers[$i+1]); + } + } + + ## XXX: + ## This is not a FULL URL encode mapping + ## space ' '; however is very common, so this + ## is useful to convert + $url =~ s/ /%20/g; + + my $config = Apache::Test::config(); + + $method ||= 'GET'; + $url ||= '/'; + my %headers = (); + + my $hostport = Apache::TestRequest::hostport($config); + $headers{Host} = (split ':', $hostport)[0]; + + my $s = Apache::TestRequest::vhost_socket(); + + unless ($s) { + warn "cannot connect to $hostport: $!"; + return undef; + } + + if ($content) { + $headers{'Content-Length'} ||= length $content; + $headers{'Content-Type'} ||= 'application/x-www-form-urlencoded'; + } + + #for modules/setenvif + $headers{'User-Agent'} ||= 'libwww-perl/0.00'; + + my $request = join $CRLF, + "$method $url HTTP/1.0", + (map { "$_: $headers{$_}" } keys %headers); + + $request .= $CRLF; + + for (my $i = 0; $i < scalar @real_headers; $i += 2) { + $request .= "$real_headers[$i]: $real_headers[$i+1]$CRLF"; + } + + $request .= $CRLF; + + # using send() avoids the need to use SIGPIPE if the server aborts + # the connection + $s->send($request); + $s->send($content) if $content; + + $request =~ s/\015//g; #for as_string + + my $res = { + request => (bless { + headers_as_string => $request, + content => $content || '', + }, 'Apache::TestClientRequest'), + headers_as_string => '', + method => $method, + code => -1, # unknown + }; + + my($response_line, $header_term); + my $eol = "\015?\012"; + + local $_; + + while (<$s>) { + $res->{headers_as_string} .= $_; + if (m:^(HTTP/\d+\.\d+)[ \t]+(\d+)[ \t]*(.*?)$eol:io) { + $res->{protocol} = $1; + $res->{code} = $2; + $res->{message} = $3; + $response_line = 1; + } + elsif (/^([a-zA-Z0-9_\-]+)\s*:\s*(.*?)$eol/o) { + $res->{headers}->{lc $1} = $2; + } + elsif (/^$eol$/o) { + $header_term = 1; + last; + } + } + + unless ($response_line and $header_term) { + warn "malformed response"; + } + + { + local $/; + $res->{content} = <$s>; + } + close $s; + + # an empty body is a valid response + $res->{content} = '' + unless exists $res->{content} and defined $res->{content}; + + $res->{headers_as_string} =~ s/\015//g; #for as_string + + bless $res, 'Apache::TestClientResponse'; +} + +for my $method (qw(GET HEAD POST PUT)) { + no strict 'refs'; + *$method = sub { + my $url = shift; + request($method, $url, @_); + }; +} + +package Apache::TestClientResponse; + +sub header { + my($self, $key) = @_; + $self->{headers}->{lc $key}; +} + +my @headers = qw(Last-Modified Content-Type); + +for my $header (@headers) { + no strict 'refs'; + (my $method = lc $header) =~ s/-/_/g; + *$method = sub { shift->{headers}->{lc $header} }; +} + +sub is_success { + my $code = shift->{code}; + return 0 unless defined $code && $code; + $code >= 200 && $code < 300; +} + +sub status_line { + my $self = shift; + "$self->{code} $self->{message}"; +} + +sub as_string { + my $self = shift; + $self->{headers_as_string} . ($self->{content} || ''); +} + +my @methods = qw( +request protocol code message method +headers_as_string headers content +); + +for my $method (@methods) { + no strict 'refs'; + *$method = sub { + my($self, $val) = @_; + $self->{$method} = $val if $val; + $self->{$method}; + }; +} + +#inherit headers_as_string, as_string, protocol, content, etc. methods +@Apache::TestClientRequest::ISA = qw(Apache::TestClientResponse); + +1; diff --git a/debian/perl-framework/Apache-Test/lib/Apache/TestCommon.pm b/debian/perl-framework/Apache-Test/lib/Apache/TestCommon.pm new file mode 100644 index 0000000..e65d1d3 --- /dev/null +++ b/debian/perl-framework/Apache-Test/lib/Apache/TestCommon.pm @@ -0,0 +1,109 @@ +# 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::TestCommon; + +use strict; +use warnings FATAL => 'all'; + +use File::Basename; + +use Apache::Test; +use Apache::TestRequest; +use Apache::TestUtil; +use Apache::TestCommonPost (); + +#this module contains common tests that are called from different .t files + +#t/apache/passbrigade.t +#t/apache/rwrite.t + +sub run_write_test { + my $module = shift; + + #1k..9k, 10k..50k, 100k, 300k, 500k, 2Mb, 4Mb, 6Mb, 10Mb + my @sizes = (1..9, 10..50, 100, 300, 500, 2000, 4000, 6000, 10_000); + my @buff_sizes = (1024, 8192); + + plan tests => @sizes * @buff_sizes, [$module, 'LWP']; + + my $location = "/$module"; + my $ua = Apache::TestRequest::user_agent(); + + for my $buff_size (@buff_sizes) { + for my $size (@sizes) { + my $length = $size * 1024; + my $received = 0; + + $ua->do_request(GET => "$location?$buff_size,$length", + sub { + my($chunk, $res) = @_; + $received += length $chunk; + }); + + ok t_cmp($length, $received, 'bytes in body'); + } + } +} + +sub run_files_test { + my($verify, $skip_other) = @_; + + my $vars = Apache::Test::vars(); + my $perlpod = $vars->{perlpod}; + + my %pod = ( + files => [], + num => 0, + url => '/getfiles-perl-pod', + dir => "", + ); + + if (-d $perlpod) { + my @files = map { basename $_ } <$perlpod/*.pod>; + $pod{files} = \@files; + $pod{num} = scalar @files; + $pod{dir} = $perlpod; + } + else { + push @Apache::Test::SkipReasons, + "dir $vars->{perlpod} does not exist"; + } + + my %other_files = (); + + unless ($skip_other) { #allow to skip the large binary files + %other_files = map { + ("/getfiles-binary-$_", $vars->{$_}) + } qw(httpd perl); + } + + my $tests = $pod{num} + keys(%other_files); + + plan tests => $tests, sub { $pod{num} and have_lwp() }; + + my $ua = Apache::TestRequest::user_agent(); + + for my $file (@{ $pod{files} }) { + $verify->($ua, "$pod{url}/$file", "$pod{dir}/$file"); + } + + for my $url (sort keys %other_files) { + $verify->($ua, $url, $other_files{$url}); + } +} + +1; +__END__ diff --git a/debian/perl-framework/Apache-Test/lib/Apache/TestCommonPost.pm b/debian/perl-framework/Apache-Test/lib/Apache/TestCommonPost.pm new file mode 100644 index 0000000..dda2b31 --- /dev/null +++ b/debian/perl-framework/Apache-Test/lib/Apache/TestCommonPost.pm @@ -0,0 +1,199 @@ +# 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::TestCommonPost; + +use strict; +use warnings FATAL => 'all'; + +use constant POST_HUGE => $ENV{APACHE_TEST_POST_HUGE} || 0; + +use Apache::TestRequest (); +use Apache::TestUtil qw(t_cmp t_debug); +use Apache::Test qw(sok); + +BEGIN { + my $use_inline = 0; + + eval { + #if Inline.pm and libcurl are available + #we can make this test about 3x faster, + #after the inlined code is compiled that is. + require Inline; + Inline->import(C => 'DATA', LIBS => ['-lcurl'], + #CLEAN_AFTER_BUILD => 0, + PREFIX => 'aptest_post_'); + *request_init = \&curl_init; + *request_do = \&curl_do; + $use_inline = 1; + } if POST_HUGE; + + if (POST_HUGE) { + if ($@) { + t_debug "tests will run faster with Inline and curl installed"; + print $@; + } + else { + t_debug "using Inline and curl client"; + } + } + + unless ($use_inline) { + t_debug "using LWP client"; + #fallback to lwp + *request_init = \&lwp_init; + *request_do = \&lwp_do; + } +} + +sub lwp_init { + use vars qw($UA $Location); + $UA = Apache::TestRequest::user_agent(); + $Location = shift; +} + +sub lwp_do { + my $length = shift; + + my $request = HTTP::Request->new(POST => $Location); + $request->header('Content-length' => $length); + + if (LWP->VERSION >= 5.800) { + $request->content_ref(\('a' x $length)); + } else { + # before LWP 5.800 there was no way to tell HTTP::Message not + # to copy the string, there is a settable content_ref since + # 5.800 + use constant BUF_SIZE => 8192; + + my $remain = $length; + my $content = sub { + my $bytes = $remain < BUF_SIZE ? $remain : BUF_SIZE; + my $buf = 'a' x $bytes; + $remain -= $bytes; + $buf; + }; + + $request->content($content); + } + + + + my $response = $UA->request($request); + + Apache::TestRequest::lwp_trace($response); + + return $response->content; +} + +my @run_post_test_small_sizes = + #1k..9k, 10k..50k, 100k + (1..9, 10..50, 100); + +my @run_post_test_sizes = @run_post_test_small_sizes; + +if (POST_HUGE) { + push @run_post_test_sizes, + #300k, 500k, 2Mb, 4Mb, 6Mb, 10Mb + 300, 500, 2000, 4000, 6000, 10_000; +} + +sub Apache::TestCommon::run_post_test_sizes { @run_post_test_sizes } + +sub Apache::TestCommon::run_post_test { + my $module = shift; + my $sizes = shift || \@run_post_test_sizes; + + my $location = Apache::TestRequest::resolve_url("/$module"); + + request_init($location); + + for my $size (@$sizes) { + sok { + my $length = ($size * 1024); + + my $str = request_do($length); + chomp $str; + + t_cmp($length, $str, "length posted"); + }; + } +} + +1; +__DATA__ + +__C__ + +#include <curl/curl.h> +#include <curl/easy.h> + +static CURL *curl = NULL; +static SV *response = (SV *)NULL; +static long total = 0; + +static size_t my_curl_read(char *buffer, size_t size, + size_t nitems, void *data) +{ + size_t bytes = nitems < total ? nitems : total; + memset(buffer, 'a', bytes); + total -= bytes; + return bytes; +} + +static size_t my_curl_write(char *buffer, size_t size, + size_t nitems, void *data) +{ + sv_catpvn(response, buffer, nitems); + return nitems; +} + +void aptest_post_curl_init(char *url) +{ + char *proto = "HTTP/1.1"; /* curl default */ + curl = curl_easy_init(); + curl_easy_setopt(curl, CURLOPT_MUTE, 1); + curl_easy_setopt(curl, CURLOPT_URL, url); + curl_easy_setopt(curl, CURLOPT_CUSTOMREQUEST, "POST"); + curl_easy_setopt(curl, CURLOPT_UPLOAD, 1); + curl_easy_setopt(curl, CURLOPT_READFUNCTION, my_curl_read); + curl_easy_setopt(curl, CURLOPT_WRITEFUNCTION, my_curl_write); + if (!getenv("APACHE_TEST_HTTP11")) { + curl_easy_setopt(curl, CURLOPT_HTTP_VERSION, CURL_HTTP_VERSION_1_0); + proto = "HTTP/1.0"; + } + fprintf(stdout, "#CURL using protocol %s\n", proto); + fflush(stdout); + response = newSV(0); +} + +SV *aptest_post_curl_do(long len) +{ + sv_setpv(response, ""); + total = len; + curl_easy_setopt(curl, CURLOPT_INFILESIZE, len); + curl_easy_perform(curl); + return SvREFCNT_inc(response); +} + +void aptest_post_END(void) +{ + if (response) { + SvREFCNT_dec(response); + } + if (curl) { + curl_easy_cleanup(curl); + } +} diff --git a/debian/perl-framework/Apache-Test/lib/Apache/TestConfig.pm b/debian/perl-framework/Apache-Test/lib/Apache/TestConfig.pm new file mode 100644 index 0000000..85689b0 --- /dev/null +++ b/debian/perl-framework/Apache-Test/lib/Apache/TestConfig.pm @@ -0,0 +1,2299 @@ +# 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)', + 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->{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 .= "</$directive>\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 { "<?php /* \n@_ \n*/ ?>" }, + 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" + : <<EOI; +$Config{'startperl'} + eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' + if \$running_under_some_shell; +EOI + + return $shebang; +} + +sub cpfile { + my($self, $from, $to) = @_; + File::Copy::copy($from, $to); + $self->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*)<VirtualHost\s+(?:_default_:|([^:]+):(?!:))?(.*?)\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 <IfModule $have_module> + 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 <VirtualHost ...> + 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 <VirtualHost ...> + @out_config = ([Listen => '0.0.0.0:' . $port]); + + if ($self->{vhosts}->{$module}->{namebased}) { + push @out_config => ["<IfVersion < 2.3.11>\n". + "${indent}${indent}NameVirtualHost" + => "*:$port\n${indent}</IfVersion>"]; + } + } + + $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<VirtualHost " . ($namebased ? '*' : '_default_') . + ":$port>", + }; +} + +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 <<EOF; +text/html html htm +image/gif gif +image/jpeg jpeg jpg jpe +image/png png +text/plain asc txt +EOF +} + +sub generate_types_config { + my $self = shift; + + # handle the case when mod_mime is built as a shared object + # but wasn't included in the system-wide httpd.conf + $self->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(<<EOI); +<IfModule mod_mime.c> + TypesConfig "$types" +</IfModule> +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(<IfModule mod_perl.c>\n PerlRequire "$file"\n</IfModule>\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 "<IfModule mod_alias.c>\n"; + for (sort keys %aliases) { + next unless $vars->{$aliases{$_}}; + print $out " Alias /getfiles-$_ $vars->{$aliases{$_}}\n"; + } + print $out "</IfModule>\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; + + 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 <<EOF; +package $name; + +sub new { +$obj; +} + +1; +EOF + + close $fh or die "failed to write $file: $!"; +} + +sub as_string { + my $cfg = ''; + my $command = ''; + + # httpd opts + my $test_config = Apache::TestConfig->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<Apache::TestConfig> is used in creating the C<Apache::Test> +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<lt>!-- --E<gt>>, 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<Apache::Test> framework: + +=head2 APACHE_TEST_COLOR + +To aid visual control over the configuration process and the run-time +phase, C<Apache::Test> uses coloured fonts when the environment +variable C<APACHE_TEST_COLOR> is set to a true value. + +=head2 APACHE_TEST_LIVE_DEV + +When using C<Apache::Test> during the project development phase, it's +often convenient to have the I<project/lib> (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<make> to +update I<blib/lib>. When the environment variable +C<APACHE_TEST_LIVE_DEV> is set to a true value during the +configuration phase (C<t/TEST -config>, C<Apache::Test> will +automatically unshift the I<project/lib> directory into C<@INC>, via +the autogenerated I<t/conf/modperl_inc.pl> 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<extra.conf.in> you can +write: + + Include @ServerRoot@/conf/myconfig.conf + +When I<extra.conf> 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<t/TEST>, such as +C<MaxClients>, C<DocumentRoot>, C<ServerRoot>, etc. To see the +complete list run: + + % t/TEST --help + +and you will find them in the C<configuration options> 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 + +<IfModule mod_version.c> +<IfVersion > 2.4.1> + DefaultRunTimeDir "@t_logs@" + LogLevel trace8 +</IfVersion> +<IfVersion > 2.4.34> +<IfDirective DefaultStateDir> + DefaultStateDir "@t_state@" +</IfDirective> +</IfVersion> +</IfModule> + +<IfModule mod_log_config.c> + TransferLog @t_logs@/access_log +</IfModule> + +<IfModule mod_cgid.c> + ScriptSock @t_logs@/cgisock +</IfModule> + +ServerAdmin @ServerAdmin@ + +#needed for http/1.1 testing +KeepAlive On + +HostnameLookups Off + +<Directory /> + Options FollowSymLinks + AllowOverride None +</Directory> + +<IfModule @THREAD_MODULE@> +<IfModule mod_version.c> +<IfVersion < 2.3.4> + LockFile @t_logs@/accept.lock +</IfVersion> +</IfModule> + StartServers @StartServersThreadedMPM@ + MinSpareThreads @ThreadsPerChild@ + MaxSpareThreads @MaxSpareThreadedMPM@ + ThreadsPerChild @ThreadsPerChild@ + MaxClients @MaxClientsThreadedMPM@ + MaxRequestsPerChild 0 +</IfModule> + +<IfModule perchild.c> +<IfModule mod_version.c> +<IfVersion < 2.3.4> + LockFile @t_logs@/accept.lock +</IfVersion> +</IfModule> + NumServers 1 + StartThreads @MinClients@ + MinSpareThreads 1 + MaxSpareThreads @MaxSpare@ + MaxThreadsPerChild @MaxClients@ + MaxRequestsPerChild 0 +</IfModule> + +<IfModule prefork.c> +<IfModule mod_version.c> +<IfVersion < 2.3.4> + LockFile @t_logs@/accept.lock +</IfVersion> +</IfModule> + StartServers @MinClients@ + MinSpareServers 1 + MaxSpareServers @MaxSpare@ + MaxClients @MaxClients@ + MaxRequestsPerChild 0 +</IfModule> + +<IfDefine APACHE1> + LockFile @t_logs@/accept.lock + StartServers @MinClients@ + MinSpareServers 1 + MaxSpareServers @MaxSpare@ + MaxClients @MaxClients@ + MaxRequestsPerChild 0 +</IfDefine> + +<IfModule mpm_winnt.c> + ThreadsPerChild 50 + MaxRequestsPerChild 0 +</IfModule> + +<Location /server-info> + SetHandler server-info +</Location> + +<Location /server-status> + SetHandler server-status +</Location> + diff --git a/debian/perl-framework/Apache-Test/lib/Apache/TestConfigC.pm b/debian/perl-framework/Apache-Test/lib/Apache/TestConfigC.pm new file mode 100644 index 0000000..c9d8fd1 --- /dev/null +++ b/debian/perl-framework/Apache-Test/lib/Apache/TestConfigC.pm @@ -0,0 +1,492 @@ +# 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 TestConfigC on purpose + +use strict; +use warnings FATAL => 'all'; + +use Config; +use Apache::TestConfig (); +use Apache::TestConfigPerl (); +use Apache::TestTrace; +use File::Find qw(finddepth); + +sub cmodule_find { + my($self, $mod) = @_; + + return unless $mod =~ /^mod_(\w+)\.c$/; + my $sym = $1; + + my $dir = $File::Find::dir; + my $file = catfile $dir, $mod; + + unless ($self->{APXS}) { + $self->{cmodules_disabled}->{$mod} = "no apxs configured"; + return; + } + + my $fh = Symbol::gensym(); + open $fh, $file or die "open $file: $!"; + my $v = <$fh>; + if ($v =~ /^\#define\s+HTTPD_TEST_REQUIRE_APACHE\s+(\d+)\s*$/) { + #define HTTPD_TEST_REQUIRE_APACHE 1 + unless ($self->{server}->{rev} == $1) { + my $reason = "requires Apache version $1"; + $self->{cmodules_disabled}->{$mod} = $reason; + notice "$mod $reason, skipping."; + return; + } + } + elsif ($v =~ /^\#define\s+HTTPD_TEST_REQUIRE_APACHE\s+(\d\.\d+(\.\d+)?)/) { + #define HTTPD_TEST_REQUIRE_APACHE 2.1 + my $wanted = $1; + (my $current) = $self->{server}->{version} =~ m:^Apache/(\d\.\d+\.\d+):; + + if (Apache::Test::normalize_vstring($current) < + Apache::Test::normalize_vstring($wanted)) { + my $reason = "requires Apache version $wanted"; + $self->{cmodules_disabled}->{$mod} = $reason; + notice "$mod $reason, skipping."; + return; + } + } + close $fh; + + push @{ $self->{cmodules} }, { + name => "mod_$sym", + sym => "${sym}_module", + dir => $dir, + subdir => basename $dir, + }; +} + +sub cmodules_configure { + my($self, $dir) = @_; + + $self->{cmodules_disabled} = {}; #for have_module to check + + $dir ||= catfile $self->{vars}->{top_dir}, 'c-modules'; + + unless (-d $dir) { + return; + } + + $self->{cmodules_dir} = $dir; + + finddepth(sub { cmodule_find($self, $_) }, $dir); + + unless ($self->{APXS}) { + warning "cannot build c-modules without apxs"; + return; + } + + $self->cmodules_generate_include; + $self->cmodules_write_makefiles; + $self->cmodules_compile; + $self->cmodules_httpd_conf; +} + +sub cmodules_makefile_vars { + return <<EOF; +MAKE = $Config{make} +EOF +} + +my %lib_dir = Apache::TestConfig::WIN32 + ? (1 => "", 2 => "") + : (1 => "", 2 => ".libs/"); + +sub cmodules_build_so { + my($self, $name) = @_; + $name = "mod_$name" unless $name =~ /^mod_/; + my $libdir = $self->server->version_of(\%lib_dir); + my $lib = "$libdir$name.so"; +} + +sub cmodules_write_makefiles { + my $self = shift; + + my $modules = $self->{cmodules}; + + for (@$modules) { + $self->cmodules_write_makefile($_); + } + + my $file = catfile $self->{cmodules_dir}, 'Makefile'; + my $fh = $self->genfile($file); + + print $fh $self->cmodules_makefile_vars; + + my @dirs = map { $_->{subdir} } @$modules; + + my @targets = qw(clean); + my @libs; + + for my $dir (@dirs) { + for my $targ (@targets) { + print $fh "$dir-$targ:\n\tcd $dir && \$(MAKE) $targ\n\n"; + } + + my $lib = $self->cmodules_build_so($dir); + my $cfile = "$dir/mod_$dir.c"; + push @libs, "$dir/$lib"; + print $fh "$libs[-1]: $cfile\n\tcd $dir && \$(MAKE) $lib\n\n"; + } + + for my $targ (@targets) { + print $fh "$targ: ", (map { "$_-$targ " } @dirs), "\n\n"; + } + + print $fh "all: @libs\n\n"; + + close $fh or die "close $file: $!"; +} + +sub cmodules_write_makefile { + my ($self, $mod) = @_; + my $write = \&{"cmodules_write_makefile_$^O"}; + $write = \&cmodules_write_makefile_default unless defined &$write; + $write->($self, $mod); +} + +sub cmodules_write_makefile_default { + my($self, $mod) = @_; + + my $dversion = $self->server->dversion; + my $name = $mod->{name}; + my $makefile = catfile $mod->{dir}, 'Makefile'; + + my $extra = $ENV{EXTRA_CFLAGS} || ''; + + debug "writing $makefile"; + + my $lib = $self->cmodules_build_so($name); + + my $fh = $self->genfile($makefile); + + print $fh <<EOF; +APXS=$self->{APXS} +all: $lib + +$lib: $name.c + \$(APXS) $dversion $extra -I$self->{cmodules_dir} -c $name.c + +clean: + -rm -rf $name.o $name.lo $name.slo $name.la $name.i $name.s $name.gcno .libs +EOF + + close $fh or die "close $makefile: $!"; +} + +sub cmodules_write_makefile_aix { + my($self, $mod) = @_; + + my $dversion = $self->server->dversion; + my $name = $mod->{name}; + my $makefile = catfile $mod->{dir}, 'Makefile'; + my $apxsflags = ''; + + # + # Only do this for Apache 1.* + # + if ($self->server->{rev} == 1) { + $apxsflags = "-Wl,-bE:$name.exp"; + my $expfile = catfile $mod->{dir}, "$name.exp"; + if (! -f $expfile) { + my $fh = Symbol::gensym(); + $name =~ /^mod_(\w+)(?:\.c)?$/; + my $sym = $1 . '_module'; + open $fh, ">$expfile" or die "open $expfile: $!"; + print $fh "$sym\n"; + close $fh; + } + } + + my $extra = $ENV{EXTRA_CFLAGS} || ''; + + debug "writing $makefile"; + + my $lib = $self->cmodules_build_so($name); + + my $fh = Symbol::gensym(); + open $fh, ">$makefile" or die "open $makefile: $!"; + + print $fh <<EOF; +APXS=$self->{APXS} +APXSFLAGS=$apxsflags +all: $lib + +$lib: $name.c + \$(APXS) $dversion $extra -I$self->{cmodules_dir} \$(APXSFLAGS) -c $name.c + +clean: + -rm -rf $name.o $name.lo $name.slo $name.la .libs +EOF + + close $fh or die "close $makefile: $!"; +} + +sub cmodules_write_makefile_MSWin32 { + my($self, $mod) = @_; + + my $dversion = $self->server->dversion; + my $name = $mod->{name}; + my $makefile = "$mod->{dir}/Makefile"; + debug "writing $makefile"; + my $extras = ''; + + my $lib = $self->cmodules_build_so($name); + $extras = ' -llibhttpd -p ' if ($self->server->{rev} != 1); + my $goners = join ' ', (map {$name . '.' . $_} qw(exp lib so lo)); + + my $fh = Symbol::gensym(); + open $fh, ">$makefile" or die "open $makefile: $!"; + + my $extra = $ENV{EXTRA_CFLAGS} || ''; + + debug "writing $makefile"; + + print $fh <<EOF; +APXS=$self->{APXS} +all: $lib + +$lib: $name.c + \$(APXS) $dversion $extra -I$self->{cmodules_dir} $extras -c $name.c + +clean: + -erase $goners +EOF + + close $fh or die "close $makefile: $!"; +} + +sub cmodules_make { + my $self = shift; + my $targ = shift || 'all'; + + my $cmd = "cd $self->{cmodules_dir} && $Config{make} $targ"; + debug $cmd; + system $cmd; + if ($?) { + die "Failed to build c-modules"; + } +} + +sub cmodules_compile { + shift->cmodules_make('all'); +} + +sub cmodules_httpd_conf { + my $self = shift; + + my @args; + + for my $mod (@{ $self->{cmodules} }) { + my $dir = $mod->{dir}; + my $lib = $self->cmodules_build_so($mod->{name}); + my $so = "$dir/$lib"; + + next unless -e $so; + + $self->preamble(LoadModule => "$mod->{sym} $so"); + + my $cname = "$mod->{name}.c"; + my $cfile = "$dir/$cname"; + $self->{modules}->{$cname} = 1; + + $self->add_module_config($cfile, \@args); + } + + $self->postamble(\@args) if @args; +} + +sub cmodules_clean { + my $self = shift; + + my $dir = $self->{cmodules_dir}; + return unless $dir and -e "$dir/Makefile"; + + unless ($self->{clean_level} > 1) { + #skip t/TEST -conf + warning "skipping rebuild of c-modules; run t/TEST -clean to force"; + return; + } + + $self->cmodules_make('clean'); + + for my $mod (@{ $self->{cmodules} }) { + my $makefile = "$mod->{dir}/Makefile"; + debug "unlink $makefile"; + unlink $makefile; + } + + unlink "$dir/Makefile"; +} + +#try making it easier for test modules to compile with both 1.x and 2.x +sub cmodule_define_name { + my $name = shift; + $name eq 'NULL' ? $name : "APACHE_HTTPD_TEST_\U$name"; +} + +sub cmodule_define { + my $hook = cmodule_define_name(@_); + "#ifndef $hook\n#define $hook NULL\n#endif\n"; +} + +my @cmodule_config_names = qw(per_dir_create per_dir_merge + per_srv_create per_srv_merge + commands); + +my @cmodule_config_defines = map { + cmodule_define($_); +} @cmodule_config_names; + +my $cmodule_config_extra = + "#ifndef APACHE_HTTPD_TEST_EXTRA_HOOKS\n". + "#define APACHE_HTTPD_TEST_EXTRA_HOOKS(p) do { } while (0)\n". + "#endif\n"; + +my $cmodule_config_hooks = join ",\n ", map { + cmodule_define_name($_); +} @cmodule_config_names; + +my @cmodule_phases = qw(post_read_request translate_name header_parser + access_checker check_user_id auth_checker + type_checker fixups handler log_transaction + child_init); + +my $cmodule_hooks_1 = join ",\n ", map { + cmodule_define_name($_); +} qw(translate_name check_user_id auth_checker access_checker + type_checker fixups log_transaction header_parser + child_init NULL post_read_request); + +my $cmodule_template_1 = <<"EOF", +static const handler_rec name ## _handlers[] = +{ + {#name, APACHE_HTTPD_TEST_HANDLER}, /* ok if handler is NULL */ + {NULL} +}; + +module MODULE_VAR_EXPORT name ## _module = +{ + STANDARD_MODULE_STUFF, + NULL, /* initializer */ + $cmodule_config_hooks, + name ## _handlers, /* handlers */ + $cmodule_hooks_1 +} +EOF + +my @cmodule_hooks = map { + my $hook = cmodule_define_name($_); + <<EOF; + if ($hook != NULL) + ap_hook_$_($hook, + NULL, NULL, + APACHE_HTTPD_TEST_HOOK_ORDER); +EOF +} @cmodule_phases; + +my @cmodule_hook_defines = map { + cmodule_define($_); +} @cmodule_phases; + +my $cmodule_template_2 = <<"EOF"; +static void name ## _register_hooks(apr_pool_t *p) +{ +@cmodule_hooks + APACHE_HTTPD_TEST_EXTRA_HOOKS(p); +} + +module AP_MODULE_DECLARE_DATA name ## _module = { + STANDARD20_MODULE_STUFF, + $cmodule_config_hooks, + name ## _register_hooks, /* register hooks */ +} +EOF + +my %cmodule_templates = (1 => $cmodule_template_1, 2 => $cmodule_template_2); + +sub cmodules_module_template { + my $self = shift; + my $template = $self->server->version_of(\%cmodule_templates); + chomp $template; + + $template =~ s,$, \\,mg; + $template =~ s, \\$,,s; + + local $" = ', '; + + return <<EOF; +#define APACHE_HTTPD_TEST_MODULE(name) \\ + $template +EOF +} + +sub cmodules_generate_include { + my $self = shift; + + my $file = "$self->{cmodules_dir}/apache_httpd_test.h"; + my $fh = $self->genfile($file); + + while (read Apache::TestConfigC::DATA, my $buf, 1024) { + print $fh $buf; + } + + print $fh @cmodule_hook_defines, @cmodule_config_defines; + + print $fh $cmodule_config_extra; + + print $fh $self->cmodules_module_template; + + close $fh; +} + +package Apache::TestConfigC; #Apache/TestConfig.pm also has __DATA__ +1; +__DATA__ +#ifndef APACHE_HTTPD_TEST_H +#define APACHE_HTTPD_TEST_H + +/* headers present in both 1.x and 2.x */ +#include "httpd.h" +#include "http_config.h" +#include "http_protocol.h" +#include "http_request.h" +#include "http_log.h" +#include "http_main.h" +#include "http_core.h" +#include "ap_config.h" + +#ifdef APACHE1 +#define AP_METHOD_BIT 1 +typedef size_t apr_size_t; +typedef array_header apr_array_header_t; +#define APR_OFF_T_FMT "ld" +#define APR_SIZE_T_FMT "lu" +#endif /* APACHE1 */ + +#ifdef APACHE2 +#ifndef APACHE_HTTPD_TEST_HOOK_ORDER +#define APACHE_HTTPD_TEST_HOOK_ORDER APR_HOOK_MIDDLE +#endif +#include "ap_compat.h" +#endif /* APACHE2 */ + +#endif /* APACHE_HTTPD_TEST_H */ + diff --git a/debian/perl-framework/Apache-Test/lib/Apache/TestConfigPHP.pm b/debian/perl-framework/Apache-Test/lib/Apache/TestConfigPHP.pm new file mode 100644 index 0000000..1c79865 --- /dev/null +++ b/debian/perl-framework/Apache-Test/lib/Apache/TestConfigPHP.pm @@ -0,0 +1,781 @@ +# 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::TestConfigPHP; + +#things specific to php + +use strict; +use warnings FATAL => 'all'; +use File::Spec::Functions qw(catfile splitdir abs2rel); +use File::Find qw(finddepth); +use Apache::TestTrace; +use Apache::TestRequest; +use Apache::TestConfig; +use Apache::TestConfigPerl; +use Config; + +@Apache::TestConfigPHP::ISA = qw(Apache::TestConfig); + +my ($php_ini, $test_more); + +{ + # __DATA__ contains both php.ini and test-more.php + + local $/ = "END_OF_FILE\n"; + + $php_ini = <DATA>; + chomp $php_ini; + + $test_more = <DATA>; + chomp $test_more; +} + +sub new { + return shift->SUPER::new(@_); +} + +my %warn_style = ( + html => sub { "<!-- @_ -->" }, + c => sub { "/* @_ */" }, + ini => sub { join '', grep {s/^/; /gm} @_ }, + php => sub { join '', "<?php\n", grep {s/^/# /gm} @_ }, + default => sub { join '', grep {s/^/\# /gm} @_ }, +); + +my %file_ext = ( + map({$_ => 'html'} qw(htm html)), + map({$_ => 'c' } qw(c h)), + map({$_ => 'ini' } qw(ini)), + map({$_ => 'php' } qw(php)), +); + +sub warn_style_sub_ref { + my ($self, $filename) = @_; + my $ext = $self->filename_ext($filename); + return $warn_style{ $file_ext{$ext} || 'default' }; +} + +sub configure_php_tests_pick { + my($self, $entries) = @_; + + for my $subdir (qw(Response)) { + my $dir = catfile $self->{vars}->{t_dir}, lc $subdir; + next unless -d $dir; + + finddepth(sub { + return unless /\.php$/; + + 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); + } +} + +sub write_php_test { + my($self, $location, $test) = @_; + + (my $path = $location) =~ s/test//i; + (my $file = $test) =~ s/php$/t/i; + + my $dir = catfile $self->{vars}->{t_dir}, lc $path; + my $t = catfile $dir, $file; + my $php_t = catfile $dir, $test; + return if -e $t; + + # don't write out foo.t if foo.php already exists + return if -e $php_t; + + $self->gendir($dir); + my $fh = $self->genfile($t); + + print $fh <<EOF; +use Apache::TestRequest 'GET_BODY_ASSERT'; +print GET_BODY_ASSERT "/$location/$test"; +EOF + + close $fh or die "close $t: $!"; + + # write out an all.t file for the directory + # that will skip running all PHP test unless have_php + + my $all = catfile $dir, 'all.t'; + + unless (-e $all) { + my $fh = $self->genfile($all); + + print $fh <<EOF; +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; + +# skip all tests in this directory unless a php module is enabled +plan tests => 1, need_php; + +ok 1; +EOF + } +} + +sub configure_php_inc { + my $self = shift; + + my $serverroot = $self->{vars}->{serverroot}; + + my $path = catfile $serverroot, 'conf'; + + # make sure that require() or include() calls can find + # the generated test-more.php without using absolute paths + my $cfg = { php_value => "include_path $path", }; + $self->postamble(IfModule => $self->{vars}->{php_module}, $cfg); + + # give test-more.php access to the ServerRoot directive + $self->postamble("SetEnv SERVER_ROOT $serverroot\n"); +} + +sub configure_php_functions { + my $self = shift; + + my $dir = catfile $self->{vars}->{serverroot}, 'conf'; + my $file = catfile $dir, 'test-more.php'; + + $self->gendir($dir); + my $fh = $self->genfile($file); + + print $fh $test_more; + + close $fh or die "close $file: $!"; + + $self->clean_add_file($file); +} + +sub configure_php_ini { + my $self = shift; + + my $dir = catfile $self->{vars}->{serverroot}, 'conf'; + my $file = catfile $dir, 'php.ini'; + + return if -e $file; + + my $log = catfile $self->{vars}->{t_logs}, 'error_log'; + + $self->gendir($dir); + my $fh = $self->genfile($file); + + $php_ini =~ s/\@error_log\@/error_log $log/; + print $fh $php_ini; + + close $fh or die "close $file: $!"; + + $self->clean_add_file($file); +} + +sub configure_php_tests { + my $self = shift; + + my @entries = (); + $self->configure_php_tests_pick(\@entries); + $self->configure_pm_tests_sort(\@entries); + + my %seen = (); + + for my $entry (@entries) { + my ($file, $module, $subdir, $status) = @$entry; + + my @args = (); + + my $directives = $self->add_module_config($file, \@args); + + my @parts = splitdir $file; + my $test = pop @parts; + my $location = $parts[-1]; + + debug "configuring PHP test file $file"; + + if ($directives->{noautoconfig}) { + $self->postamble(""); # which adds "\n" + } + else { + unless ($seen{$location}++) { + $self->postamble(Alias => [ catfile('', $parts[-1]), catfile(@parts) ]); + + my @args = (AddType => 'application/x-httpd-php .php'); + + $self->postamble(Location => "/$location", \@args); + } + } + + $self->write_php_test($location, $test); + } +} + +1; + +__DATA__ +; This is php.ini-recommended from php 5.0.2, +; used in place of your locally installed php.ini file +; as part of the pristine environment Apache-Test creates +; for you +; [NOTE]: cat php.ini-recommended | grep -v '^;' | sed -e '/^$/d' +; +; exceptions to php.ini-recommended are as follows: +display_startup_errors = On +html_errors = Off +@error_log@ +output_buffering = Off + +; the rest of php.ini-recommended, unaltered, save for +; some tidying like the removal of comments and blank lines + +[PHP] +engine = On +zend.ze1_compatibility_mode = Off +short_open_tag = Off +asp_tags = Off +precision = 14 +y2k_compliance = On +zlib.output_compression = Off +implicit_flush = Off +unserialize_callback_func= +serialize_precision = 100 +allow_call_time_pass_reference = Off +safe_mode = Off +safe_mode_gid = Off +safe_mode_include_dir = +safe_mode_exec_dir = +safe_mode_allowed_env_vars = PHP_ +safe_mode_protected_env_vars = LD_LIBRARY_PATH +disable_functions = +disable_classes = +expose_php = On +max_execution_time = 30 ; Maximum execution time of each script, in seconds +max_input_time = 60 ; Maximum amount of time each script may spend parsing request data +memory_limit = 128M ; Maximum amount of memory a script may consume (128MB) +error_reporting = E_ALL +display_errors = Off +log_errors = On +log_errors_max_len = 1024 +ignore_repeated_errors = Off +ignore_repeated_source = Off +report_memleaks = On +track_errors = Off +variables_order = "GPCS" +register_globals = Off +register_long_arrays = Off +register_argc_argv = Off +auto_globals_jit = On +post_max_size = 8M +magic_quotes_gpc = Off +magic_quotes_runtime = Off +magic_quotes_sybase = Off +auto_prepend_file = +auto_append_file = +default_mimetype = "text/html" +doc_root = +user_dir = +enable_dl = On +file_uploads = On +upload_max_filesize = 2M +allow_url_fopen = On +allow_url_include = Off +default_socket_timeout = 60 +[Date] +[filter] +[iconv] +[sqlite] +[xmlrpc] +[Pcre] +[Syslog] +define_syslog_variables = Off +[mail function] +SMTP = localhost +smtp_port = 25 +[SQL] +sql.safe_mode = Off +[ODBC] +odbc.allow_persistent = On +odbc.check_persistent = On +odbc.max_persistent = -1 +odbc.max_links = -1 +odbc.defaultlrl = 4096 +odbc.defaultbinmode = 1 +[MySQL] +mysql.allow_persistent = On +mysql.max_persistent = -1 +mysql.max_links = -1 +mysql.default_port = +mysql.default_socket = +mysql.default_host = +mysql.default_user = +mysql.default_password = +mysql.connect_timeout = 60 +mysql.trace_mode = Off +[MySQLi] +mysqli.max_links = -1 +mysqli.default_port = 3306 +mysqli.default_socket = +mysqli.default_host = +mysqli.default_user = +mysqli.default_pw = +mysqli.reconnect = Off +[mSQL] +msql.allow_persistent = On +msql.max_persistent = -1 +msql.max_links = -1 +[OCI8] +[PostgresSQL] +pgsql.allow_persistent = On +pgsql.auto_reset_persistent = Off +pgsql.max_persistent = -1 +pgsql.max_links = -1 +pgsql.ignore_notice = 0 +pgsql.log_notice = 0 +[Sybase] +sybase.allow_persistent = On +sybase.max_persistent = -1 +sybase.max_links = -1 +sybase.min_error_severity = 10 +sybase.min_message_severity = 10 +sybase.compatability_mode = Off +[Sybase-CT] +sybct.allow_persistent = On +sybct.max_persistent = -1 +sybct.max_links = -1 +sybct.min_server_severity = 10 +sybct.min_client_severity = 10 +[bcmath] +bcmath.scale = 0 +[browscap] +[Informix] +ifx.default_host = +ifx.default_user = +ifx.default_password = +ifx.allow_persistent = On +ifx.max_persistent = -1 +ifx.max_links = -1 +ifx.textasvarchar = 0 +ifx.byteasvarchar = 0 +ifx.charasvarchar = 0 +ifx.blobinfile = 0 +ifx.nullformat = 0 +[Session] +session.save_handler = files +session.use_cookies = 1 +session.name = PHPSESSID +session.auto_start = 0 +session.cookie_lifetime = 0 +session.cookie_path = / +session.cookie_domain = +session.cookie_httponly = +session.serialize_handler = php +session.gc_probability = 1 +session.gc_divisor = 1000 +session.gc_maxlifetime = 1440 +session.bug_compat_42 = 0 +session.bug_compat_warn = 1 +session.referer_check = +session.entropy_length = 0 +session.entropy_file = +session.cache_limiter = nocache +session.cache_expire = 180 +session.use_trans_sid = 0 +session.hash_function = 0 +session.hash_bits_per_character = 5 +url_rewriter.tags = "a=href,area=href,frame=src,input=src,form=fakeentry" +[MSSQL] +mssql.allow_persistent = On +mssql.max_persistent = -1 +mssql.max_links = -1 +mssql.min_error_severity = 10 +mssql.min_message_severity = 10 +mssql.compatability_mode = Off +mssql.secure_connection = Off +[Assertion] +[COM] +[mbstring] +[FrontBase] +[gd] +[exif] +[Tidy] +tidy.clean_output = Off +[soap] +soap.wsdl_cache_enabled=1 +soap.wsdl_cache_dir="/tmp" +soap.wsdl_cache_ttl=86400 +END_OF_FILE +/*******************************************************************\ +* PROJECT INFORMATION * +* * +* Project: Apache-Test * +* URL: http://perl.apache.org/Apache-Test/ * +* Notice: Copyright (c) 2006 The Apache Software Foundation * +* * +********************************************************************* +* LICENSE INFORMATION * +* * +* Licensed 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. * +* * +********************************************************************* +* MODULE INFORMATION * +* * +* This is a PHP implementation of Test::More: * +* * +* http://search.cpan.org/dist/Test-Simple/lib/Test/More.pm * +* * +********************************************************************* +* CREDITS * +* * +* Originally inspired by work from Andy Lester. Written and * +* maintained by Chris Shiflett. For contact information, see: * +* * +* http://shiflett.org/ * +* * +\*******************************************************************/ + +header('Content-Type: text/plain'); +register_shutdown_function('_test_end'); + +$_no_plan = FALSE; +$_num_failures = 0; +$_num_skips = 0; +$_test_num = 0; + +function plan($plan) +{ + /* + plan('no_plan'); + plan('skip_all'); + plan(array('skip_all' => 'My reason is...')); + plan(23); + */ + + global $_no_plan; + global $_skip_all; + global $_skip_reason; + + switch ($plan) + { + case 'no_plan': + $_no_plan = TRUE; + break; + + case 'skip_all': + echo "1..0\n"; + break; + + default: + if (is_array($plan)) + { + echo "1..0 # Skip {$plan['skip_all']}\n"; + exit; + } + + echo "1..$plan\n"; + break; + } +} + +function ok($pass, $test_name = '') +{ + global $_test_num; + global $_num_failures; + global $_num_skips; + + $_test_num++; + + if ($_num_skips) + { + $_num_skips--; + return TRUE; + } + + if (!empty($test_name) && $test_name[0] != '#') + { + $test_name = "- $test_name"; + } + + if ($pass) + { + echo "ok $_test_num $test_name\n"; + } + else + { + echo "not ok $_test_num $test_name\n"; + + $_num_failures++; + $caller = debug_backtrace(); + + if (strstr($caller['0']['file'], $_SERVER['PHP_SELF'])) + { + $file = $caller['0']['file']; + $line = $caller['0']['line']; + } + else + { + $file = $caller['1']['file']; + $line = $caller['1']['line']; + } + + $file = str_replace($_SERVER['SERVER_ROOT'], 't', $file); + + diag(" Failed test ($file at line $line)"); + } + + return $pass; +} + +function is($this, $that, $test_name = '') +{ + $pass = ($this == $that); + + ok($pass, $test_name); + + if (!$pass) + { + diag(" got: '$this'"); + diag(" expected: '$that'"); + } + + return $pass; +} + +function isnt($this, $that, $test_name = '') +{ + $pass = ($this != $that); + + ok($pass, $test_name); + + if (!$pass) + { + diag(" '$this'"); + diag(' !='); + diag(" '$that'"); + } + + return $pass; +} + +function like($string, $pattern, $test_name = '') +{ + $pass = preg_match($pattern, $string); + + ok($pass, $test_name); + + if (!$pass) + { + diag(" '$string'"); + diag(" doesn't match '$pattern'"); + } + + return $pass; +} + +function unlike($string, $pattern, $test_name = '') +{ + $pass = !preg_match($pattern, $string); + + ok($pass, $test_name); + + if (!$pass) + { + diag(" '$string'"); + diag(" matches '$pattern'"); + } + + return $pass; +} + +function cmp_ok($this, $operator, $that, $test_name = '') +{ + eval("\$pass = (\$this $operator \$that);"); + + ok($pass, $test_name); + + if (!$pass) + { + diag(" got: '$this'"); + diag(" expected: '$that'"); + } + + return $pass; +} + +function can_ok($object, $methods) +{ + $pass = TRUE; + $errors = array(); + + foreach ($methods as $method) + { + if (!method_exists($object, $method)) + { + $pass = FALSE; + $errors[] = " method_exists(\$object, $method) failed"; + } + } + + if ($pass) + { + ok(TRUE, "method_exists(\$object, ...)"); + } + else + { + ok(FALSE, "method_exists(\$object, ...)"); + diag($errors); + } + + return $pass; +} + +function isa_ok($object, $expected_class, $object_name = 'The object') +{ + $got_class = get_class($object); + + if (version_compare(php_version(), '5', '>=')) + { + $pass = ($got_class == $expected_class); + } + else + { + $pass = ($got_class == strtolower($expected_class)); + } + + if ($pass) + { + ok(TRUE, "$object_name isa $expected_class"); + } + else + { + ok(FALSE, "$object_name isn't a '$expected_class' it's a '$got_class'"); + } + + return $pass; +} + +function pass($test_name = '') +{ + return ok(TRUE, $test_name); +} + +function fail($test_name = '') +{ + return ok(FALSE, $test_name); +} + +function diag($message) +{ + if (is_array($message)) + { + foreach($message as $current) + { + echo "# $current\n"; + } + } + else + { + echo "# $message\n"; + } +} + +function include_ok($module) +{ + $pass = ((include $module) == 'OK'); + return ok($pass); +} + +function require_ok($module) +{ + $pass = ((require $module) == 'OK'); + return ok($pass); +} + +function skip($message, $num) +{ + global $_num_skips; + + if ($num < 0) + { + $num = 0; + } + + for ($i = 0; $i < $num; $i++) + { + pass("# SKIP $message"); + } + + $_num_skips = $num; +} + +/* + +TODO: + +function todo() +{ +} + +function todo_skip() +{ +} + +function is_deeply() +{ +} + +function eq_array() +{ +} + +function eq_hash() +{ +} + +function eq_set() +{ +} + +*/ + +function _test_end() +{ + global $_no_plan; + global $_num_failures; + global $_test_num; + + if ($_no_plan) + { + echo "1..$_test_num\n"; + } + + if ($_num_failures) + { + diag("Looks like you failed $_num_failures tests of $_test_num."); + } +} + +?> diff --git a/debian/perl-framework/Apache-Test/lib/Apache/TestConfigParrot.pm b/debian/perl-framework/Apache-Test/lib/Apache/TestConfigParrot.pm new file mode 100644 index 0000000..e13a7dc --- /dev/null +++ b/debian/perl-framework/Apache-Test/lib/Apache/TestConfigParrot.pm @@ -0,0 +1,92 @@ +# 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::TestConfigParrot; + +#things specific to mod_parrot + +use strict; +use warnings FATAL => 'all'; +use File::Spec::Functions qw(catfile splitdir abs2rel); +use File::Find qw(finddepth); +use Apache::TestTrace; +use Apache::TestRequest; +use Apache::TestConfig; +use Apache::TestConfigPerl; +use Config; + +@Apache::TestConfigParrot::ISA = qw(Apache::TestConfig); + +sub new { + return shift->SUPER::new(@_); +} + +sub configure_parrot_tests_pick { + my($self, $entries) = @_; + + for my $subdir (qw(Response)) { + my $dir = catfile $self->{vars}->{t_dir}, lc $subdir; + next unless -d $dir; + + finddepth(sub { + return unless /\.pir$/; + + 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); + } +} + +sub configure_parrot_tests { + my $self = shift; + + my @entries = (); + $self->configure_parrot_tests_pick(\@entries); + $self->configure_pm_tests_sort(\@entries); + + my %seen = (); + + for my $entry (@entries) { + my ($file, $module, $subdir, $status) = @$entry; + + my @args = (); + + my $directives = $self->add_module_config($file, \@args); + + $module =~ s,\.pir$,,; + $module =~ s/^[a-z]://i; #strip drive if any + $module = join '::', splitdir $module; + + my @base = map { s/^test//i; $_ } split '::', $module; + + my $sub = pop @base; + + debug "configuring mod_parrot test file $file"; + + push @args, SetHandler => 'parrot-code'; + push @args, ParrotHandler => $module; + + $self->postamble(ParrotLoad => $file); + $self->postamble($self->location_container($module), \@args); + + $self->write_pm_test($module, lc $sub, map { lc } @base); + } +} + +1; + +__DATA__ 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; 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; diff --git a/debian/perl-framework/Apache-Test/lib/Apache/TestHandler.pm b/debian/perl-framework/Apache-Test/lib/Apache/TestHandler.pm new file mode 100644 index 0000000..6b1e691 --- /dev/null +++ b/debian/perl-framework/Apache-Test/lib/Apache/TestHandler.pm @@ -0,0 +1,175 @@ +# 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::TestHandler; + +use strict; +use warnings FATAL => 'all'; + +use Apache::Test qw/!:DEFAULT/; # call import() to tell about -withouttestmore +use Apache::TestRequest (); + +use Apache2::Const -compile => qw(OK NOT_FOUND SERVER_ERROR); + +#some utility handlers for testing hooks other than response +#see modperl-2.0/t/hooks/TestHooks/authen.pm + +if ($ENV{MOD_PERL} && require mod_perl2) { + require Apache2::RequestRec; # content_type + require Apache2::RequestIO; # puts +} + +#compat with 1.xx +my $send_http_header = Apache->can('send_http_header') || sub {}; +my $print = Apache2->can('print') || Apache2::RequestRec->can('puts'); + +sub ok { + my ($r, $boolean) = @_; + $r->$send_http_header; + $r->content_type('text/plain'); + $r->$print((@_>1 && !$boolean ? "not " : '')."ok"); + 0; +} + +sub ok1 { + my ($r, $boolean) = @_; + Apache::Test::plan($r, tests => 1); + Apache::Test::ok(@_==1 || $boolean); + 0; +} + +# a fixup handler to be used when a few requests need to be run +# against the same perl interpreter, in situations where there is more +# than one client running. For an example of use see +# modperl-2.0/t/response/TestModperl/interp.pm and +# modperl-2.0/t/modperl/interp.t +# +# this handler expects the header X-PerlInterpreter in the request +# - if none is set, Apache::SERVER_ERROR is returned +# - if its value eq 'tie', instance's global UUID is assigned and +# returned via the same header +# - otherwise if its value is not the same the stored instance's +# global UUID Apache::NOT_FOUND is returned +# +# in addition $same_interp_counter counts how many times this instance of +# pi has been called after the reset 'tie' request (inclusive), this +# value can be retrieved with Apache::TestHandler::same_interp_counter() +my $same_interp_id = ""; +# keep track of how many times this instance was called after the reset +my $same_interp_counter = 0; +sub same_interp_counter { $same_interp_counter } +sub same_interp_fixup { + my $r = shift; + my $interp = $r->headers_in->get(Apache::TestRequest::INTERP_KEY); + + unless ($interp) { + # shouldn't be requesting this without an INTERP header + die "can't find the interpreter key"; + } + + my $id = $same_interp_id; + if ($interp eq 'tie') { #first request for an interpreter instance + # unique id for this instance + $same_interp_id = $id = + unpack "H*", pack "Nnn", time, $$, int(rand(60000)); + $same_interp_counter = 0; #reset the counter + } + elsif ($interp ne $same_interp_id) { + # this is not the request interpreter instance + return Apache2::Const::NOT_FOUND; + } + + $same_interp_counter++; + + # so client can save the created instance id or check the existing + # value + $r->headers_out->set(Apache::TestRequest::INTERP_KEY, $id); + + return Apache2::Const::OK; +} + +1; +__END__ + +=encoding utf8 + +=head1 NAME + +Apache::TestHandler - a few response handlers and helpers + +=head1 SYNOPSIS + + package My::Test; + use Apache::TestHandler (); + sub handler { + my ($r) = @_; + my $result = do_my_test; + Apache::TestHandler::ok1 $r, $result; + } + + sub handler2 { + my ($r) = @_; + my $result = do_my_test; + Apache::TestHandler::ok $r, $result; + } + +=head1 DESCRIPTION + +C<Apache::TestHandler> provides 2 very simple response handler. + +=head1 FUNCTIONS + +=over 4 + +=item ok $r, $boolean + +The handler simply prints out C<ok> or C<not ok> depending on the +optional C<$boolean> parameter. + +If C<$boolean> is omitted C<true> is assumed. + +=item ok1 $r, $boolean + +This handler implements a simple response-only test. It can be used on its +own to check if for a certain URI the response phase is reached. Or it +can be called like a normal function to print out the test result. The +client side is automatically created as described in +L<http://perl.apache.org/docs/general/testing/testing.html#Developing_Response_only_Part_of_a_Test>. + +C<$boolean> is optional. If omitted C<true> is assumed. + +=item same_interp_counter + +=item same_interp_fixup + +TODO + +=back + +=head1 SEE ALSO + +The Apache-Test tutorial: +L<http://perl.apache.org/docs/general/testing/testing.html>. + +L<Apache::Test>. + +=head1 AUTHOR + +Doug MacEachern, Geoffrey Young, Stas Bekman, Torsten Förtsch and others. + +Questions can be asked at the test-dev <at> httpd.apache.org list +For more information see: http://httpd.apache.org/test/. + +=cut diff --git a/debian/perl-framework/Apache-Test/lib/Apache/TestHarness.pm b/debian/perl-framework/Apache-Test/lib/Apache/TestHarness.pm new file mode 100644 index 0000000..4128a43 --- /dev/null +++ b/debian/perl-framework/Apache-Test/lib/Apache/TestHarness.pm @@ -0,0 +1,199 @@ +# 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::TestHarness; + +use strict; +use warnings FATAL => 'all'; + +use Test::Harness (); +use Apache::Test (); +use Apache::TestSort (); +use Apache::TestTrace; +use File::Spec::Functions qw(catfile catdir); +use File::Find qw(finddepth); +use File::Basename qw(dirname); + +sub inc_fixup { + # use blib + unshift @INC, map "blib/$_", qw(lib arch); + + # fix all relative library locations + for (@INC) { + $_ = "../$_" unless m,^(/)|([a-f]:),i; + } +} + +#skip tests listed in t/SKIP +sub skip { + my($self, $file) = @_; + $file ||= catfile Apache::Test::vars('serverroot'), 'SKIP'; + + return unless -e $file; + + my $fh = Symbol::gensym(); + open $fh, $file or die "open $file: $!"; + my @skip; + local $_; + + while (<$fh>) { + chomp; + s/^\s+//; s/\s+$//; s/^\#.*//; + next unless $_; + s/\*/.*/g; + push @skip, $_; + } + + close $fh; + return join '|', @skip; +} + +#test if all.t would skip tests or not +{ + my $source_lib = ''; + + sub run_t { + my($self, $file) = @_; + my $ran = 0; + + if (Apache::TestConfig::IS_APACHE_TEST_BUILD and !length $source_lib) { + # so we can find Apache/Test.pm from both the perl-framework/ + # and Apache-Test/ + + my $top_dir = Apache::Test::vars('top_dir'); + foreach my $lib (catfile($top_dir, qw(Apache-Test lib)), + catfile($top_dir, qw(.. Apache-Test lib)), + catfile($top_dir, 'lib')) { + + if (-d $lib) { + info "adding source lib $lib to \@INC"; + $source_lib = qq[-Mlib="$lib"]; + last; + } + } + } + + my $cmd = qq[$^X $source_lib $file]; + + my $h = Symbol::gensym(); + open $h, "$cmd|" or die "open $cmd: $!"; + + local $_; + while (<$h>) { + if (/^1\.\.(\d)/) { + $ran = $1; + last; + } + } + + close $h; + + $ran; + } +} + +#if a directory has an all.t test +#skip all tests in that directory if all.t prints "1..0\n" +sub prune { + my($self, @tests) = @_; + my(@new_tests, %skip_dirs); + + foreach my $test (@tests) { + next if $test =~ /\.#/; # skip temp emacs files + my $dir = dirname $test; + if ($test =~ m:\Wall\.t$:) { + unless (__PACKAGE__->run_t($test)) { + $skip_dirs{$dir} = 1; + @new_tests = grep { m:\Wall\.t$: || + not $skip_dirs{dirname $_} } @new_tests; + push @new_tests, $test; + } + } + elsif (!$skip_dirs{$dir}) { + push @new_tests, $test; + } + } + + @new_tests; +} + +sub get_tests { + my $self = shift; + my $args = shift; + my @tests = (); + + my $base = -d 't' ? catdir('t', '.') : '.'; + + my $ts = $args->{tests} || []; + + if (@$ts) { + for (@$ts) { + if (-d $_) { + push(@tests, sort <$base/$_/*.t>); + } + else { + $_ .= ".t" unless /\.t$/; + push(@tests, $_); + } + } + } + else { + if ($args->{tdirs}) { + push @tests, map { sort <$base/$_/*.t> } @{ $args->{tdirs} }; + } + else { + finddepth(sub { + return unless /\.t$/; + my $t = catfile $File::Find::dir, $_; + my $dotslash = catfile '.', ""; + $t =~ s:^\Q$dotslash::; + push @tests, $t + }, $base); + @tests = sort @tests; + } + } + + @tests = $self->prune(@tests); + + if (my $skip = $self->skip) { + # Allow / \ and \\ path delimiters in SKIP file + $skip =~ s![/\\\\]+![/\\\\]!g; + + @tests = grep { not /(?:$skip)/ } @tests; + } + + Apache::TestSort->run(\@tests, $args); + + #when running 't/TEST t/dir' shell tab completion adds a / + #dir//foo output is annoying, fix that. + s:/+:/:g for @tests; + + return @tests; +} + +sub run { + my $self = shift; + my $args = shift || {}; + + $Test::Harness::verbose ||= $args->{verbose}; + + if (my(@subtests) = @{ $args->{subtests} || [] }) { + $ENV{HTTPD_TEST_SUBTESTS} = "@subtests"; + } + + Test::Harness::runtests($self->get_tests($args, @_)); +} + +1; diff --git a/debian/perl-framework/Apache-Test/lib/Apache/TestHarnessPHP.pm b/debian/perl-framework/Apache-Test/lib/Apache/TestHarnessPHP.pm new file mode 100644 index 0000000..90fdedc --- /dev/null +++ b/debian/perl-framework/Apache-Test/lib/Apache/TestHarnessPHP.pm @@ -0,0 +1,139 @@ +# 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::TestHarnessPHP; + +use strict; +use warnings FATAL => 'all'; + +use File::Spec::Functions qw(catfile catdir); +use File::Find qw(finddepth); +use Apache::TestHarness (); +use Apache::TestTrace; +use Apache::TestConfig (); + +use vars qw(@ISA); +@ISA = qw(Apache::TestHarness); +use TAP::Formatter::Console; +use TAP::Harness; + +sub get_tests { + + my $self = shift; + my $args = shift; + my @tests = (); + + my $base = -d 't' ? catdir('t', '.') : '.'; + + my $ts = $args->{tests} || []; + + if (@$ts) { + for (@$ts) { + if (-d $_) { + push(@tests, sort <$base/$_/*.t>); + push(@tests, sort <$base/$_/*.php>); + } + else { + $_ .= ".t" unless /(\.t|\.php)$/; + push(@tests, $_); + } + } + } + else { + if ($args->{tdirs}) { + push @tests, map { sort <$base/$_/*.t> } @{ $args->{tdirs} }; + push @tests, map { sort <$base/$_/*.php> } @{ $args->{tdirs} }; + } + else { + finddepth(sub { + return unless /\.(t|php)$/; + return if $File::Find::dir =~ m/\b(conf|htdocs|logs|response)\b/; + my $t = catfile $File::Find::dir, $_; + my $dotslash = catfile '.', ""; + $t =~ s:^\Q$dotslash::; + push @tests, $t + }, $base); + @tests = sort @tests; + } + } + + @tests = $self->prune(@tests); + + if (my $skip = $self->skip) { + # Allow / \ and \\ path delimiters in SKIP file + $skip =~ s![/\\\\]+![/\\\\]!g; + + @tests = grep { not /(?:$skip)/ } @tests; + } + + Apache::TestSort->run(\@tests, $args); + + #when running 't/TEST t/dir' shell tab completion adds a / + #dir//foo output is annoying, fix that. + s:/+:/:g for @tests; + + # remove *.php tests unless we can run them with php + if (! Apache::TestConfig::which('php')) { + warning(join ' - ', 'skipping *.php tests', + 'make sure php is in your PATH'); + @tests = grep { not /\.php$/ } @tests; + } + elsif (! $phpclient) { + warning(join ' - ', 'skipping *.php tests', + 'Test::Harness 2.38 not available'); + @tests = grep { not /\.php$/ } @tests; + } + + return @tests; +} + +sub run { + my $self = shift; + my $args = shift || {}; + my $formatter = TAP::Formatter::Console->new; + my $agg = TAP::Parser::Aggregator->new; + my $verbose = $args->{verbose} && $args->{verbose}; + my $php_harness = TAP::Harness->new + ({exec => $self->command_line(), + verbosity => $verbose}); + my $perl_harness = TAP::Harness->new + ({verbosity => $verbose}); + my @tests = $self->get_tests($args, @_); + + $agg->start(); + $php_harness->aggregate_tests($agg, grep {m{\.php$}} @tests); + $perl_harness->aggregate_tests($agg, grep {m{\.t$}} @tests); + $agg->stop(); + + $formatter->summary($agg); +} + +sub command_line { + my $self = shift; + + my $server_root = Apache::Test::vars('serverroot'); + + my $conf = catfile($server_root, 'conf'); + + my $ini = catfile($conf, 'php.ini'); + + my $php = Apache::TestConfig::which('php') || + die 'no php executable found in ' . $ENV{PATH}; + + return ["env", "SERVER_ROOT=$server_root", + $php, "--php-ini", $ini, "--define", "include_path=$conf"]; +} + +1; diff --git a/debian/perl-framework/Apache-Test/lib/Apache/TestMB.pm b/debian/perl-framework/Apache-Test/lib/Apache/TestMB.pm new file mode 100644 index 0000000..51254a8 --- /dev/null +++ b/debian/perl-framework/Apache-Test/lib/Apache/TestMB.pm @@ -0,0 +1,410 @@ +# 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::TestMB; + +use strict; +use vars qw(@ISA); +use Module::Build 0.18; +use Apache::Test (); +use Apache::TestConfig (); +@ISA = qw(Module::Build); + +sub new { + my $pkg = shift; + my($argv, $vars) = + Apache::TestConfig::filter_args(\@ARGV, \%Apache::TestConfig::Usage); + @ARGV = @$argv; + my $self = $pkg->SUPER::new(@_); + $self->{properties}{apache_test_args} = $vars; + $self->{properties}{apache_test_script} ||= 't/TEST'; + $self->generate_script; + return $self; +} + +sub valid_property { + return 1 if defined $_[1] && + ($_[1] eq 'apache_test_args' || $_[1] eq 'apache_test_script'); + shift->SUPER::valid_property(@_); +} + +sub apache_test_args { + my $self = shift; + $self->{properties}{apache_test_args} = shift if @_; + return $self->{properties}{apache_test_args}; +} + +sub apache_test_script { + my $self = shift; + $self->{properties}{apache_test_script} = shift if @_; + return $self->{properties}{apache_test_script}; +} + +sub ACTION_test_clean { + my $self = shift; + # XXX I'd love to do this without t/TEST. + $self->do_system( $self->perl, $self->_bliblib, + $self->localize_file_path($self->apache_test_script), + '-clean'); +} + +sub ACTION_clean { + my $self = shift; + $self->depends_on('test_clean'); + $self->SUPER::ACTION_clean(@_); +} + +sub ACTION_run_tests { + my $self = shift; + $self->depends_on('test_clean'); + # XXX I'd love to do this without t/TEST. + $self->do_system($self->perl, $self->_bliblib, + $self->localize_file_path($self->apache_test_script), + '-bugreport', '-verbose=' . ($self->verbose || 0)); +} + +sub ACTION_testcover { + my $self = shift; + + unless ($self->find_module_by_name('Devel::Cover', \@INC)) { + warn("Cannot run testcover action unless Devel::Cover " + . "is installed.\n" . + "Don't forget to rebuild your Makefile after " + . "installing Devel::Cover\n"); + return; + } + + $self->add_to_cleanup('coverage', 'cover_db'); + + my $atdir = $self->localize_file_path("$ENV{HOME}/.apache-test"); + local $Test::Harness::switches = + local $Test::Harness::Switches = + local $ENV{HARNESS_PERL_SWITCHES} = "-MDevel::Cover=+inc,'$atdir'"; + local $ENV{APACHE_TEST_EXTRA_ARGS} = "-one-process"; + + $self->depends_on('test'); + $self->do_system('cover'); +} + +sub ACTION_test_config { + my $self = shift; + $self->do_system($self->perl, $self->_bliblib, + $self->localize_file_path($self->apache_test_script), + '-conf', '-verbose=' . ($self->verbose || 0)); +} + +sub _bliblib { + my $self = shift; + return ( + '-I', File::Spec->catdir($self->base_dir, $self->blib, 'lib'), + '-I', File::Spec->catdir($self->base_dir, $self->blib, 'arch'), + ); +} + +sub ACTION_test { + my $self = shift; + $self->depends_on('code'); + $self->depends_on('run_tests'); + $self->depends_on('test_clean'); +} + +sub _cmodules { + my ($self, $action) = @_; + die "The cmodules" . ( $action ne 'all' ? "_$action" : '') + . " action is not yet implemented"; + # XXX TBD. + $self->depends_on('test_config'); + my $start_dir = $self->cwd; + chdir $self->localize_file_path('c-modules'); + # XXX How do we get Build.PL to be generated instead of Makefile? + # Subclass Apache::TestConfigC, perhaps? + $self->do_system('Build.PL', $action); + chdir $start_dir; +} + +sub ACTION_cmodules { shift->_cmodues('all') } +sub ACTION_cmodules_clean { shift->_cmodues('clean') } + +# XXX I'd love to make this optional. +sub generate_script { + my $self = shift; + + # If a file name has been passed in, use it. Otherwise, use the + # one set up when the Apache::TestMB object was created. + my $script = $self->localize_file_path($_[0] + ? $self->apache_test_script(shift) + : $self->apache_test_script + ); + + # We need a class to run the tests from t/TEST. + my $class = pop || 'Apache::TestRunPerl'; + + # Delete any existing instance of the file. + unlink $script if -e $script; + + # Start the contents of t/TEST. + my $body = "BEGIN { eval { require blib && blib->import; } }\n"; + + # Configure the arguments for t/TEST. + while (my($k, $v) = each %{ $self->apache_test_args }) { + $v =~ s/\|/\\|/g; + $body .= "\n\$Apache::TestConfig::Argv{'$k'} = q|$v|;\n"; + } + + my $infile = "$script.PL"; + if (-f $infile) { + # Use the existing t/TEST.PL. + my $in = Symbol::gensym(); + open $in, "$infile" or die "Couldn't open $infile: $!"; + local $/; + $body .= <$in>; + close $in; + } else { + # Create t/TEST from scratch. + $body .= join "\n", + Apache::TestConfig->perlscript_header, + "use $class ();", + "$class->new->run(\@ARGV);"; + } + + # Make it so! + print "Generating test running script $script\n" if $self->verbose; + Apache::Test::basic_config()->write_perlscript($script, $body); + $self->add_to_cleanup($self->apache_test_script); +} + + +1; +__END__ + +=head1 NAME + +Apache::TestMB - Subclass of Module::Build to support Apache::Test + +=head1 SYNOPSIS + +Standard process for building & installing modules: + + perl Build.PL + ./Build + ./Build test + ./Build install + +Or, if you're on a platform (like DOS or Windows) that doesn't like the "./" +notation, you can do this: + + perl Build.PL + perl Build + perl Build test + perl Build install + +=head1 DESCRIPTION + +This class subclasses C<Module::Build> to add support for testing +Apache integration with Apache::Test. It is broadly based on +C<Apache::TestMM>, and as such adds a number of build actions to a the +F<Build> script, while simplifying the process of creating F<Build.PL> +scripts. + +Here's how to use C<Apache::TestMB> in a F<Build.PL> script: + + use Module::Build; + + my $build_pkg = eval { require Apache::TestMB } + ? 'Apache::TestMB' : 'Module::Build'; + + my $build = $build_pkg->new( + module_name => 'My::Module', + ); + $build->create_build_script; + +This is identical to how C<Module::Build> is used. Not all target +systems may have C<Apache::Test> (and therefore C<Apache::TestMB> +installed, so we test for it to be installed, first. But otherwise, +its use can be exactly the same. Consult the +L<Module::Build|Module::Build> documentation for more information on +how to use it; L<Module::Build::Cookbook|Module::Build::Cookbook> may +be especially useful for those looking to migrate from +C<ExtUtils::MakeMaker>. + +=head1 INTERFACE + +=head2 Build + +With the above script, users can build your module in the usual +C<Module::Build> way: + + perl Build.PL + ./Build + ./Build test + ./Build install + +If C<Apache::TestMB> is installed, then Apache will be started before +tests are run by the C<test> action, and shut down when the tests +complete. Note that C<Build.PL> can be called C<Apache::Test>-specific +options in addition to the usual C<Module::Build> options. For +example: + + perl Build.PL -apxs /usr/local/apache/bin/apxs + +Consult the L<Apache::Test|Apache::Test> documentation for a complete +list of options. + +In addition to the actions provided by C<Module::Build> (C<build>, +C<clean>, C<code>, C<test>, etc.), C<Apache::TestMB> adds a few extra +actions: + +=over 4 + +=item test_clean + +This action cleans out the files generated by the test script, +F<t/TEST>. It is also executed by the C<clean> action. + +=item run_tests + +This action actually the tests by executing the test script, +F<t/TEST>. It is executed by the C<test> action, so most of the time +it won't be executed directly. + +=item testcover + +C<Apache::TestMB> overrides this action from C<Module::Build> in order to +prevent the C<Apache::Test> preference files from being included in the test +coverage. + +=back + +=head2 Constructor + +=head3 new + +The C<new()> constructor takes all the same arguments as its parent in +C<Module::Build>, but can optionally accept one other parameter: + +=over + +=item apache_test_script + +The name of the C<Apache::Test> test script. The default value is +F<t/TEST>, which will work in the vast majority of cases. If you wish +to specify your own file name, do so with a relative file name using +Unix-style paths; the file name will automatically be converted for +the local platform. + +=back + +When C<new()> is called it does the following: + +=over 4 + +=item * + +Processes the C<Apache::Test>-specific options in C<@ARGV>. See the +L<Apache::Test|Apache::Test> documentation for a complete list of +options. + +=item * + +Sets the name of the C<Apache::Test> test script to F<t/TEST>, unless +it was explicitly specified by the C<apache_test_script> parameter. + +=item * + +Calls C<generate_script()> to generate C<Apache::Test> test script, +usually F<t/TEST>. + +=back + +=head2 Instance Methods + +=head3 apache_test_args + +Returns a hash reference containing all of the settings specified by +options passed to F<Build.PL>, or explicitly added to C<@ARGV> in +F<Build.PL>. Consult the L<Apache::Test|Apache::Test> documentation +for a complete list of options. + +=head3 apache_test_script + +Gets or sets the file name of the C<Apache::Test> test script. + +=head3 generate_script + + $build->generate_script; + $build->generate_script('t/FOO'); + $build->generate_script(undef, 'Apache::TestRun'); + +This method is called by C<new()>, so in most cases it can be +ignored. If you'd like it to use other than the default arguments, you +can call it explicitly in F<Build.PL> and pass it the arguments you +desire. It takes two optional arguments: + +=over 4 + +=item * + +The name of the C<Apache::Test> test script. Defaults to the value +returned by C<apache_test_script()>. + +=item * + +The name of an C<Apache::Test> test running class. Defaults to +C<Apache::TestRunPerl>. + +=back + +If there is an existing F<t/TEST.PL> (or a script with the same name +as specified by the C<apache_test_script> parameter but with F<.PL> +appended to it), then that script will be used as the template for the +test script. Otherwise, a simple test script will be written similar +to what would be written by C<Apache::TestRun::generate_script()> +(although that function is not aware of the arguments passed to +F<Build.PL>, so use this one instead!). + +=head1 SEE ALSO + +=over 4 + +=item L<Apache::TestRequest|Apache::TestRequest> + +Demonstrates how to write tests to send requests to the Apache server +run by C<./Build test>. + +=item L<Module::Build|Module::Build> + +The parent class for C<Apache::TestMB>; consult it's documentation for +more on its interface. + +=item L<http://www.perl.com/pub/a/2003/05/22/testing.html> + +This article by Geoffrey Young explains how to configure Apache and +write tests for your module using Apache::Test. Just use +C<Apache::TestMB> instead of C<Apache::TestMM> to update it for use +with C<Module::Build>. + +=back + +=head1 AUTHOR + +David Wheeler + +Questions can be asked at the test-dev <at> httpd.apache.org list. For +more information see: I<http://httpd.apache.org/test/> and +I<http://perl.apache.org/docs/general/testing/testing.html>. + +=cut + diff --git a/debian/perl-framework/Apache-Test/lib/Apache/TestMM.pm b/debian/perl-framework/Apache-Test/lib/Apache/TestMM.pm new file mode 100644 index 0000000..f9b862f --- /dev/null +++ b/debian/perl-framework/Apache-Test/lib/Apache/TestMM.pm @@ -0,0 +1,258 @@ +# 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::TestMM; + +use strict; +use warnings FATAL => 'all'; + +use Config; +use Apache::TestConfig (); +use Apache::TestTrace; +use Apache::TestSmoke; + +sub import { + my $class = shift; + + for my $section (@_) { + unless (defined &$section) { + die "unknown Apache::TestMM section: $section"; + } + no strict 'refs'; + my $sub = "MY::$section"; + # Force aliasing, since previous WriteMakefile might have + # moved it + undef &$sub if defined &$sub; + *$sub = \&{$section}; + } +} + +sub add_dep { + my($string, $targ, $add) = @_; + $$string =~ s/($targ\s+::)/$1 $add /; +} + +sub clean { + my $self = shift; + my $string = $self->MM::clean(@_); + add_dep(\$string, clean => 'test_clean'); + $string; +} + +sub test { + my $self = shift; + my $env = Apache::TestConfig->passenv_makestr(); + + my $tests = "TEST_FILES =\n"; + + if (ref $self && exists $self->{'test'}) { + $tests = 'TEST_FILES = ' . $self->{'test'}->{'TESTS'} . "\n"; + } + + my $preamble = Apache::TestConfig::WIN32 ? "" : <<EOF; +PASSENV = $env +EOF + + my $cover; + + if (eval { require Devel::Cover }) { + my $atdir = File::Spec->catfile($ENV{HOME}, '.apache-test'); + + my $cover_exec = Apache::TestConfig::which("cover"); + + my @cover = ("", "testcover :", ); + push @cover, "\t-\@$cover_exec -delete" if $cover_exec; + push @cover, "\t-HARNESS_PERL_SWITCHES=-MDevel::Cover=+inc,$atdir \\", + "\tAPACHE_TEST_EXTRA_ARGS=-one-process \$(MAKE) test"; + push @cover, "\t-\@$cover_exec" if $cover_exec; + $cover = join "\n", @cover, ""; + } + else { + + $cover = <<'EOF'; + +testcover : + @echo "Cannot run testcover action unless Devel::Cover is installed" + @echo "Don't forget to rebuild your Makefile after installing Devel::Cover" +EOF + } + + return $preamble . $tests . <<'EOF' . $cover; +TEST_VERBOSE = 0 + +test_clean : + $(FULLPERL) -I$(INST_ARCHLIB) -I$(INST_LIB) \ + t/TEST $(APACHE_TEST_EXTRA_ARGS) -clean + +run_tests : + $(PASSENV) \ + $(FULLPERL) -I$(INST_ARCHLIB) -I$(INST_LIB) \ + t/TEST $(APACHE_TEST_EXTRA_ARGS) -bugreport -verbose=$(TEST_VERBOSE) $(TEST_FILES) + +test :: pure_all test_clean run_tests + +test_config : + $(PASSENV) \ + $(FULLPERL) -I$(INST_ARCHLIB) -I$(INST_LIB) \ + t/TEST $(APACHE_TEST_EXTRA_ARGS) -conf + +cmodules: test_config + cd c-modules && $(MAKE) all + +cmodules_clean: test_config + cd c-modules && $(MAKE) clean +EOF + +} + +sub generate_script { + my $file = shift; + + unlink $file if -e $file; + + my $body = "BEGIN { eval { require blib && blib->import; } }\n"; + + my %args = @Apache::TestMM::Argv; + while (my($k, $v) = each %args) { + $v =~ s/\|/\\|/g; + $body .= "\n\$Apache::TestConfig::Argv{'$k'} = q|$v|;\n"; + } + + my $in = Symbol::gensym(); + open $in, "$file.PL" or die "Couldn't open $file.PL: $!"; + { + local $/; + $body .= <$in>; + } + close $in; + + info "generating script $file"; + Apache::Test::basic_config()->write_perlscript($file, $body); + Apache::TestSmoke->generate_script; +} + +sub filter_args { + my($argv, $vars) = + Apache::TestConfig::filter_args(\@ARGV, \%Apache::TestConfig::Usage); + @ARGV = @$argv; + @Apache::TestMM::Argv = %$vars; +} + +1; + +=head1 NAME + +Apache::TestMM - Provide MakeMaker Wrapper Methods + +=head1 SYNOPSIS + + require Apache::TestMM; + + # import MY::test and MY::clean overrides for MM + Apache::TestMM->import(qw(test clean)); + + # parse command line args + Apache::TestMM::filter_args(); + + # autogenerate the script + Apache::TestMM::generate_script('t/TEST'); + +=head1 DESCRIPTION + +C<Apache::TestMM> provides wrappers for the C<ExtUtils::MakeMaker> +craft, making it easier to extend the autogenerated F<Makefile> with +C<Apache::Test>. + +=head1 FUNCTIONS + +=head2 C<import> + + use Apache::TestMM qw(test clean); + +or: + + Apache::TestMM->import(qw(test clean)); + +Imports C<MY::> overrides for the default C<ExtUtils::MakeMaker> +I<test> and I<clean> targets, as if you have defined: + + sub MY::test {...} + sub MY::clean {...} + +in F<Makefile.PL>. C<Apache::TestMM> does this for you so that these Makefile +targets will run the Apache server and the tests for it, and clean up after +its mess. + +=head2 C<filter_args> + + push @ARGV, '-apxs', $apxs_path; + Apache::TestMM::filter_args(); + WriteMakefile(...); + +When C<WriteMakefile()> is called it parses C<@ARGV>, hoping to find +special options like C<PREFIX=/home/stas/perl>. C<Apache::Test> +accepts a lot of configuration options of its own. When +C<Apache::TestMM::filter_args()> is called, it removes any +C<Apache::Test>-specific options from C<@ARGV> and stores them +internally, so when C<WriteMakefile()> is called they aren't in +C<@ARGV> and thus won't be processed by C<WriteMakefile()>. + +The options can be set when F<Makefile.PL> is called: + + % perl Makefile.PL -apxs /path/to/apxs + +Or you can push them manually to C<@ARGV> from the code: + + push @ARGV, '-apxs', $apxs_path; + +When: + + Apache::TestMM::generate_script('t/TEST'); + +is called, C<Apache::Test>-specific options extracted by +C<Apache::TestMM::filter_args()> are written to the autogenerated +file. In our example, the autogenerated F<t/TEST> will include: + + %Apache::TestConfig::Argv = qw(apxs /path/to/apxs); + +which is going to be used by the C<Apache::Test> runtime. + +The other frequently used options are: C<-httpd>, telling where to +find the httpd (usually when the C<-apxs> option is not used), +C<-libmodperl> to use a specific mod_perl shared object (if your +mod_perl is built as DSO), C<-maxclients> to change the default number +of the configured C<MaxClients> directive, C<-port> to start the +server on a specific port, etc. To get the complete list of available +configuration options and their purpose and syntax, run: + + % perl -MApache::TestConfig -le 'Apache::TestConfig::usage()' + +You may wish to document some of these in your application's F<README> +file, especially the C<-apxs> and C<-httpd> options. + + +=head2 C<generate_script> + + Apache::TestMM::generate_script('t/TEST'); + +C<generate_script()> accepts the name of the script to generate and +will look for a template with the same name and suffix I<.PL>. So in +our example it'll look for F<t/TEST.PL>. The autogenerated script +F<t/TEST> will include the contents of F<t/TEST.PL>, and special +directives, including any configuration options passed via +C<L<filter_args()|/C_filter_args_>> called from F<Makefile.PL>, special +fixup code, etc. + +=cut diff --git a/debian/perl-framework/Apache-Test/lib/Apache/TestPerlDB.pm b/debian/perl-framework/Apache-Test/lib/Apache/TestPerlDB.pm new file mode 100644 index 0000000..ba2e810 --- /dev/null +++ b/debian/perl-framework/Apache-Test/lib/Apache/TestPerlDB.pm @@ -0,0 +1,53 @@ +# 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. +# +#no 'package Apache::TestPerlDB.pm' here, else we change perldb's package +use strict; + +sub Apache::TestPerlDB::lwpd { + print Apache::TestRequest::lwp_debug(shift || 1); +} + +sub Apache::TestPerlDB::bok { + my $n = shift || 1; + print "breakpoint set at test $n\n"; + DB::cmd_b_sub('ok', "\$Test::ntest == $n"); +} + +my %help = ( + lwpd => 'Set the LWP debug level for Apache::TestRequest', + bok => 'Set breakpoint at test n', +); + +my $setup_db_aliases = sub { + my $package = 'Apache::TestPerlDB'; + my @cmds; + no strict 'refs'; + + while (my($name, $val) = each %{"$package\::"}) { + next unless defined &$val; + *{"main::$name"} = \&{$val}; + push @cmds, $name; + } + + print "$package added perldb commands:\n", + map { " $_ - $help{$_}\n" } @cmds; + +}; + +$setup_db_aliases->(); + +1; +__END__ diff --git a/debian/perl-framework/Apache-Test/lib/Apache/TestReport.pm b/debian/perl-framework/Apache-Test/lib/Apache/TestReport.pm new file mode 100644 index 0000000..eb575ea --- /dev/null +++ b/debian/perl-framework/Apache-Test/lib/Apache/TestReport.pm @@ -0,0 +1,181 @@ +# 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::TestReport; + +use strict; +use warnings FATAL => 'all'; + +use Apache::Test (); +use Apache::TestConfig (); + +use File::Spec::Functions qw(catfile); +use File::Find; + +sub new { + my $class = shift; + bless { @_ }, $class; +} + +# generate t/REPORT script (or a different filename) which will drive +# Apache::TestReport +sub generate_script { + my ($class, $file) = @_; + + $file ||= catfile 't', 'REPORT'; + + my $content = join "\n", + "BEGIN { eval { require blib && blib->import; } }", + Apache::TestConfig->perlscript_header, + "use $class;", + "$class->new(\@ARGV)->run;"; + + Apache::Test::basic_config()->write_perlscript($file, $content); +} + +sub replace { + my($self, $template) = @_; + + $template =~ s{\@(\w+)\@} { + my $method = lc $1; + eval { $self->$method() } || $self->{$1} || ''; + }eg; + + $template; +} + +sub run { + my $self = shift; + + print $self->replace($self->template); +} + +sub config { Apache::TestConfig::as_string() } + +sub report_to { 'test-dev@httpd.apache.org' } + +sub postit_note { + my $self = shift; + + my($to, $where) = split '@', $self->report_to; + + return <<EOF; +Note: Complete the rest of the details and post this bug report to +$to <at> $where. To subscribe to the list send an empty +email to $to-subscribe\@$where. +EOF +} + +sub executable { $0 } + +my $core_dump; +sub core_dump { + my $self = shift; + + $core_dump = ""; + + if (eval { require Devel::GDB }) { + find(\&dump_core_file, 't') + } + + $core_dump || ' [CORE TRACE COMES HERE]'; +} + +sub dump_core_file { + return unless /^core(\.\d+)?$/; + + my $core = $_; + my $gdb = new Devel::GDB (); + my $test_config = Apache::TestConfig->new({thaw=>1}); + my $httpd = $test_config->{vars}->{httpd}; + + return unless defined $httpd; + + $core_dump .= join '', + $gdb->get("file $httpd"), + $gdb->get('sharedlibrary'), + $gdb->get("core $core"), + $gdb->get('info threads'), + $gdb->get('thread apply all bt'); +} + +sub date { scalar gmtime() . " GMT" } + +sub template { +<<'EOI' +-------------8<---------- Start Bug Report ------------8<---------- +1. Problem Description: + + [DESCRIBE THE PROBLEM HERE] + +2. Used Components and their Configuration: + +@CONFIG@ + +3. This is the core dump trace: (if you get a core dump): + +@CORE_DUMP@ + +This report was generated by @EXECUTABLE@ on @DATE@. + +-------------8<---------- End Bug Report --------------8<---------- + +@POSTIT_NOTE@ + +EOI + +} + +1; +__END__ + +=head1 NAME + +Apache::TestReport - A parent class for generating bug/success reports + +=head1 Synopsis + + use Apache::TestReport; + Apache::TestReport->new(@ARGV)->run; + +=head1 Description + +This class is used to generate a bug or a success report, providing +information about the system the code was running on. + +=head1 Overridable Methods + +=head2 config + +return the information about user's system + +=head2 report_to + +return a string containing the email address the report should be sent +to + +=head2 postit_note + +return a string to close the report with, e.g.: + + my($to, $where) = split '@', $self->report_to; + return <<EOF; + Note: Complete the rest of the details and post this bug report to + $to <at> $where. To subscribe to the list send an empty + email to $to-subscribe\@$where. + + +=cut + diff --git a/debian/perl-framework/Apache-Test/lib/Apache/TestReportPerl.pm b/debian/perl-framework/Apache-Test/lib/Apache/TestReportPerl.pm new file mode 100644 index 0000000..befd8ff --- /dev/null +++ b/debian/perl-framework/Apache-Test/lib/Apache/TestReportPerl.pm @@ -0,0 +1,40 @@ +# 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::TestReportPerl; + +use strict; +use warnings FATAL => 'all'; + +use Apache::TestReport (); +use ModPerl::Config (); + +# a subclass of Apache::TestReport that generates a bug report script +use vars qw(@ISA); +@ISA = qw(Apache::TestReport); + +sub config { + ModPerl::Config::as_string(); +} + +sub report_to { + my $self = shift; + my $pkg = ref $self; + die "you need to implement $pkg\::report_to() to return the " . + "contact email address of your project"; +} + +1; +__END__ diff --git a/debian/perl-framework/Apache-Test/lib/Apache/TestRequest.pm b/debian/perl-framework/Apache-Test/lib/Apache/TestRequest.pm new file mode 100644 index 0000000..55d32c8 --- /dev/null +++ b/debian/perl-framework/Apache-Test/lib/Apache/TestRequest.pm @@ -0,0 +1,1258 @@ +# 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::TestRequest; + +use strict; +use warnings FATAL => 'all'; + +BEGIN { + $ENV{PERL_LWP_USE_HTTP_10} = 1; # default to http/1.0 + $ENV{APACHE_TEST_HTTP_09_OK} ||= 0; # 0.9 responses are ok +} + +use Apache::Test (); +use Apache::TestConfig (); + +use Carp; + +use constant TRY_TIMES => 200; +use constant INTERP_KEY => 'X-PerlInterpreter'; +use constant UA_TIMEOUT => 60 * 10; #longer timeout for debugging + +my $have_lwp = 0; + +# APACHE_TEST_PRETEND_NO_LWP=1 pretends that LWP is not available so +# one can test whether the test suite survives if the user doesn't +# have lwp installed +unless ($ENV{APACHE_TEST_PRETEND_NO_LWP}) { + $have_lwp = eval { + require LWP::UserAgent; + require HTTP::Request::Common; + + unless (defined &HTTP::Request::Common::OPTIONS) { + package HTTP::Request::Common; + no strict 'vars'; + *OPTIONS = sub { _simple_req(OPTIONS => @_) }; + push @EXPORT, 'OPTIONS'; + } + 1; + }; +} + +unless ($have_lwp) { + require Apache::TestClient; +} + +sub has_lwp { $have_lwp } + +unless ($have_lwp) { + #need to define the shortcuts even though the wont be used + #so Perl can parse test scripts + @HTTP::Request::Common::EXPORT = qw(GET HEAD POST PUT OPTIONS); +} + +sub install_http11 { + eval { + die "no LWP" unless $have_lwp; + LWP->VERSION(5.60); #minimal version + require LWP::Protocol::http; + #LWP::Protocol::http10 is used by default + LWP::Protocol::implementor('http', 'LWP::Protocol::http'); + }; +} + +use vars qw(@EXPORT @ISA $RedirectOK $DebugLWP); + +require Exporter; +*import = \&Exporter::import; +@EXPORT = @HTTP::Request::Common::EXPORT; + +@ISA = qw(LWP::UserAgent); + +my $UA; +my $REDIR = $have_lwp ? undef : 1; +my $conn_opts = {}; + +sub module { + my $module = shift; + $Apache::TestRequest::Module = $module if $module; + $Apache::TestRequest::Module; +} + +sub scheme { + my $scheme = shift; + $Apache::TestRequest::Scheme = $scheme if $scheme; + $Apache::TestRequest::Scheme; +} + +sub module2path { + my $package = shift; + + # httpd (1.3 && 2) / winFU have problems when the first path's + # segment includes ':' (security precaution which breaks the rfc) + # so we can't use /TestFoo::bar as path_info + (my $path = $package) =~ s/::/__/g; + + return $path; +} + +sub module2url { + my $module = shift; + my $opt = shift || {}; + my $scheme = $opt->{scheme} || 'http'; + my $path = exists $opt->{path} ? $opt->{path} : module2path($module); + + module($module); + + my $config = Apache::Test::config(); + my $hostport = hostport($config); + + $path =~ s|^/||; + return "$scheme://$hostport/$path"; +} + +sub user_agent { + my $args = {@_}; + + if (delete $args->{reset}) { + $UA = undef; + } + + if (exists $args->{requests_redirectable}) { + my $redir = $args->{requests_redirectable}; + if (ref $redir and (@$redir > 1 or $redir->[0] ne 'POST')) { + # Set our internal flag if there's no LWP. + $REDIR = $have_lwp ? undef : 1; + } elsif ($redir) { + if ($have_lwp) { + $args->{requests_redirectable} = [ qw/GET HEAD POST/ ]; + $REDIR = undef; + } else { + # Set our internal flag. + $REDIR = 1; + } + } else { + # Make sure our internal flag is false if there's no LWP. + $REDIR = $have_lwp ? undef : 0; + } + } + + $args->{keep_alive} ||= $ENV{APACHE_TEST_HTTP11}; + + if ($args->{keep_alive}) { + install_http11(); + eval { + require LWP::Protocol::https; #https10 is the default + LWP::Protocol::implementor('https', 'LWP::Protocol::https'); + }; + } + + # in LWP 6, verify_hostname defaults to on, so SSL_ca_file + # needs to be set accordingly + if ($have_lwp and $LWP::VERSION >= 6.0 and not exists $args->{ssl_opts}->{SSL_ca_file}) { + my $vars = Apache::Test::vars(); + my $cafile = "$vars->{sslca}/$vars->{sslcaorg}/certs/ca.crt"; + $args->{ssl_opts}->{SSL_ca_file} = $cafile; + # IO::Socket:SSL raw socket compatibility + $conn_opts->{SSL_ca_file} = $cafile; + } + + eval { $UA ||= __PACKAGE__->new(%$args); }; +} + +sub user_agent_request_num { + my $res = shift; + $res->header('Client-Request-Num') || #lwp 5.60 + $res->header('Client-Response-Num'); #lwp 5.62+ +} + +sub user_agent_keepalive { + $ENV{APACHE_TEST_HTTP11} = shift; +} + +sub do_request { + my($ua, $method, $url, $callback) = @_; + my $r = HTTP::Request->new($method, resolve_url($url)); + my $response = $ua->request($r, $callback); + lwp_trace($response); +} + +sub hostport { + my $config = shift || Apache::Test::config(); + my $vars = $config->{vars}; + local $vars->{scheme} = + $Apache::TestRequest::Scheme || $vars->{scheme}; + my $hostport = $config->hostport; + + my $default_hostport = join ':', $vars->{servername}, $vars->{port}; + if (my $module = $Apache::TestRequest::Module) { + $hostport = $module eq 'default' + ? $default_hostport + : $config->{vhosts}->{$module}->{hostport}; + } + + $hostport || $default_hostport; +} + +sub resolve_url { + my $url = shift; + Carp::croak("no url passed") unless defined $url; + + return $url if $url =~ m,^(\w+):/,; + $url = "/$url" unless $url =~ m,^/,; + + my $vars = Apache::Test::vars(); + + local $vars->{scheme} = + $Apache::TestRequest::Scheme || $vars->{scheme} || 'http'; + + scheme_fixup($vars->{scheme}); + + my $hostport = hostport(); + + return "$vars->{scheme}://$hostport$url"; +} + +my %wanted_args = map {$_, 1} qw(username password realm content filename + redirect_ok cert); + +sub wanted_args { + \%wanted_args; +} + +sub redirect_ok { + my $self = shift; + if ($have_lwp) { + # Return user setting or let LWP handle it. + return $RedirectOK if defined $RedirectOK; + return $self->SUPER::redirect_ok(@_); + } + + # No LWP. We don't support redirect on POST. + return 0 if $self->method eq 'POST'; + # Return user setting or our internal calculation. + return $RedirectOK if defined $RedirectOK; + return $REDIR; +} + +my %credentials; + +#subclass LWP::UserAgent +sub new { + my $self = shift->SUPER::new(@_); + + lwp_debug(); #init from %ENV (set by Apache::TestRun) + + my $config = Apache::Test::config(); + if (my $proxy = $config->configure_proxy) { + #t/TEST -proxy + $self->proxy(http => "http://$proxy"); + } + + $self->timeout(UA_TIMEOUT); + + $self; +} + +sub credentials { + my $self = shift; + return $self->get_basic_credentials(@_); +} + +sub get_basic_credentials { + my($self, $realm, $uri, $proxy) = @_; + + for ($realm, '__ALL__') { + next unless $_ && $credentials{$_}; + return @{ $credentials{$_} }; + } + + return (undef,undef); +} + +sub vhost_socket { + my $module = shift; + local $Apache::TestRequest::Module = $module if $module; + + my $hostport = hostport(Apache::Test::config()); + + my($host, $port) = split ':', $hostport; + my(%args) = (PeerAddr => $host, PeerPort => $port); + + if ($module and ($module =~ /ssl/ || $module eq 'h2')) { + require IO::Socket::SSL; + # Add all conn_opts to args + map {$args{$_} = $conn_opts->{$_}} keys %{$conn_opts}; + return IO::Socket::SSL->new(%args, Timeout => UA_TIMEOUT); + } + else { + require IO::Socket; + return IO::Socket::INET->new(%args); + } +} + +#IO::Socket::SSL::getline does not correctly handle OpenSSL *_WANT_*. +#Could care less about performance here, just need a getline() +#that returns the same results with or without ssl. +#Inspired from Net::SSLeay::ssl_read_all(). +my %getline = ( + 'IO::Socket::SSL' => sub { + my $self = shift; + # _get_ssl_object in IO::Socket::SSL only meant for internal use! + # But we need to compensate for unsufficient getline impl there. + my $ssl = $self->_get_ssl_object; + my ($got, $rv, $errs); + my $reply = ''; + + while (1) { + ($got, $rv) = Net::SSLeay::read($ssl, 1); + if (! defined $got) { + my $err = Net::SSLeay::get_error($ssl, $rv); + if ($err != Net::SSLeay::ERROR_WANT_READ() and + $err != Net::SSLeay::ERROR_WANT_WRITE()) { + $errs = Net::SSLeay::print_errs('SSL_read'); + last; + } + next; + } + last if $got eq ''; # EOF + $reply .= $got; + last if $got eq "\n"; + } + + wantarray ? ($reply, $errs) : $reply; + }, +); + +sub getline { + my $sock = shift; + my $class = ref $sock; + my $method = $getline{$class} || 'getline'; + $sock->$method(); +} + +sub socket_trace { + my $sock = shift; + return unless $sock->can('get_peer_certificate'); + + #like having some -v info + my $cert = $sock->get_peer_certificate; + print "#Cipher: ", $sock->get_cipher, "\n"; + print "#Peer DN: ", $cert->subject_name, "\n"; +} + +sub prepare { + my $url = shift; + + if ($have_lwp) { + user_agent(); + $url = resolve_url($url); + } + else { + lwp_debug() if $ENV{APACHE_TEST_DEBUG_LWP}; + } + + my($pass, $keep) = Apache::TestConfig::filter_args(\@_, \%wanted_args); + + %credentials = (); + if (defined $keep->{username}) { + $credentials{$keep->{realm} || '__ALL__'} = + [$keep->{username}, $keep->{password}]; + } + if (defined(my $content = $keep->{content})) { + if ($content eq '-') { + $content = join '', <STDIN>; + } + elsif ($content =~ /^x(\d+)$/) { + $content = 'a' x $1; + } + push @$pass, content => $content; + } + if (exists $keep->{cert}) { + set_client_cert($keep->{cert}); + } + + return ($url, $pass, $keep); +} + +sub UPLOAD { + my($url, $pass, $keep) = prepare(@_); + + local $RedirectOK = exists $keep->{redirect_ok} + ? $keep->{redirect_ok} + : $RedirectOK; + + if ($keep->{filename}) { + return upload_file($url, $keep->{filename}, $pass); + } + else { + return upload_string($url, $keep->{content}); + } +} + +sub UPLOAD_BODY { + UPLOAD(@_)->content; +} + +sub UPLOAD_BODY_ASSERT { + content_assert(UPLOAD(@_)); +} + +#lwp only supports files +sub upload_string { + my($url, $data) = @_; + + my $CRLF = "\015\012"; + my $bound = 742617000027; + my $req = HTTP::Request->new(POST => $url); + + my $content = join $CRLF, + "--$bound", + "Content-Disposition: form-data; name=\"HTTPUPLOAD\"; filename=\"b\"", + "Content-Type: text/plain", "", + $data, "--$bound--", ""; + + $req->header("Content-Length", length($content)); + $req->content_type("multipart/form-data; boundary=$bound"); + $req->content($content); + + $UA->request($req); +} + +sub upload_file { + my($url, $file, $args) = @_; + + my $content = [@$args, filename => [$file]]; + + $UA->request(HTTP::Request::Common::POST($url, + Content_Type => 'form-data', + Content => $content, + )); +} + +#useful for POST_HEAD and $DebugLWP (see below) +sub lwp_as_string { + my($r, $want_body) = @_; + my $content = $r->content; + + unless ($r->isa('HTTP::Request') or + $r->header('Content-Length') or + $r->header('Transfer-Encoding')) + { + $r->header('Content-Length' => length $content); + $r->header('X-Content-length-note' => 'added by Apache::TestRequest'); + } + + $r->content('') unless $want_body; + + (my $string = $r->as_string) =~ s/^/\#/mg; + $r->content($content); #reset + $string; +} + +$DebugLWP = 0; #1 == print METHOD URL and header response for all requests + #2 == #1 + response body + #other == passed to LWP::Debug->import + +sub lwp_debug { + package main; #wtf: else package in perldb changes + my $val = $_[0] || $ENV{APACHE_TEST_DEBUG_LWP}; + + return unless $val; + + if ($val =~ /^\d+$/) { + $Apache::TestRequest::DebugLWP = $val; + return "\$Apache::TestRequest::DebugLWP = $val\n"; + } + else { + my(@args) = @_ ? @_ : split /\s+/, $val; + require LWP::Debug; + LWP::Debug->import(@args); + return "LWP::Debug->import(@args)\n"; + } +} + +sub lwp_trace { + my $r = shift; + + unless ($r->request->protocol) { + #lwp always sends a request, but never sets + #$r->request->protocol, happens deeper in the + #LWP::Protocol::http* modules + my $proto = user_agent_request_num($r) ? "1.1" : "1.0"; + $r->request->protocol("HTTP/$proto"); + } + + my $want_body = $DebugLWP > 1; + print "#lwp request:\n", + lwp_as_string($r->request, $want_body); + + print "#server response:\n", + lwp_as_string($r, $want_body); +} + +sub lwp_call { + my($name, $shortcut) = (shift, shift); + + my $r = (\&{$name})->(@_); + + Carp::croak("$name(@_) didn't return a response object") unless $r; + + my $error = ""; + unless ($shortcut) { + #GET, HEAD, POST + if ($r->method eq "POST" && !defined($r->header("Content-Length"))) { + $r->header('Content-Length' => length($r->content)); + } + $r = $UA ? $UA->request($r) : $r; + my $proto = $r->protocol; + if (defined($proto)) { + if ($proto !~ /^HTTP\/(\d\.\d)$/) { + $error = "response had no protocol (is LWP broken or something?)"; + } + if ($1 ne "1.0" && $1 ne "1.1") { + $error = "response had protocol HTTP/$1 (headers not sent?)" + unless ($1 eq "0.9" && $ENV{APACHE_TEST_HTTP_09_OK}); + } + } + } + + if ($DebugLWP and not $shortcut) { + lwp_trace($r); + } + + Carp::croak($error) if $error; + + return $shortcut ? $r->$shortcut() : $r; +} + +my %shortcuts = (RC => sub { shift->code }, + OK => sub { shift->is_success }, + STR => sub { shift->as_string }, + HEAD => sub { lwp_as_string(shift, 0) }, + BODY => sub { shift->content }, + BODY_ASSERT => sub { content_assert(shift) }, +); + +for my $name (@EXPORT) { + my $package = $have_lwp ? + 'HTTP::Request::Common': 'Apache::TestClient'; + + my $method = join '::', $package, $name; + no strict 'refs'; + + next unless defined &$method; + + *$name = sub { + my($url, $pass, $keep) = prepare(@_); + local $RedirectOK = exists $keep->{redirect_ok} + ? $keep->{redirect_ok} + : $RedirectOK; + return lwp_call($method, undef, $url, @$pass); + }; + + while (my($shortcut, $cv) = each %shortcuts) { + my $alias = join '_', $name, $shortcut; + *$alias = sub { lwp_call($name, $cv, @_) }; + } +} + +my @export_std = @EXPORT; +for my $method (@export_std) { + push @EXPORT, map { join '_', $method, $_ } keys %shortcuts; +} + +push @EXPORT, qw(UPLOAD UPLOAD_BODY UPLOAD_BODY_ASSERT); + +sub to_string { + my $obj = shift; + ref($obj) ? $obj->as_string : $obj; +} + +# request an interpreter instance and use this interpreter id to +# select the same interpreter in requests below +sub same_interp_tie { + my($url) = @_; + + my $res = GET($url, INTERP_KEY, 'tie'); + unless ($res->code == 200) { + die sprintf "failed to init the same_handler data (url=%s). " . + "Failed with code=%s, response:\n%s", + $url, $res->code, $res->content; + } + my $same_interp = $res->header(INTERP_KEY); + + return $same_interp; +} + +# run the request though the selected perl interpreter, by polling +# until we found it +# currently supports only GET, HEAD, PUT, POST subs +sub same_interp_do { + my($same_interp, $sub, $url, @args) = @_; + + die "must pass an interpreter id, obtained via same_interp_tie()" + unless defined $same_interp and $same_interp; + + push @args, (INTERP_KEY, $same_interp); + + my $res = ''; + my $times = 0; + my $found_same_interp = ''; + do { + #loop until we get a response from our interpreter instance + $res = $sub->($url, @args); + die "no result" unless $res; + my $code = $res->code; + if ($code == 200) { + $found_same_interp = $res->header(INTERP_KEY) || ''; + } + elsif ($code == 404) { + # try again + } + else { + die sprintf "failed to run the request (url=%s):\n" . + "code=%s, response:\n%s", $url, $code, $res->content; + } + + unless ($found_same_interp eq $same_interp) { + $found_same_interp = ''; + } + + if ($times++ > TRY_TIMES) { #prevent endless loop + die "unable to find interp $same_interp\n"; + } + } until ($found_same_interp); + + return $found_same_interp ? $res : undef; +} + + +sub set_client_cert { + my $name = shift; + my $vars = Apache::Test::vars(); + my $dir = join '/', $vars->{sslca}, $vars->{sslcaorg}; + + if ($name) { + my ($cert, $key) = ("$dir/certs/$name.crt", "$dir/keys/$name.pem"); + # IO::Socket:SSL raw socket compatibility + $conn_opts->{SSL_cert_file} = $cert; + $conn_opts->{SSL_key_file} = $key; + if ($LWP::VERSION >= 6.0) { + # IO::Socket:SSL doesn't look at environment variables + if ($UA) { + $UA->ssl_opts(SSL_cert_file => $cert); + $UA->ssl_opts(SSL_key_file => $key); + } else { + user_agent(ssl_opts => { SSL_cert_file => $cert, + SSL_key_file => $key }); + } + } + } + else { + # IO::Socket:SSL raw socket compatibility + $conn_opts->{SSL_cert_file} = undef; + $conn_opts->{SSL_key_file} = undef; + if ($LWP::VERSION >= 6.0 and $UA) { + $UA->ssl_opts(SSL_cert_file => undef); + $UA->ssl_opts(SSL_key_file => undef); + } + } +} + +# Only for IO::Socket:SSL raw socket compatibility, +# when using user_agent() already done in its +# constructor. +sub set_ca_cert { + my $vars = Apache::Test::vars(); + my $cafile = "$vars->{sslca}/$vars->{sslcaorg}/certs/ca.crt"; + $conn_opts->{SSL_ca_file} = $cafile; +} + +#want news: urls to work with the LWP shortcuts +#but cant find a clean way to override the default nntp port +#by brute force we trick Net::NTTP into calling FixupNNTP::new +#instead of IO::Socket::INET::new, we fixup the args then forward +#to IO::Socket::INET::new + +#also want KeepAlive on for Net::HTTP +#XXX libwww-perl 5.53_xx has: LWP::UserAgent->new(keep_alive => 1); + +sub install_net_socket_new { + my($module, $code) = @_; + + return unless Apache::Test::have_module($module); + + no strict 'refs'; + + my $new; + my $isa = \@{"$module\::ISA"}; + + for (@$isa) { + last if $new = $_->can('new'); + } + + my $fixup_class = "Apache::TestRequest::$module"; + unshift @$isa, $fixup_class; + + *{"$fixup_class\::new"} = sub { + my $class = shift; + my $args = {@_}; + $code->($args); + return $new->($class, %$args); + }; +} + +my %scheme_fixups = ( + 'news' => sub { + return if $INC{'Net/NNTP.pm'}; + eval { + install_net_socket_new('Net::NNTP' => sub { + my $args = shift; + my($host, $port) = split ':', + Apache::TestRequest::hostport(); + $args->{PeerPort} = $port; + $args->{PeerAddr} = $host; + }); + }; + }, +); + +sub scheme_fixup { + my $scheme = shift; + my $fixup = $scheme_fixups{$scheme}; + return unless $fixup; + $fixup->(); +} + +# when the client side simply prints the response body which should +# include the test's output, we need to make sure that the request +# hasn't failed, or the test will be skipped instead of indicating the +# error. +sub content_assert { + my $res = shift; + + return $res->content if $res->is_success; + + die join "\n", + "request has failed (the response code was: " . $res->code . ")", + "see t/logs/error_log for more details\n"; +} + +1; + +=head1 NAME + +Apache::TestRequest - Send requests to your Apache test server + +=head1 SYNOPSIS + + use Apache::Test qw(ok have_lwp); + use Apache::TestRequest qw(GET POST); + use Apache::Constants qw(HTTP_OK); + + plan tests => 1, have_lwp; + + my $res = GET '/test.html'; + ok $res->code == HTTP_OK, "Request is ok"; + +=head1 DESCRIPTION + +B<Apache::TestRequest> provides convenience functions to allow you to +make requests to your Apache test server in your test scripts. It +subclasses C<LWP::UserAgent>, so that you have access to all if its +methods, but also exports a number of useful functions likely useful +for majority of your test requests. Users of the old C<Apache::test> +(or C<Apache::testold>) module, take note! Herein lie most of the +functions you'll need to use to replace C<Apache::test> in your test +suites. + +Each of the functions exported by C<Apache::TestRequest> uses an +C<LWP::UserAgent> object to submit the request and retrieve its +results. The return value for many of these functions is an +HTTP::Response object. See L<HTTP::Response|HTTP::Response> for +documentation of its methods, which you can use in your tests. For +example, use the C<code()> and C<content()> methods to test the +response code and content of your request. Using C<GET>, you can +perform a couple of tests using these methods like this: + + use Apache::Test qw(ok have_lwp); + use Apache::TestRequest qw(GET POST); + use Apache::Constants qw(HTTP_OK); + + plan tests => 2, have_lwp; + + my $uri = "/test.html?foo=1&bar=2"; + my $res = GET $uri; + ok $res->code == HTTP_OK, "Check that the request was OK"; + ok $res->content eq "foo => 1, bar => 2", "Check its content"; + +Note that you can also use C<Apache::TestRequest> with +C<Test::Builder> and its derivatives, including C<Test::More>: + + use Test::More; + # ... + is $res->code, HTTP_OK, "Check that the request was OK"; + is $res->content, "foo => 1, bar => 2", "Check its content"; + +=head1 CONFIGURATION FUNCTION + +You can tell C<Apache::TestRequest> what kind of C<LWP::UserAgent> +object to use for its convenience functions with C<user_agent()>. This +function uses its arguments to construct an internal global +C<LWP::UserAgent> object that will be used for all subsequent requests +made by the convenience functions. The arguments it takes are the same +as for the C<LWP::UserAgent> constructor. See the +C<L<LWP::UserAgent|LWP::UserAgent>> documentation for a complete list. + +The C<user_agent()> function only creates the internal +C<LWP::UserAgent> object the first time it is called. Since this +function is called internally by C<Apache::TestRequest>, you should +always use the C<reset> parameter to force it to create a new global +C<LWP::UserAgent> Object: + + Apache::TestRequest::user_agent(reset => 1, %params); + +C<user_agent()> differs from C<< LWP::UserAgent->new >> in two +additional ways. First, it supports an additional parameter, +C<keep_alive>, which enables connection persistence, where the same +connection is used to process multiple requests (and, according to the +C<L<LWP::UserAgent|LWP::UserAgent>> documentation, has the effect of +loading and enabling the new experimental HTTP/1.1 protocol module). + +And finally, the semantics of the C<requests_redirectable> parameter is +different than for C<LWP::UserAgent> in that you can pass it a boolean +value as well as an array for C<LWP::UserAgent>. To force +C<Apache::TestRequest> not to follow redirects in any of its convenience +functions, pass a false value to C<requests_redirectable>: + + Apache::TestRequest::user_agent(reset => 1, + requests_redirectable => 0); + +If LWP is not installed, then you can still pass in an array reference +as C<LWP::UserAgent> expects. C<Apache::TestRequest> will examine the +array and allow redirects if the array contains more than one value or +if there is only one value and that value is not "POST": + + # Always allow redirection. + my $redir = have_lwp() ? [qw(GET HEAD POST)] : 1; + Apache::TestRequest::user_agent(reset => 1, + requests_redirectable => $redir); + +But note that redirection will B<not> work with C<POST> unless LWP is +installed. It's best, therefore, to check C<have_lwp> before running +tests that rely on a redirection from C<POST>. + +Sometimes it is desireable to have C<Apache::TestRequest> remember +cookies sent by the pages you are testing and send them back to the +server on subsequent requests. This is especially necessary when +testing pages whose functionality relies on sessions or the presence +of preferences stored in cookies. + +By default, C<LWP::UserAgent> does B<not> remember cookies between +requests. You can tell it to remember cookies between request by +adding: + + Apache::TestRequest::user_agent(cookie_jar => {}); + +before issuing the requests. + + +=head1 FUNCTIONS + +C<Apache::TestRequest> exports a number of functions that will likely +prove convenient for use in the majority of your request tests. + + + + +=head2 Optional Parameters + +Each function also takes a number of optional arguments. + +=over 4 + +=item redirect_ok + +By default a request will follow redirects retrieved from the server. To +prevent this behavior, pass a false value to a C<redirect_ok> +parameter: + + my $res = GET $uri, redirect_ok => 0; + +Alternately, if all of your tests need to disable redirects, tell +C<Apache::TestRequest> to use an C<LWP::UserAgent> object that +disables redirects: + + Apache::TestRequest::user_agent( reset => 1, + requests_redirectable => 0 ); + +=item cert + +If you need to force an SSL request to use a particular SSL +certificate, pass the name of the certificate via the C<cert> +parameter: + + my $res = GET $uri, cert => 'my_cert'; + +=item content + +If you need to add content to your request, use the C<content> +parameter: + + my $res = GET $uri, content => 'hello world!'; + +=item filename + +The name of a local file on the file system to be sent to the Apache +test server via C<UPLOAD()> and its friends. + +=back + +=head2 The Functions + +=head3 GET + + my $res = GET $uri; + +Sends a simple GET request to the Apache test server. Returns an +C<HTTP::Response> object. + +You can also supply additional headers to be sent with the request by +adding their name/value pairs after the C<url> parameter, for example: + + my $res = GET $url, 'Accept-Language' => 'de,en-us,en;q=0.5'; + +=head3 GET_STR + +A shortcut function for C<GET($uri)-E<gt>as_string>. + +=head3 GET_BODY + +A shortcut function for C<GET($uri)-E<gt>content>. + +=head3 GET_BODY_ASSERT + +Use this function when your test is outputting content that you need +to check, and you want to make sure that the request was successful +before comparing the contents of the request. If the request was +unsuccessful, C<GET_BODY_ASSERT> will return an error +message. Otherwise it will simply return the content of the request +just as C<GET_BODY> would. + +=head3 GET_OK + +A shortcut function for C<GET($uri)-E<gt>is_success>. + +=head3 GET_RC + +A shortcut function for C<GET($uri)-E<gt>code>. + +=head3 GET_HEAD + +Throws out the content of the request, and returns the string +representation of the request. Since the body has been thrown out, the +representation will consist solely of the headers. Furthermore, +C<GET_HEAD> inserts a "#" at the beginning of each line of the return +string, so that the contents are suitable for printing to STDERR +during your tests without interfering with the workings of +C<Test::Harness>. + +=head3 HEAD + + my $res = HEAD $uri; + +Sends a HEAD request to the Apache test server. Returns an +C<HTTP::Response> object. + +=head3 HEAD_STR + +A shortcut function for C<HEAD($uri)-E<gt>as_string>. + +=head3 HEAD_BODY + +A shortcut function for C<HEAD($uri)-E<gt>content>. Of course, this +means that it will likely return nothing. + +=head3 HEAD_BODY_ASSERT + +Use this function when your test is outputting content that you need +to check, and you want to make sure that the request was successful +before comparing the contents of the request. If the request was +unsuccessful, C<HEAD_BODY_ASSERT> will return an error +message. Otherwise it will simply return the content of the request +just as C<HEAD_BODY> would. + +=head3 HEAD_OK + +A shortcut function for C<GET($uri)-E<gt>is_success>. + +=head3 HEAD_RC + +A shortcut function for C<GET($uri)-E<gt>code>. + +=head3 HEAD_HEAD + +Throws out the content of the request, and returns the string +representation of the request. Since the body has been thrown out, the +representation will consist solely of the headers. Furthermore, +C<GET_HEAD> inserts a "#" at the beginning of each line of the return +string, so that the contents are suitable for printing to STDERR +during your tests without interfering with the workings of +C<Test::Harness>. + +=head3 PUT + + my $res = PUT $uri; + +Sends a simple PUT request to the Apache test server. Returns an +C<HTTP::Response> object. + +=head3 PUT_STR + +A shortcut function for C<PUT($uri)-E<gt>as_string>. + +=head3 PUT_BODY + +A shortcut function for C<PUT($uri)-E<gt>content>. + +=head3 PUT_BODY_ASSERT + +Use this function when your test is outputting content that you need +to check, and you want to make sure that the request was successful +before comparing the contents of the request. If the request was +unsuccessful, C<PUT_BODY_ASSERT> will return an error +message. Otherwise it will simply return the content of the request +just as C<PUT_BODY> would. + +=head3 PUT_OK + +A shortcut function for C<PUT($uri)-E<gt>is_success>. + +=head3 PUT_RC + +A shortcut function for C<PUT($uri)-E<gt>code>. + +=head3 PUT_HEAD + +Throws out the content of the request, and returns the string +representation of the request. Since the body has been thrown out, the +representation will consist solely of the headers. Furthermore, +C<PUT_HEAD> inserts a "#" at the beginning of each line of the return +string, so that the contents are suitable for printing to STDERR +during your tests without interfering with the workings of +C<Test::Harness>. + +=head3 POST + + my $res = POST $uri, [ arg => $val, arg2 => $val ]; + +Sends a POST request to the Apache test server and returns an +C<HTTP::Response> object. An array reference of parameters passed as +the second argument will be submitted to the Apache test server as the +POST content. Parameters corresponding to those documented in +L<Optional Parameters|/Optional +Parameters> can follow the optional array reference of parameters, or after +C<$uri>. + +To upload a chunk of data, simply use: + + my $res = POST $uri, content => $data; + +=head3 POST_STR + +A shortcut function for C<POST($uri, @args)-E<gt>content>. + +=head3 POST_BODY + +A shortcut function for C<POST($uri, @args)-E<gt>content>. + +=head3 POST_BODY_ASSERT + +Use this function when your test is outputting content that you need +to check, and you want to make sure that the request was successful +before comparing the contents of the request. If the request was +unsuccessful, C<POST_BODY_ASSERT> will return an error +message. Otherwise it will simply return the content of the request +just as C<POST_BODY> would. + +=head3 POST_OK + +A shortcut function for C<POST($uri, @args)-E<gt>is_success>. + +=head3 POST_RC + +A shortcut function for C<POST($uri, @args)-E<gt>code>. + +=head3 POST_HEAD + +Throws out the content of the request, and returns the string +representation of the request. Since the body has been thrown out, the +representation will consist solely of the headers. Furthermore, +C<POST_HEAD> inserts a "#" at the beginning of each line of the return +string, so that the contents are suitable for printing to STDERR +during your tests without interfering with the workings of +C<Test::Harness>. + +=head3 UPLOAD + + my $res = UPLOAD $uri, \@args, filename => $filename; + +Sends a request to the Apache test server that includes an uploaded +file. Other POST parameters can be passed as a second argument as an +array reference. + +C<Apache::TestRequest> will read in the contents of the file named via +the C<filename> parameter for submission to the server. If you'd +rather, you can submit use the C<content> parameter instead of +C<filename>, and its value will be submitted to the Apache server as +file contents: + + my $res = UPLOAD $uri, undef, content => "This is file content"; + +The name of the file sent to the server will simply be "b". Note that +in this case, you cannot pass other POST arguments to C<UPLOAD()> -- +they would be ignored. + +=head3 UPLOAD_BODY + +A shortcut function for C<UPLOAD($uri, @params)-E<gt>content>. + +=head3 UPLOAD_BODY_ASSERT + +Use this function when your test is outputting content that you need +to check, and you want to make sure that the request was successful +before comparing the contents of the request. If the request was +unsuccessful, C<UPLOAD_BODY_ASSERT> will return an error +message. Otherwise it will simply return the content of the request +just as C<UPLOAD_BODY> would. + +=head3 OPTIONS + + my $res = OPTIONS $uri; + +Sends an C<OPTIONS> request to the Apache test server. Returns an +C<HTTP::Response> object with the I<Allow> header, indicating which +methods the server supports. Possible methods include C<OPTIONS>, +C<GET>, C<HEAD> and C<POST>. This function thus can be useful for +testing what options the Apache server supports. Consult the HTTPD 1.1 +specification, section 9.2, at +I<http://www.faqs.org/rfcs/rfc2616.html> for more information. + + + + + +=head2 URL Manipulation Functions + +C<Apache::TestRequest> also includes a few helper functions to aid in +the creation of urls used in the functions above. + + + +=head3 C<module2path> + + $path = Apache::TestRequest::module2path($module_name); + +Convert a module name to a path, safe for use in the various request +methods above. e.g. C<::> can't be used in URLs on win32. For example: + + $path = Apache::TestRequest::module2path('Foo::Bar'); + +returns: + + /Foo__Bar + + + + +=head3 C<module2url> + + $url = Apache::TestRequest::module2url($module); + $url = Apache::TestRequest::module2url($module, \%options); + +Convert a module name to a full URL including the current +configurations C<hostname:port> and sets C<module> accordingly. + + $url = Apache::TestRequest::module2url('Foo::Bar'); + +returns: + + http://$hostname:$port/Foo__Bar + +The default scheme used is C<http>. You can override this by passing +your preferred scheme into an optional second param. For example: + + $module = 'MyTestModule::TestHandler'; + $url = Apache::TestRequest::module2url($module, {scheme => 'https'}); + +returns: + + https://$hostname:$port/MyTestModule__TestHandler + +You may also override the default path with a path of your own: + + $module = 'MyTestModule::TestHandler'; + $url = Apache::TestRequest::module2url($module, {path => '/foo'}); + +returns: + + http://$hostname:$port/foo + + + + + +=head1 ENVIRONMENT VARIABLES + +The following environment variables can affect the behavior of +C<Apache::TestRequest>: + +=over + +=item APACHE_TEST_PRETEND_NO_LWP + +If the environment variable C<APACHE_TEST_PRETEND_NO_LWP> is set to a +true value, C<Apache::TestRequest> will pretend that LWP is not +available so one can test whether the test suite will survive on a +system which doesn't have libwww-perl installed. + +=item APACHE_TEST_HTTP_09_OK + +If the environment variable C<APACHE_TEST_HTTP_09_OK> is set to a +true value, C<Apache::TestRequest> will allow HTTP/0.9 responses +from the server to proceed. The default behavior is to die if +the response protocol is not either HTTP/1.0 or HTTP/1.1. + +=back + +=head1 SEE ALSO + +L<Apache::Test|Apache::Test> is the main Apache testing module. Use it +to set up your tests, create a plan, and to ensure that you have the +Apache version and modules you need. + +Use L<Apache::TestMM|Apache::TestMM> in your I<Makefile.PL> to set up +your distribution for testing. + +=head1 AUTHOR + +Doug MacEachern with contributions from Geoffrey Young, Philippe +M. Chiasson, Stas Bekman and others. Documentation by David Wheeler. + +Questions can be asked at the test-dev <at> httpd.apache.org list. For +more information see: I<http://httpd.apache.org/test/> and +I<http://perl.apache.org/docs/general/testing/testing.html>. diff --git a/debian/perl-framework/Apache-Test/lib/Apache/TestRun.pm b/debian/perl-framework/Apache-Test/lib/Apache/TestRun.pm new file mode 100644 index 0000000..f398eb5 --- /dev/null +++ b/debian/perl-framework/Apache-Test/lib/Apache/TestRun.pm @@ -0,0 +1,1220 @@ +# 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::TestRun; + +use strict; +use warnings FATAL => 'all'; + +use Apache::Test (); +use Apache::TestMM (); +use Apache::TestConfig (); +use Apache::TestConfigC (); +use Apache::TestRequest (); +use Apache::TestHarness (); +use Apache::TestTrace; + +use Cwd; +use ExtUtils::MakeMaker; +use File::Find qw(finddepth); +use File::Path; +use File::Spec::Functions qw(catfile catdir canonpath); +use File::Basename qw(basename dirname); +use Getopt::Long qw(GetOptions); +use Config; + +use constant IS_APACHE_TEST_BUILD => Apache::TestConfig::IS_APACHE_TEST_BUILD; + +use constant STARTUP_TIMEOUT => 300; # secs (good for extreme debug cases) + +use subs qw(exit_shell exit_perl); + +my $orig_command; +my $orig_cwd; +my $orig_conf_opts; + +my %core_files = (); + +my @std_run = qw(start-httpd run-tests stop-httpd); +my @others = qw(verbose configure clean help ssl http11 bugreport + save no-httpd one-process); +my @flag_opts = (@std_run, @others); +my @string_opts = qw(order trace); +my @ostring_opts = qw(proxy ping); +my @debug_opts = qw(debug); +my @list_opts = qw(preamble postamble breakpoint); +my @hash_opts = qw(header); +my @help_opts = qw(clean help); +my @request_opts = qw(get post head); + +my @exit_opts_no_need_httpd = (@help_opts); +my @exit_opts_need_httpd = (@debug_opts, qw(ping)); + +my %usage = ( + 'start-httpd' => 'start the test server', + 'run-tests' => 'run the tests', + 'order=mode' => 'run the tests in one of the modes: ' . + '(repeat|random|SEED)', + 'stop-httpd' => 'stop the test server', + 'no-httpd' => 'run the tests without configuring or starting httpd', + 'verbose[=1]' => 'verbose output', + 'configure' => 'force regeneration of httpd.conf ' . + ' (tests will not be run)', + 'clean' => 'remove all generated test files', + 'help' => 'display this message', + 'bugreport' => 'print the hint how to report problems', + 'preamble' => 'config to add at the beginning of httpd.conf', + 'postamble' => 'config to add at the end of httpd.conf', + 'ping[=block]' => 'test if server is running or port in use', + 'debug[=name]' => 'start server under debugger name (gdb, ddd, etc.)', + 'breakpoint=bp' => 'set breakpoints (multiply bp can be set)', + 'header' => "add headers to (" . + join('|', @request_opts) . ") request", + 'http11' => 'run all tests with HTTP/1.1 (keep alive) requests', + 'ssl' => 'run tests through ssl', + 'proxy' => 'proxy requests (default proxy is localhost)', + 'trace=T' => 'change tracing default to: warning, notice, ' . + 'info, debug, ...', + 'one-process' => 'run the server in single process mode', + (map { $_, "\U$_\E url" } @request_opts), +); + +sub fixup { + #make sure we use an absolute path to perl + #else Test::Harness uses the perl in our PATH + #which might not be the one we want + $^X = $Config{perlpath} unless -e $^X; +} + +# if the test suite was aborted because of a user-error we don't want +# to call the bugreport and invite users to submit a bug report - +# after all it's a user error. but we still want the program to fail, +# so raise this flag in such a case. +my $user_error = 0; +sub user_error { + my $self = shift; + $user_error = shift if @_; + $user_error; +} + +sub new { + my $class = shift; + + my $self = bless { + tests => [], + @_, + }, $class; + + $self->fixup; + + $self; +} + +#split arguments into test files/dirs and options +#take extra care if -e, the file matches /\.t$/ +# if -d, the dir contains .t files +#so we dont slurp arguments that are not tests, example: +# httpd $HOME/apache-2.0/bin/httpd + +sub split_test_args { + my($self) = @_; + + my(@tests); + my $top_dir = $self->{test_config}->{vars}->{top_dir}; + my $t_dir = $self->{test_config}->{vars}->{t_dir}; + + my $argv = $self->{argv}; + my @leftovers = (); + for (@$argv) { + my $arg = $_; + # need the t/ (or t\) for stat-ing, but don't want to include + # it in test output + $arg =~ s@^(?:\.[\\/])?t[\\/]@@; + my $file = catfile $t_dir, $arg; + if (-d $file and $_ ne '/') { + my @files = <$file/*.t>; + my $remove = catfile $top_dir, ""; + if (@files) { + push @tests, map { s,^\Q$remove,,; $_ } @files; + next; + } + } + else { + if ($file =~ /\.t$/ and -e $file) { + push @tests, "t/$arg"; + next; + } + elsif (-e "$file.t") { + push @tests, "t/$arg.t"; + next; + } + elsif (/^[\d.]+$/) { + my @t = $_; + #support range of subtests: t/TEST t/foo/bar 60..65 + if (/^(\d+)\.\.(\d+)$/) { + @t = $1..$2; + } + + push @{ $self->{subtests} }, @t; + next; + } + } + push @leftovers, $_; + } + + $self->{tests} = [ map { canonpath($_) } @tests ]; + $self->{argv} = \@leftovers; +} + +sub die_on_invalid_args { + my($self) = @_; + + # at this stage $self->{argv} should be empty + my @invalid_argv = @{ $self->{argv} }; + if (@invalid_argv) { + error "unknown opts or test names: @invalid_argv\n" . + "-help will list options\n"; + exit_perl 0; + } + +} + +sub passenv { + my $passenv = Apache::TestConfig->passenv; + for (keys %$passenv) { + return 1 if $ENV{$_}; + } + 0; +} + +sub getopts { + my($self, $argv) = @_; + + local *ARGV = $argv; + my(%opts, %vopts, %conf_opts); + + # a workaround to support -verbose and -verbose=0|1 + # $Getopt::Long::VERSION > 2.26 can use the "verbose:1" rule + # but we have to support older versions as well + @ARGV = grep defined, + map {/-verbose=(\d)/ ? ($1 ? '-verbose' : undef) : $_ } @ARGV; + + # permute : optional values can come before the options + # pass_through : all unknown things are to be left in @ARGV + Getopt::Long::Configure(qw(pass_through permute)); + + # grab from @ARGV only the options that we expect + GetOptions(\%opts, @flag_opts, @help_opts, + (map "$_:s", @debug_opts, @request_opts, @ostring_opts), + (map "$_=s", @string_opts), + (map { ("$_=s", $vopts{$_} ||= []) } @list_opts), + (map { ("$_=s", $vopts{$_} ||= {}) } @hash_opts)); + + $opts{$_} = $vopts{$_} for keys %vopts; + + # separate configuration options and test files/dirs + my $req_wanted_args = Apache::TestRequest::wanted_args(); + my @argv = (); + my %req_args = (); + + while (@ARGV) { + my $val = shift @ARGV; + if ($val =~ /^--?(.+)/) { # must have a leading - or -- + my $key = lc $1; + # a known config option? + if (exists $Apache::TestConfig::Usage{$key}) { + $conf_opts{$key} = shift @ARGV; + next; + } # a TestRequest config option? + elsif (exists $req_wanted_args->{$key}) { + $req_args{$key} = shift @ARGV; + next; + } + } + # to be processed later + push @argv, $val; + } + + # save the orig args (make a deep copy) + $orig_conf_opts = { %conf_opts }; + + # fixup the filepath options on win32 (spaces, short names, etc.) + if (Apache::TestConfig::WIN32) { + for my $key (keys %conf_opts) { + next unless Apache::TestConfig::conf_opt_is_a_filepath($key); + next unless -e $conf_opts{$key}; + $conf_opts{$key} = Win32::GetShortPathName($conf_opts{$key}); + } + } + + $opts{req_args} = \%req_args; + + # only test files/dirs if any at all are left in argv + $self->{argv} = \@argv; + + # force regeneration of httpd.conf if commandline args want to + # modify it. configure_opts() has more checks to decide whether to + # reconfigure or not. + # XXX: $self->passenv() is already tested in need_reconfiguration() + $self->{reconfigure} = $opts{configure} || + (grep { $opts{$_}->[0] } qw(preamble postamble)) || + (grep { $Apache::TestConfig::Usage{$_} } keys %conf_opts ) || + $self->passenv() || (! -e 't/conf/httpd.conf'); + + if (exists $opts{debug}) { + $opts{debugger} = $opts{debug}; + $opts{debug} = 1; + } + + if ($opts{trace}) { + my %levels = map {$_ => 1} @Apache::TestTrace::Levels; + if (exists $levels{ $opts{trace} }) { + $Apache::TestTrace::Level = $opts{trace}; + # propogate the override for the server-side. + # -trace overrides any previous APACHE_TEST_TRACE_LEVEL settings + $ENV{APACHE_TEST_TRACE_LEVEL} = $opts{trace}; + } + else { + error "unknown trace level: $opts{trace}", + "valid levels are: @Apache::TestTrace::Levels"; + exit_perl 0; + } + } + + # breakpoint automatically turns the debug mode on + if (@{ $opts{breakpoint} }) { + $opts{debug} ||= 1; + } + + if ($self->{reconfigure}) { + $conf_opts{save} = 1; + delete $self->{reconfigure}; + } + else { + $conf_opts{thaw} = 1; + } + + #propagate some values + for (qw(verbose)) { + $conf_opts{$_} = $opts{$_}; + } + + $self->{opts} = \%opts; + $self->{conf_opts} = \%conf_opts; +} + +sub default_run_opts { + my $self = shift; + my($opts, $tests) = ($self->{opts}, $self->{tests}); + + unless (grep { exists $opts->{$_} } @std_run, @request_opts) { + if (@$tests && $self->{server}->ping) { + # if certain tests are specified and server is running, + # dont restart + $opts->{'run-tests'} = 1; + } + else { + #default is start-server run-tests stop-server + $opts->{$_} = 1 for @std_run; + } + } + + $opts->{'run-tests'} ||= @$tests; +} + +my $parent_pid = $$; +sub is_parent { $$ == $parent_pid } + +my $caught_sig_int = 0; + +sub install_sighandlers { + my $self = shift; + + my($server, $opts) = ($self->{server}, $self->{opts}); + + $SIG{__DIE__} = sub { + return unless $_[0] =~ /^Failed/i; #dont catch Test::ok failures + + # _show_results() calls die() under a few conditions, such as + # when no tests are run or when tests fail. make sure the message + # is propagated back to the user. + print $_[0] if (caller(1))[3]||'' eq 'Test::Harness::_show_results'; + + $server->stop(1) if $opts->{'start-httpd'}; + $server->failed_msg("error running tests"); + exit_perl 0; + }; + + $SIG{INT} = sub { + if ($caught_sig_int++) { + warning "\ncaught SIGINT"; + exit_perl 0; + } + warning "\nhalting tests"; + $server->stop if $opts->{'start-httpd'}; + exit_perl 0; + }; + + #try to make sure we scan for core no matter what happens + #must eval "" to "install" this END block, otherwise it will + #always run, a subclass might not want that + eval 'END { + return unless is_parent(); # because of fork + $self ||= + Apache::TestRun->new(test_config => Apache::TestConfig->thaw); + { + local $?; # preserve the exit status + eval { + $self->scan_core; + }; + } + $self->try_bug_report(); + }'; + die "failed: $@" if $@; + +} + +sub try_bug_report { + my $self = shift; + if ($? && !$self->user_error && + $self->{opts}->{bugreport} && $self->can('bug_report')) { + $self->bug_report; + } +} + +#throw away cached config and start fresh +sub refresh { + my $self = shift; + $self->opt_clean(1); + $self->{conf_opts}->{save} = delete $self->{conf_opts}->{thaw} || 1; + $self->{test_config} = $self->new_test_config()->httpd_config; + $self->{test_config}->{server}->{run} = $self; + $self->{server} = $self->{test_config}->server; +} + +sub configure_opts { + my $self = shift; + my $save = shift; + my $refreshed = 0; + + my($test_config, $opts) = ($self->{test_config}, $self->{opts}); + + $test_config->{vars}->{scheme} = + $opts->{ssl} ? 'https' : + $self->{conf_opts}->{scheme} || 'http'; + + if ($opts->{http11}) { + $ENV{APACHE_TEST_HTTP11} = 1; + } + + # unless we are already reconfiguring, check for .conf.in files changes + if (!$$save && + (my @reasons = + $self->{test_config}->need_reconfiguration($self->{conf_opts}))) { + warning "forcing re-configuration:"; + warning "\t- $_." for @reasons; + unless ($refreshed) { + $self->refresh; + $refreshed = 1; + $test_config = $self->{test_config}; + } + } + + # unless we are already reconfiguring, check for -proxy + if (!$$save && exists $opts->{proxy}) { + my $max = $test_config->{vars}->{maxclients}; + $opts->{proxy} ||= 'on'; + + #if config is cached and MaxClients == 1, must reconfigure + if (!$$save and $opts->{proxy} eq 'on' and $max == 1) { + $$save = 1; + warning "server is reconfigured for proxy"; + unless ($refreshed) { + $self->refresh; + $refreshed = 1; + $test_config = $self->{test_config}; + } + } + + $test_config->{vars}->{proxy} = $opts->{proxy}; + } + else { + $test_config->{vars}->{proxy} = 'off'; + } + + return unless $$save; + + my $preamble = sub { shift->preamble($opts->{preamble}) }; + my $postamble = sub { shift->postamble($opts->{postamble}) }; + + $test_config->preamble_register($preamble); + $test_config->postamble_register($postamble); +} + +sub pre_configure { } + +sub configure { + my $self = shift; + + if ($self->{opts}->{'no-httpd'}) { + warning "skipping httpd configuration"; + return; + } + + # create the conf dir as early as possible + $self->{test_config}->prepare_t_conf(); + + my $save = \$self->{conf_opts}->{save}; + $self->configure_opts($save); + + my $config = $self->{test_config}; + unless ($$save) { + my $addr = \$config->{vars}->{remote_addr}; + my $remote_addr = $config->our_remote_addr; + unless ($$addr eq $remote_addr) { + warning "local ip address has changed, updating config cache"; + $$addr = $remote_addr; + } + #update minor changes to cached config + #without complete regeneration + #for example this allows switching between + #'t/TEST' and 't/TEST -ssl' + $config->sync_vars(qw(scheme proxy remote_addr)); + return; + } + + my $test_config = $self->{test_config}; + $test_config->sslca_generate; + $test_config->generate_ssl_conf if $self->{opts}->{ssl}; + $test_config->cmodules_configure; + $test_config->generate_httpd_conf; + $test_config->save; + +} + +sub try_exit_opts { + my $self = shift; + my @opts = @_; + + for (@opts) { + next unless exists $self->{opts}->{$_}; + my $method = "opt_$_"; + my $rc = $self->$method(); + exit_perl $rc if $rc; + } + + if ($self->{opts}->{'stop-httpd'}) { + my $ok = 1; + if ($self->{server}->ping) { + $ok = $self->{server}->stop; + $ok = $ok < 0 ? 0 : 1; # adjust to 0/1 logic + } + else { + warning "server $self->{server}->{name} is not running"; + # cleanup a stale pid file if found + my $pid_file = $self->{test_config}->{vars}->{t_pid_file}; + unlink $pid_file if -e $pid_file; + } + exit_perl $ok; + } +} + +sub start { + my $self = shift; + + my $opts = $self->{opts}; + my $server = $self->{server}; + + #if t/TEST -d is running make sure we don't try to stop/start the server + my $file = $server->debugger_file; + if (-e $file and $opts->{'start-httpd'}) { + if ($server->ping) { + warning "server is running under the debugger, " . + "defaulting to -run"; + $opts->{'start-httpd'} = $opts->{'stop-httpd'} = 0; + } + else { + warning "removing stale debugger note: $file"; + unlink $file; + } + } + + $self->check_runtime_user(); + + if ($opts->{'start-httpd'}) { + exit_perl 0 unless $server->start; + } + elsif ($opts->{'run-tests'}) { + my $is_up = $server->ping + || (exists $self->{opts}->{ping} + && $self->{opts}->{ping} eq 'block' + && $server->wait_till_is_up(STARTUP_TIMEOUT)); + unless ($is_up) { + error "server is not ready yet, try again."; + exit_perl 0; + } + } +} + +sub run_tests { + my $self = shift; + + my $test_opts = { + verbose => $self->{opts}->{verbose}, + tests => $self->{tests}, + order => $self->{opts}->{order}, + subtests => $self->{subtests} || [], + }; + + if (grep { exists $self->{opts}->{$_} } @request_opts) { + run_request($self->{test_config}, $self->{opts}); + } + else { + Apache::TestHarness->run($test_opts) + if $self->{opts}->{'run-tests'}; + } +} + +sub stop { + my $self = shift; + + return $self->{server}->stop if $self->{opts}->{'stop-httpd'}; +} + +sub new_test_config { + my $self = shift; + + Apache::TestConfig->new($self->{conf_opts}); +} + +sub set_ulimit_via_sh { + return if Apache::TestConfig::WINFU; + return if $ENV{APACHE_TEST_ULIMIT_SET}; + + # only root can allow unlimited core dumps on Solaris (8 && 9?) + if (Apache::TestConfig::SOLARIS) { + my $user = getpwuid($>) || ''; + if ($user ne 'root') { + warning "Skipping 'set unlimited ulimit for coredumps', " . + "since we are running as a non-root user on Solaris"; + return; + } + } + + my $binsh = '/bin/sh'; + return unless -e $binsh; + $ENV{APACHE_TEST_ULIMIT_SET} = 1; + + my $sh = Symbol::gensym(); + open $sh, "echo ulimit -a | $binsh|" or die; + local $_; + while (<$sh>) { + if (/^core.*unlimited$/) { + #already set to unlimited + $ENV{APACHE_TEST_ULIMIT_SET} = 1; + return; + } + } + close $sh; + + $orig_command = "ulimit -c unlimited; $orig_command"; + warning "setting ulimit to allow core files\n$orig_command"; + # use 'or die' to avoid warnings due to possible overrides of die + exec $orig_command or die "exec $orig_command has failed"; +} + +sub set_ulimit { + my $self = shift; + #return if $self->set_ulimit_via_bsd_resource; + eval { $self->set_ulimit_via_sh }; +} + +sub set_env { + #export some environment variables for t/modules/env.t + #(the values are unimportant) + $ENV{APACHE_TEST_HOSTNAME} = 'test.host.name'; + $ENV{APACHE_TEST_HOSTTYPE} = 'z80'; +} + +sub run { + my $self = shift; + + # assuming that test files are always in the same directory as the + # driving script, make it possible to run the test suite from any place + # use a full path, which will work after chdir (e.g. ./TEST) + $0 = File::Spec->rel2abs($0); + if (-e $0) { + my $top = dirname dirname $0; + chdir $top if $top and -d $top; + } + + # reconstruct argv, preserve multiwords args, eg 'PerlTrace all' + my $argv = join " ", map { /^-/ ? $_ : qq['$_'] } @ARGV; + $orig_command = "$^X $0 $argv"; + $orig_cwd = Cwd::cwd(); + $self->set_ulimit; + $self->set_env; #make sure these are always set + + $self->detect_relocation($orig_cwd); + + my(@argv) = @_; + + $self->getopts(\@argv); + + $self->pre_configure(); + + # can't setup the httpd-specific parts of the config object yet + $self->{test_config} = $self->new_test_config(); + + $self->warn_core(); + + # give TestServer access to our runtime configuration directives + # so we can tell the server stuff if we need to + $self->{test_config}->{server}->{run} = $self; + + $self->{server} = $self->{test_config}->server; + + local($SIG{__DIE__}, $SIG{INT}); + $self->install_sighandlers; + + $self->try_exit_opts(@exit_opts_no_need_httpd); + + # httpd is found here (unless it was already configured before) + $self->{test_config}->httpd_config(); + + $self->try_exit_opts(@exit_opts_need_httpd); + + if ($self->{opts}->{configure}) { + warning "cleaning out current configuration"; + $self->opt_clean(1); + } + + $self->split_test_args; + + $self->die_on_invalid_args; + + $self->default_run_opts; + + # if configure() fails for some reason before it has flushed the + # config to a file, save it so -clean will be able to clean + if ($self->{opts}->{'start-httpd'} || $self->{opts}->{'configure'}) { + eval { $self->configure }; + if ($@) { + error "configure() has failed:\n$@"; + warning "forcing Apache::TestConfig object save"; + $self->{test_config}->save; + warning "run 't/TEST -clean' to clean up before continuing"; + exit_perl 0; + } + } + + if ($self->{opts}->{configure}) { + warning "reconfiguration done"; + exit_perl 1; + } + + $self->start unless $self->{opts}->{'no-httpd'}; + + $self->run_tests; + + $self->stop unless $self->{opts}->{'no-httpd'}; +} + +sub rerun { + my $vars = shift; + + # in %$vars + # - httpd will be always set + # - apxs is optional + + $orig_cwd ||= Cwd::cwd(); + chdir $orig_cwd; + my $new_opts = " -httpd $vars->{httpd}"; + $new_opts .= " -apxs $vars->{apxs}" if $vars->{apxs}; + + my $new_command = $orig_command; + + # strip any old bogus -httpd/-apxs + $new_command =~ s/--?httpd\s+$orig_conf_opts->{httpd}// + if $orig_conf_opts->{httpd}; + $new_command =~ s/--?httpd\s+$orig_conf_opts->{httpd}// + if $orig_conf_opts->{httpd} and $vars->{apxs}; + + # add new opts + $new_command .= $new_opts; + + warning "running with new config opts: $new_command"; + + # use 'or die' to avoid warnings due to possible overrides of die + exec $new_command or die "exec $new_command has failed"; +} + + +# make it easy to move the whole distro w/o running +# 't/TEST -clean' before moving. when moving the whole package, +# the old cached config will stay, so we want to nuke it only if +# we realize that it's no longer valid. we can't just check the +# existance of the saved top_dir value, since the project may have +# been copied and the old dir could be still there, but that's not +# the one that we work in +sub detect_relocation { + my($self, $cur_top_dir) = @_; + + my $config_file = catfile qw(t conf apache_test_config.pm); + return unless -e $config_file; + + my %inc = %INC; + eval { require "$config_file" }; + %INC = %inc; # be stealth + warn($@), return if $@; + + my $cfg = 'apache_test_config'->new; + + # if the top_dir from saved config doesn't match the current + # top_dir, that means that the whole project was relocated to a + # different directory, w/o running t/TEST -clean first (in each + # directory with a test suite) + my $cfg_top_dir = $cfg->{vars}->{top_dir}; + return unless $cfg_top_dir; + return if $cfg_top_dir eq $cur_top_dir; + + # if that's the case silently fixup the saved config to use the + # new paths, and force a complete cleanup. if we don't fixup the + # config files, the cleanup process won't be able to locate files + # to delete and re-configuration will fail + { + # in place editing + local @ARGV = $config_file; + local $^I = ".bak"; # Win32 needs a backup + while (<>) { + s{$cfg_top_dir}{$cur_top_dir}g; + print; + } + unlink $config_file . $^I; + } + + my $cleanup_cmd = "$^X $0 -clean"; + warning "cleaning up the old config"; + # XXX: do we care to check success? + system $cleanup_cmd; + + # XXX: I tried hard to accomplish that w/o starting a new process, + # but too many things get on the way, so for now just keep it as an + # external process, as it's absolutely transparent to the normal + # app-run +} + +my @oh = qw(jeez golly gosh darn shucks dangit rats nuts dangnabit crap); +sub oh { + $oh[ rand scalar @oh ]; +} + +#e.g. t/core or t/core.12499 +my $core_pat = '^core(\.\d+)?' . "\$"; + +# $self->scan_core_incremental([$only_top_dir]) +# normally would be called after each test +# and since it updates the list of seen core files +# scan_core() won't report these again +# currently used in Apache::TestSmoke +# +# if $only_t_dir arg is true only the t_dir dir (t/) will be scanned +sub scan_core_incremental { + my($self, $only_t_dir) = @_; + my $vars = $self->{test_config}->{vars}; + + # no core files dropped on win32 + return () if Apache::TestConfig::WIN32; + + if ($only_t_dir) { + require IO::Dir; + my @cores = (); + for (IO::Dir->new($vars->{t_dir})->read) { + my $file = catfile $vars->{t_dir}, $_; + next unless -f $file; + next unless /$core_pat/o; + next if exists $core_files{$file} && + $core_files{$file} == -M $file; + $core_files{$file} = -M $file; + push @cores, $file; + } + return @cores + ? join "\n", "server dumped core, for stacktrace, run:", + map { "gdb $vars->{httpd} -core $_" } @cores + : (); + } + + my @msg = (); + finddepth({ no_chdir => 1, + wanted => sub { + return unless -f $_; + my $file = basename $File::Find::name; + return unless $file =~ /$core_pat/o; + my $core = $File::Find::name; + unless (exists $core_files{$core} && $core_files{$core} == -M $core) { + # new core file! + + # XXX: could rename the file if it doesn't include the pid + # in its name (i.e., just called 'core', instead of 'core.365') + + # XXX: could pass the test name and rename the core file + # to use that name as a suffix, plus pid, time or some + # other unique identifier, in case the same test is run + # more than once and each time it caused a segfault + $core_files{$core} = -M $core; + push @msg, "server dumped core, for stacktrace, run:\n" . + "gdb $vars->{httpd} -core $core"; + } + }}, $vars->{top_dir}); + + return @msg; + +} + +sub scan_core { + my $self = shift; + my $vars = $self->{test_config}->{vars}; + my $times = 0; + + # no core files dropped on win32 + return if Apache::TestConfig::WIN32; + + finddepth({ no_chdir => 1, + wanted => sub { + return unless -f $_; + my $file = basename $File::Find::name; + return unless $file =~ /$core_pat/o; + my $core = $File::Find::name; + if (exists $core_files{$core} && $core_files{$core} == -M $core) { + # we have seen this core file before the start of the test + info "an old core file has been found: $core"; + } + else { + my $oh = oh(); + my $again = $times++ ? "again" : ""; + error "oh $oh, server dumped core $again"; + error "for stacktrace, run: gdb $vars->{httpd} -core $core"; + } + }}, $vars->{top_dir}); +} + +# warn the user that there is a core file before the tests +# start. suggest to delete it before proceeding or a false alarm can +# be generated at the end of the test routine run. +sub warn_core { + my $self = shift; + my $vars = $self->{test_config}->{vars}; + %core_files = (); # reset global + + # no core files dropped on win32 + return if Apache::TestConfig::WIN32; + + finddepth(sub { + return unless -f $_; + return unless /$core_pat/o; + my $core = "$File::Find::dir/$_"; + info "consider removing an old $core file before running tests"; + # remember the timestamp of $core so we can check if it's the + # old core file at the end of the run and not complain then + $core_files{$core} = -M $core; + }, $vars->{top_dir}); +} + +# catch any attempts to ./t/TEST the tests as root user + +sub check_runtime_user { + my $self = shift; + + return if Apache::TestConfig::WINFU; + + my $user = getpwuid($>) || ''; + + if ($user eq 'root') { + error "Apache cannot spawn child processes as root, therefore the test suite must be run as a non-privileged user."; + exit_perl(1); + } + + return 1; +} + +sub run_request { + my($test_config, $opts) = @_; + + my @args = (%{ $opts->{header} }, %{ $opts->{req_args} }); + + my($request, $url) = ("", ""); + + for (@request_opts) { + next unless exists $opts->{$_}; + $url = $opts->{$_} if $opts->{$_}; + $request = join $request ? '_' : '', $request, $_; + } + + if ($request) { + my $method = \&{"Apache::TestRequest::\U$request"}; + my $res = $method->($url, @args); + print Apache::TestRequest::to_string($res); + } +} + +sub opt_clean { + my($self, $level) = @_; + my $test_config = $self->{test_config}; + $test_config->server->stop; + $test_config->clean($level); + 1; +} + +sub opt_ping { + my($self) = @_; + + my $test_config = $self->{test_config}; + my $server = $test_config->server; + my $pid = $server->ping; + my $name = $server->{name}; + # support t/TEST -ping=block -run ... + my $exit = not $self->{opts}->{'run-tests'}; + + if ($pid) { + if ($pid == -1) { + error "port $test_config->{vars}->{port} is in use, ". + "but cannot determine server pid"; + } + else { + my $version = $server->{version}; + warning "server $name running (pid=$pid, version=$version)"; + } + return $exit; + } + + if (exists $self->{opts}->{ping} && $self->{opts}->{ping} eq 'block') { + $server->wait_till_is_up(STARTUP_TIMEOUT); + } + else { + warning "no server is running on $name"; + exit_perl(0); + } + + return $exit; #means call exit() if true +} + +sub test_inc { + map { "$_/Apache-Test/lib" } qw(. ..); +} + +sub set_perl5lib { + $ENV{PERL5LIB} = join $Config{path_sep}, shift->test_inc(); +} + +sub set_perldb_opts { + my $config = shift->{test_config}; + my $file = catfile $config->{vars}->{t_logs}, 'perldb.out'; + $config->genfile($file); #mark for -clean + $ENV{PERLDB_OPTS} = "NonStop frame=4 AutoTrace LineInfo=$file"; + warning "perldb log is t/logs/perldb.out"; +} + +sub opt_debug { + my $self = shift; + my $server = $self->{server}; + + my $opts = $self->{opts}; + my $debug_opts = {}; + + for (qw(debugger breakpoint)) { + $debug_opts->{$_} = $opts->{$_}; + } + + if (my $db = $opts->{debugger}) { + if ($db =~ s/^perl=?//) { + $opts->{'run-tests'} = 1; + $self->start; #if not already running + $self->set_perl5lib; + $self->set_perldb_opts if $db eq 'nostop'; + system $^X, '-MApache::TestPerlDB', '-d', @{ $self->{tests} }; + $self->stop; + return 1; + } + elsif ($db =~ s/^lwp[=:]?//) { + $ENV{APACHE_TEST_DEBUG_LWP} = $db || 1; + $opts->{verbose} = 1; + return 0; + } + } + + $server->stop; + $server->start_debugger($debug_opts); + 1; +} + +sub opt_help { + my $self = shift; + + print <<EOM; +usage: TEST [options ...] + where options include: +EOM + + for (sort keys %usage){ + printf " -%-13s %s\n", $_, $usage{$_}; + } + + print "\n configuration options:\n"; + + Apache::TestConfig->usage; + 1; +} + +# generate t/TEST script (or a different filename) which will drive +# Apache::TestRun +sub generate_script { + my ($class, @opts) = @_; + + my %opts = (); + + # back-compat + if (@opts == 1) { + $opts{file} = $opts[0]; + } + else { + %opts = @opts; + $opts{file} ||= catfile 't', 'TEST'; + } + + my $body = "BEGIN { eval { require blib && blib->import; } }\n"; + + my %args = @Apache::TestMM::Argv; + while (my($k, $v) = each %args) { + $v =~ s/\|/\\|/g; + $body .= "\n\$Apache::TestConfig::Argv{'$k'} = q|$v|;\n"; + } + + my $header = Apache::TestConfig->perlscript_header; + + $body .= join "\n", + $header, "use $class ();"; + + if (my $report = $opts{bugreport}) { + $body .= "\n\npackage $class;\n" . + "sub bug_report { print '$report' }\n\n"; + } + + $body .= "$class->new->run(\@ARGV);"; + + Apache::Test::basic_config()->write_perlscript($opts{file}, + $body); +} + +# in idiomatic perl functions return 1 on success and 0 on +# failure. Shell expects the opposite behavior. So this function +# reverses the status. +sub exit_perl { + exit_shell $_[0] ? 0 : 1; +} + +# expects shell's exit status values (0==success) +sub exit_shell { +# require Carp; +# Carp::cluck('exiting'); + CORE::exit $_[0]; +} + +1; + +__END__ + +=head1 NAME + +Apache::TestRun - Run the test suite + +=head1 SYNOPSIS + + +=head1 DESCRIPTION + +The C<Apache::TestRun> package controls the configuration and running +of the test suite. + +=head1 METHODS + +Several methods are sub-classable, if the default behavior should be +changed. + +=head2 C<bug_report> + +The C<bug_report()> method is executed when C<t/TEST> was executed +with the C<-bugreport> option, and C<make test> (or C<t/TEST>) +fail. Normally this is callback which you can use to tell the user how +to deal with the problem, e.g. suggesting to read some document or +email some details to someone who can take care of it. By default +nothing is executed. + +The C<-bugreport> option is needed so this feature won't become +annoying to developers themselves. It's automatically added to the +C<run_tests> target in F<Makefile>. So if you repeateadly have to test +your code, just don't use C<make test> but run C<t/TEST> +directly. Here is an example of a custom C<t/TEST> + + My::TestRun->new->run(@ARGV); + + package My::TestRun; + use base 'Apache::TestRun'; + + sub bug_report { + my $self = shift; + + print <<EOI; + +--------------------------------------------------------+ + | Please file a bug report: http://perl.apache.org/bugs/ | + +--------------------------------------------------------+ + EOI + } + +=head2 C<pre_configure> + +The C<pre_configure()> method is executed before the configuration for +C<Apache::Test> is generated. So if you need to adjust the setup +before I<httpd.conf> and other files are autogenerated, this is the +right place to do so. + +For example if you don't want to inherit a LoadModule directive for +I<mod_apreq.so> but to make sure that the local version is used, you +can sub-class C<Apache::TestRun> and override this method in +I<t/TEST.PL>: + + package My::TestRun; + use base 'Apache::TestRun'; + use Apache::TestConfig; + __PACKAGE__->new->run(@ARGV); + + sub pre_configure { + my $self = shift; + # Don't load an installed mod_apreq + Apache::TestConfig::autoconfig_skip_module_add('mod_apreq.c'); + + $self->SUPER::pre_configure(); + } + +Notice that the extension is I<.c>, and not I<.so>. + +Don't forget to run the super class' c<pre_configure()> method. + + + +=head2 C<new_test_config> + +META: to be completed + +=cut diff --git a/debian/perl-framework/Apache-Test/lib/Apache/TestRunPHP.pm b/debian/perl-framework/Apache-Test/lib/Apache/TestRunPHP.pm new file mode 100644 index 0000000..d2965ba --- /dev/null +++ b/debian/perl-framework/Apache-Test/lib/Apache/TestRunPHP.pm @@ -0,0 +1,332 @@ +# 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::TestRunPHP; + +use strict; +use warnings FATAL => 'all'; + +use File::Spec::Functions qw(catfile canonpath); + +use Apache::TestRun (); +use Apache::TestConfigParse (); +use Apache::TestTrace; +use Apache::TestConfigPHP (); +use Apache::TestHarnessPHP (); + +use vars qw($VERSION); +$VERSION = '1.00'; # make CPAN.pm's r() version scanner happy + +use File::Spec::Functions qw(catfile); + +# subclass of Apache::TestRun that configures php things +use vars qw(@ISA); +@ISA = qw(Apache::TestRun); + +sub start { + my $self = shift; + + # point php to our own php.ini file + $ENV{PHPRC} = catfile $self->{test_config}->{vars}->{serverroot}, + 'conf'; + + $self->SUPER::start(@_); +} + +sub new_test_config { + my $self = shift; + + Apache::TestConfigPHP->new($self->{conf_opts}); +} + +sub configure_php { + my $self = shift; + + my $test_config = $self->{test_config}; + + $test_config->postamble_register(qw(configure_php_inc + configure_php_ini + configure_php_functions + configure_php_tests)); +} + +sub configure { + my $self = shift; + + $self->configure_php; + + $self->SUPER::configure; +} + +#if Apache::TestRun refreshes config in the middle of configure +#we need to re-add php configure hooks +sub refresh { + my $self = shift; + $self->SUPER::refresh; + $self->configure_php; +} + +my @request_opts = qw(get post head); + +sub run_tests { + my $self = shift; + + my $test_opts = { + verbose => $self->{opts}->{verbose}, + tests => $self->{tests}, + order => $self->{opts}->{order}, + subtests => $self->{subtests} || [], + }; + + if (grep { exists $self->{opts}->{$_} } @request_opts) { + run_request($self->{test_config}, $self->{opts}); + } + else { + Apache::TestHarnessPHP->run($test_opts) + if $self->{opts}->{'run-tests'}; + } +} + +sub split_test_args { + my($self) = @_; + + my(@tests); + my $top_dir = $self->{test_config}->{vars}->{top_dir}; + my $t_dir = $self->{test_config}->{vars}->{t_dir}; + + my $argv = $self->{argv}; + my @leftovers = (); + for (@$argv) { + my $arg = $_; + # need the t/ (or t\) for stat-ing, but don't want to include + # it in test output + $arg =~ s@^(?:\.[\\/])?t[\\/]@@; + my $file = catfile $t_dir, $arg; + if (-d $file and $_ ne '/') { + my @files = <$file/*.t>; + push @files, <$file/*.php>; + my $remove = catfile $top_dir, ""; + if (@files) { + push @tests, map { s,^\Q$remove,,; $_ } @files; + next; + } + } + else { + if (($file =~ /\.t$/ || $file =~ /\.php$/) and -e $file) { + push @tests, "t/$arg"; + next; + } + elsif (-e "$file.t") { + push @tests, "t/$arg.t"; + next; + } + elsif (/^[\d.]+$/) { + my @t = $_; + #support range of subtests: t/TEST t/foo/bar 60..65 + if (/^(\d+)\.\.(\d+)$/) { + @t = $1..$2; + } + + push @{ $self->{subtests} }, @t; + next; + } + } + push @leftovers, $_; + } + + $self->{tests} = [ map { canonpath($_) } @tests ]; + $self->{argv} = \@leftovers; +} +1; +__END__ + +=head1 NAME + +Apache::TestRunPHP - configure and run a PHP-based test suite + +=head1 SYNOPSIS + + use Apache::TestRunPHP; + Apache::TestRunPHP->new->run(@ARGV); + +=head1 DESCRIPTION + +The C<Apache::TestRunPHP> package controls the configuration and +running of the test suite for PHP-based tests. It's a subclass +of C<Apache::TestRun> and similar in function to C<Apache::TestRunPerl>. + +Refer to the C<Apache::TestRun> manpage for information on the +available API. + +=head1 EXAMPLE + +C<TestRunPHP> works almost identially to C<TestRunPerl>, but in +case you are new to C<Apache-Test> here is a quick getting started +guide. be sure to see the links at the end of this document for +places to find additional details. + +because C<Apache-Test> is a Perl-based testing framework we start +from a C<Makefile.PL>, which should have the following lines (in +addition to the standard C<Makefile.PL> parts): + + use Apache::TestMM qw(test clean); + use Apache::TestRunPHP (); + + Apache::TestMM::filter_args(); + + Apache::TestRunPHP->generate_script(); + +C<generate_script()> will create a script named C<t/TEST>, the gateway +to the Perl testing harness and what is invoked when you call +C<make test>. C<filter_args()> accepts some C<Apache::Test>-specific +arguments and passes them along. for example, to point to a specific +C<httpd> installation you would invoke C<Makefile.PL> as follows + + $ perl Makefile.PL -httpd /my/local/apache/bin/httpd + +and C</my/local/apache/bin/httpd> will be propagated throughout the +rest of the process. note that PHP needs to be active within Apache +prior to configuring the test framework as shown above, either by +virtue of PHP being compiled into the C<httpd> binary statically or +through an active C<LoadModule> statement within the configuration +located in C</my/local/apache/conf/httpd.conf>. Other required modules +are the (very common) mod_alias and mod_env. + +now, like with C<Apache::TestRun> and C<Apache::TestRunPerl>, you can +place client-side Perl test scripts under C<t/>, such as C<t/01basic.t>, +and C<Apache-Test> will run these scripts when you call C<make test>. +however, what makes C<Apache::TestRunPHP> unique is some added magic +specifically tailored to a PHP environment. here are the mechanics. + +C<Apache::TestRunPHP> will look for PHP test scripts in that match +the following pattern + + t/response/TestFoo/bar.php + +where C<Foo> and C<bar> can be anything you like, and C<t/response/Test*> +is case sensitive. when this format is adhered to, C<Apache::TestRunPHP> +will create an associated Perl test script called C<t/foo/bar.t>, which +will be executed when you call C<make test>. all C<bar.t> does is issue +a simple GET to C<bar.php>, leaving the actual testing to C<bar.php>. in +essence, you can forget that C<bar.t> even exists. + +what does C<bar.php> look like? here is an example: + + <?php + print "1..1\n"; + print "ok 1\n" + ?> + +if it looks odd, that's ok because it is. I could explain to you exactly +what this means, but it isn't important to understand the gory details. +instead, it is sufficient to understand that when C<Apache::Test> calls +C<bar.php> it feeds the results directly to C<Test::Harness>, a module +that comes with every Perl installation, and C<Test::Harness> expects +what it receives to be formated in a very specific way. by itself, all +of this is pretty useless, so C<Apache::Test> provides PHP testers with +something much better. here is a much better example: + + <?php + # import the Test::More emulation layer + # see + # http://search.cpan.org/dist/Test-Simple/lib/Test/More.pm + # for Perl's documentation - these functions should behave + # in the same way + require 'test-more.php'; + + # plan() the number of tests + plan(6); + + # call ok() for each test you plan + ok ('foo' == 'foo', 'foo is equal to foo'); + ok ('foo' != 'foo', 'foo is not equal to foo'); + + # ok() can be other things as well + is ('bar', 'bar', 'bar is bar'); + is ('baz', 'bar', 'baz is baz'); + isnt ('bar', 'beer', 'bar is not beer'); + like ('bar', '/ar$/', 'bar matches ar$'); + + diag("printing some debugging information"); + + # whoops! one too many tests. I wonder what will happen... + is ('biff', 'biff', 'baz is a baz'); + ?> + +the include library C<test-more.php> is automatically generated by +C<Apache::TestConfigPHP> and configurations tweaked in such a +a way that your PHP scripts can find it without issue. the +functions provided by C<test-more.php> are equivalent in name and +function to those in C<Test::More>, a standard Perl testing +library, so you can see that manpage for details on the syntax +and functionality of each. + +at this point, we have enough in place to run some tests from +PHP-land - a C<Makefile.PL> to configure Apache for us, and +a PHP script in C<t/response/TestFoo/bar.php> to send some +results out to the testing engine. issuing C<make test> +would start Apache, issue the request to C<bar.php>, generate +a report, and shut down Apache. the report would look like +something like this after running the tests in verbose mode +(eg C<make test TEST_VERBOSE=1>): + + t/php/bar....1..6 + ok 1 - foo is equal to foo + not ok 2 - foo is not equal to foo + # Failed test (/src/devel/perl-php-test/t/response/TestFoo/bar.php at line 13) + ok 3 - bar is bar + not ok 4 - baz is baz + # Failed test (/src/devel/perl-php-test/t/response/TestFoo/bar.php at line 17) + # got: 'baz' + # expected: 'bar' + ok 5 - bar is not beer + ok 6 - bar matches ar$ + # printing some debugging information + ok 7 - baz is a baz + FAILED tests 2, 4, 7 + Failed 3/6 tests, 50.00% okay + Failed Test Stat Wstat Total Fail Failed List of Failed + ------------------------------------------------------------------------------- + t/php/bar.t 6 3 50.00% 2 4 7 + Failed 1/1 test scripts, 0.00% okay. 1/6 subtests failed, 83.33% okay. + +note that the actual test file that was run was C<t/php/bar.t>. this +file is autogenerated based on the C<t/response/TestFoo/bar.php> +pattern of your PHP script. C<t/php/bar.t> happens to be written in +Perl, but you really don't need to worry about it too much. + +as an interesting aside, if you are using perl-5.8.3 or later you can +actually create your own C<t/foo.php> client-side scripts and they +will be run via php (using our C<php.ini>). but more on that later... + +=head1 SEE ALSO + +the best source of information about using Apache-Test with +PHP (at this time) is probably the talk given at ApacheCon 2004 +(L<http://xrl.us/phpperl>), as well as the code from the talk +(L<http://xrl.us/phpperlcode>). there is also the online tutorial +L<http://perl.apache.org/docs/general/testing/testing.html> +which has all of the mod_perl-specific syntax and features have been +ported to PHP with this class. + +=head1 AUTHOR + +C<Apache-Test> is a community effort, maintained by a group of +dedicated volunteers. + +Questions can be asked at the test-dev <at> httpd.apache.org list +For more information see: http://httpd.apache.org/test/. + +=cut diff --git a/debian/perl-framework/Apache-Test/lib/Apache/TestRunParrot.pm b/debian/perl-framework/Apache-Test/lib/Apache/TestRunParrot.pm new file mode 100644 index 0000000..21bd3a9 --- /dev/null +++ b/debian/perl-framework/Apache-Test/lib/Apache/TestRunParrot.pm @@ -0,0 +1,68 @@ +# 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::TestRunParrot; + +use strict; +use warnings FATAL => 'all'; + +use File::Spec::Functions qw(catfile canonpath); + +use Apache::TestRun (); +use Apache::TestConfigParse (); +use Apache::TestTrace; +use Apache::TestConfigParrot (); + +use vars qw($VERSION); +$VERSION = '1.00'; # make CPAN.pm's r() version scanner happy + +use File::Spec::Functions qw(catfile); + +# subclass of Apache::TestRun that configures parrot things +use vars qw(@ISA); +@ISA = qw(Apache::TestRun); + +sub new_test_config { + my $self = shift; + + Apache::TestConfigParrot->new($self->{conf_opts}); +} + +sub configure_parrot { + my $self = shift; + + my $test_config = $self->{test_config}; + + $test_config->postamble_register(qw(configure_parrot_tests)); +} + +sub configure { + my $self = shift; + + $self->configure_parrot; + + $self->SUPER::configure; +} + +#if Apache::TestRun refreshes config in the middle of configure +#we need to re-add parrotconfigure hooks +sub refresh { + my $self = shift; + $self->SUPER::refresh; + $self->configure_parrot; +} + +1; +__END__ diff --git a/debian/perl-framework/Apache-Test/lib/Apache/TestRunPerl.pm b/debian/perl-framework/Apache-Test/lib/Apache/TestRunPerl.pm new file mode 100644 index 0000000..2226575 --- /dev/null +++ b/debian/perl-framework/Apache-Test/lib/Apache/TestRunPerl.pm @@ -0,0 +1,139 @@ +# 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::TestRunPerl; + +use strict; +use warnings FATAL => 'all'; + +use Apache::TestRun (); +use Apache::TestConfigParse (); +use Apache::TestTrace; + +use vars qw($VERSION); +$VERSION = '1.00'; # make CPAN.pm's r() version scanner happy + +use File::Spec::Functions qw(catfile); + +#subclass of Apache::TestRun that configures mod_perlish things +use vars qw(@ISA); +@ISA = qw(Apache::TestRun); + +sub pre_configure { + my $self = shift; + + # Apache::TestConfigPerl already configures mod_perl.so + Apache::TestConfig::autoconfig_skip_module_add('mod_perl.c'); + + # skip over Embperl.so - it's funky + Apache::TestConfig::autoconfig_skip_module_add('Embperl.c'); +} + +sub configure_modperl { + my $self = shift; + + my $test_config = $self->{test_config}; + + my $rev = $test_config->server->{rev}; + my $ver = $test_config->server->{version}; + + # sanity checking and loading the right mod_perl version + + # remove mod_perl.pm from %INC so that the below require() + # calls accurately populate $mp_ver + delete $INC{'mod_perl.pm'}; + + if ($rev == 2) { + eval { require mod_perl2 }; + } else { + eval { require mod_perl }; + } + + my $mp_ver = $mod_perl::VERSION; + if ($@) { + error "You are using mod_perl response handlers ", + "but do not have a mod_perl capable Apache."; + Apache::TestRun::exit_perl(0); + } + if (($rev == 1 && $mp_ver >= 1.99) || + ($rev == 2 && $mp_ver < 1.99)) { + error "Found mod_perl/$mp_ver, but it can't be used with $ver"; + Apache::TestRun::exit_perl(0); + } + + if ($rev == 2) { + # load apreq2 if it is present + # do things a bit differently that find_and_load_module() + # because apreq2 can't be loaded that way (the 2 causes a problem) + my $name = 'mod_apreq2.so'; + if (my $mod_path = $test_config->find_apache_module($name)) { + + # don't match the 2 here + my ($sym) = $name =~ m/mod_(\w+)2\./; + + if ($mod_path && -e $mod_path) { + $test_config->preamble(IfModule => "!mod_$sym.c", + qq{LoadModule ${sym}_module "$mod_path"\n}); + } + } + } + + $test_config->preamble_register(qw(configure_libmodperl + configure_env)); + + $test_config->postamble_register(qw(configure_inc + configure_pm_tests_inc + configure_startup_pl + configure_pm_tests)); +} + +sub configure { + my $self = shift; + + $self->configure_modperl; + + $self->SUPER::configure; +} + +#if Apache::TestRun refreshes config in the middle of configure +#we need to re-add modperl configure hooks +sub refresh { + my $self = shift; + $self->SUPER::refresh; + $self->configure_modperl; +} + +1; +__END__ + +=head1 NAME + +Apache::TestRunPerl - Run mod_perl-requiring Test Suite + +=head1 SYNOPSIS + + use Apache::TestRunPerl; + Apache::TestRunPerl->new->run(@ARGV); + +=head1 DESCRIPTION + +The C<Apache::TestRunPerl> package controls the configuration and +running of the test suite. It's a subclass of C<Apache::TestRun>, and +should be used only when you need to run mod_perl tests. + +Refer to the C<Apache::TestRun> manpage for information on the +available API. + +=cut diff --git a/debian/perl-framework/Apache-Test/lib/Apache/TestSSLCA.pm b/debian/perl-framework/Apache-Test/lib/Apache/TestSSLCA.pm new file mode 100644 index 0000000..fc4c685 --- /dev/null +++ b/debian/perl-framework/Apache-Test/lib/Apache/TestSSLCA.pm @@ -0,0 +1,595 @@ +# 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::TestSSLCA; + +use strict; +use warnings FATAL => 'all'; + +use Cwd (); +use DirHandle (); +use File::Path (); +use File::Copy 'cp'; +use File::Basename; +use File::Spec::Functions qw(devnull); +use Apache::TestConfig (); +use Apache::TestTrace; + +use constant SSLCA_DB => 'index.txt'; + +use vars qw(@EXPORT_OK &import); + +use subs qw(symlink); + +@EXPORT_OK = qw(dn dn_vars dn_oneline); +*import = \&Exporter::import; + +my $openssl = $ENV{APACHE_TEST_OPENSSL_CMD} || 'openssl'; +my $version = version(); + +my $CA = 'asf'; +my $Config; #global Apache::TestConfig object + +my $days = '-days 365'; +my $cakey = 'keys/ca.pem'; +my $cacert = 'certs/ca.crt'; +my $capolicy = '-policy policy_anything'; +my $cacrl = 'crl/ca-bundle.crl'; +my $dgst = 'sha256'; + +#we use the same password for everything +my $pass = 'httpd'; +my $passin = "-passin pass:$pass"; +my $passout = "-passout pass:$pass"; + +# (limited) subjectAltName otherName testing +my $san_msupn = ', otherName:msUPN;UTF8:$mail'; +my $san_dnssrv = ', otherName:1.3.6.1.5.5.7.8.7;IA5:_https.$CN'; + +# in 0.9.7 s/Email/emailAddress/ in DN +my $email_field = Apache::Test::normalize_vstring($version) < + Apache::Test::normalize_vstring("0.9.7") ? + "Email" : "emailAddress"; + +# downgrade to SHA-1 for OpenSSL before 0.9.8 +if (Apache::Test::normalize_vstring($version) < + Apache::Test::normalize_vstring("0.9.8")) { + $dgst = 'sha1'; + # otherNames in x509v3_config are not supported either + $san_msupn = $san_dnssrv = ""; +} + +my $sslproto = "all"; + +eval { require Net::SSLeay; }; +if (Apache::Test::normalize_vstring($version) >= + Apache::Test::normalize_vstring("1.1.1") + && !defined(&Net::SSLeay::CTX_set_post_handshake_auth)) { + # OpenSSL 1.1.1 disables PHA by default client-side in TLSv1.3 but + # most clients are not updated to enable it (at time of writing). + # Many mod_ssl tests require working PHA, so disable v1.3 unless + # using an updated Net::SSLeay. This is strictly insufficient + # since an updated IO::Socket::SSL is also needed; to be + # continued. Ref: https://github.com/openssl/openssl/issues/6933 + $sslproto = "all -TLSv1.3"; +} + +my $ca_dn = { + asf => { + C => 'US', + ST => 'California', + L => 'San Francisco', + O => 'ASF', + OU => 'httpd-test', + CN => '', + $email_field => 'test-dev@httpd.apache.org', + }, +}; + +my $cert_dn = { + client_snakeoil => { + C => 'AU', + ST => 'Queensland', + L => 'Mackay', + O => 'Snake Oil, Ltd.', + OU => 'Staff', + }, + client_ok => { + }, + client_colon => { + CN => "user:colon", + }, + client_revoked => { + }, + server => { + CN => 'localhost', + OU => 'httpd-test/rsa-test', + }, + server2 => { + CN => 'localhost', + OU => 'httpd-test/rsa-test-2', + }, + server_des3 => { + CN => 'localhost', + OU => 'httpd-test/rsa-des3-test', + }, + server2_des3 => { + CN => 'localhost', + OU => 'httpd-test/rsa-des3-test-2', + }, +}; + +#generate DSA versions of the server certs/keys +for my $key (keys %$cert_dn) { + next unless $key =~ /^server/; + my $val = $$cert_dn{$key}; + my $name = join '_', $key, 'dsa'; + $cert_dn->{$name} = { %$val }; #copy + $cert_dn->{$name}->{OU} =~ s/rsa/dsa/; +} + +sub ca_dn { + $ca_dn = shift if @_; + $ca_dn; +} + +sub cert_dn { + $cert_dn = shift if @_; + $cert_dn; +} + +sub dn { + my $name = shift; + + my %dn = %{ $ca_dn->{$CA} }; #default values + $dn{CN} ||= $name; #try make sure each Common Name is different + + my $default_dn = $cert_dn->{$name}; + + if ($default_dn) { + while (my($key, $value) = each %$default_dn) { + #override values + $dn{$key} = $value; + } + } + + return wantarray ? %dn : \%dn; +} + +sub dn_vars { + my($name, $type) = @_; + + my $dn = dn($name); + my $prefix = join '_', 'SSL', $type, 'DN'; + + return { map { $prefix ."_$_", $dn->{$_} } keys %$dn }; +} + +sub dn_oneline { + my($dn, $rfc2253) = @_; + + unless (ref $dn) { + $dn = dn($dn); + } + + my $string = ""; + my @parts = (qw(C ST L O OU CN), $email_field); + @parts = reverse @parts if $rfc2253; + + for my $k (@parts) { + next unless $dn->{$k}; + if ($rfc2253) { + my $tmp = $dn->{$k}; + $tmp =~ s{([,+"\\<>;])}{\\$1}g; + $tmp =~ s{^([ #])}{\\$1}; + $tmp =~ s{ $}{\\ }; + $string .= "," if $string; + $string .= "$k=$tmp"; + } + else { + $string .= "/$k=$dn->{$k}"; + } + } + + $string; +} + +sub openssl { + return $openssl unless @_; + + my $cmd = "$openssl @_"; + + info $cmd; + + unless (system($cmd) == 0) { + my $status = $? >> 8; + die "system @_ failed (exit status=$status)"; + } +} + +my @dirs = qw(keys newcerts certs crl export csr conf proxy); + +sub init { + for my $dir (@dirs) { + gendir($dir); + } +} + +sub config_file { + my $name = shift; + + my $file = "conf/$name.cnf"; + return $file if -e $file; + + my $dn = dn($name); + my $db = SSLCA_DB; + + writefile($db, '', 1) unless -e $db; + + writefile($file, <<EOF); +mail = $dn->{$email_field} +CN = $dn->{CN} + +[ req ] +distinguished_name = req_distinguished_name +attributes = req_attributes +prompt = no +default_bits = 2048 +output_password = $pass + +[ req_distinguished_name ] +C = $dn->{C} +ST = $dn->{ST} +L = $dn->{L} +O = $dn->{O} +OU = $dn->{OU} +CN = \$CN +$email_field = \$mail + +[ req_attributes ] +challengePassword = $pass + +[ ca ] +default_ca = CA_default + +[ CA_default ] +certs = certs # Where the issued certs are kept +new_certs_dir = newcerts # default place for new certs. +crl_dir = crl # Where the issued crl are kept +database = $db # database index file. +serial = serial # The current serial number + +certificate = $cacert # The CA certificate +crl = $cacrl # The current CRL +private_key = $cakey # The private key + +default_days = 365 # how long to certify for +default_crl_days = 365 # how long before next CRL +default_md = $dgst # which md to use. +preserve = no # keep passed DN ordering + +[ policy_anything ] +countryName = optional +stateOrProvinceName = optional +localityName = optional +organizationName = optional +organizationalUnitName = optional +commonName = supplied +$email_field = optional + +[ client_ok_ext ] +nsComment = This Is A Comment +1.3.6.1.4.1.18060.12.0 = DER:0c064c656d6f6e73 +subjectAltName = email:\$mail$san_msupn + +[ server_ext ] +subjectAltName = DNS:\$CN$san_dnssrv +EOF + + return $file; +} + +sub config { + my $name = shift; + + my $file = config_file($name); + + my $config = "-config $file"; + + $config; +} + +use constant PASSWORD_CLEARTEXT => + Apache::TestConfig::WIN32 || Apache::TestConfig::NETWARE; + +#http://www.modssl.org/docs/2.8/ssl_reference.html#ToC21 +my $basic_auth_password = + PASSWORD_CLEARTEXT ? 'password': 'xxj31ZMTZzkVA'; +my $digest_auth_hash = '$1$OXLyS...$Owx8s2/m9/gfkcRVXzgoE/'; + +sub new_ca { + writefile('serial', "01\n", 1); + + writefile('ssl.htpasswd', + join ':', dn_oneline('client_snakeoil'), + $basic_auth_password); + + openssl req => "-new -x509 -keyout $cakey -out $cacert $days", + config('ca'); + + export_cert('ca'); #useful for importing into IE +} + +sub new_key { + my $name = shift; + + my $encrypt = @_ ? "@_ $passout" : ""; + + my $out = "-out keys/$name.pem $encrypt"; + + if ($name =~ /dsa/) { + #this takes a long time so just do it once + #don't do this in real life + unless (-e 'dsa-param') { + openssl dsaparam => '-inform PEM -out dsa-param 2048'; + } + openssl gendsa => "$out dsa-param"; + } + else { + openssl genrsa => "$out 2048"; + } +} + +sub new_cert { + my $name = shift; + + openssl req => "-new -key keys/$name.pem -out csr/$name.csr", + $passin, $passout, config($name); + + sign_cert($name); + + export_cert($name); +} + +sub sign_cert { + my $name = shift; + my $exts = ''; + + $exts = ' -extensions client_ok_ext' if $name =~ /client_ok/; + + $exts = ' -extensions server_ext' if $name =~ /server/; + + openssl ca => "$capolicy -in csr/$name.csr -out certs/$name.crt", + $passin, config($name), '-batch', $exts; +} + +#handy for importing into a browser such as netscape +sub export_cert { + my $name = shift; + + return if $name =~ /^server/; #no point in exporting server certs + + openssl pkcs12 => "-export -in certs/$name.crt -inkey keys/$name.pem", + "-out export/$name.p12", $passin, $passout; +} + +sub revoke_cert { + my $name = shift; + + my @args = (config('cacrl'), $passin); + + #revokes in the SSLCA_DB database + openssl ca => "-revoke certs/$name.crt", @args; + + #generates crl from the index.txt database + openssl ca => "-gencrl -out $cacrl", @args; +} + +sub symlink { + my($file, $symlink) = @_; + + my $what = 'linked'; + + if (Apache::TestConfig::WINFU) { + cp $file, $symlink; + $what = 'copied'; + } + else { + CORE::symlink($file, $symlink); + } + + info "$what $file to $symlink"; +} + +sub hash_certs { + my($type, $dir) = @_; + + chdir $dir; + + my $dh = DirHandle->new('.') or die "opendir $dir: $!"; + my $n = 0; + + for my $file ($dh->read) { + next unless $file =~ /\.cr[tl]$/; + chomp(my $hash = `openssl $type -noout -hash < $file`); + next unless $hash; + my $symlink = "$hash.r$n"; + $n++; + symlink $file, $symlink; + } + + close $dh; + + chdir $CA; +} + +sub make_proxy_cert { + my $name = shift; + + my $from = "certs/$name.crt"; + my $to = "proxy/$name.pem"; + + info "generating proxy cert: $to"; + + my $fh_to = Symbol::gensym(); + my $fh_from = Symbol::gensym(); + + open $fh_to, ">$to" or die "open $to: $!"; + open $fh_from, $from or die "open $from: $!"; + + cp $fh_from, $fh_to; + + $from = "keys/$name.pem"; + + open $fh_from, $from or die "open $from: $!"; + + cp $fh_from, $fh_to; + + close $fh_from; + close $fh_to; +} + +sub setup { + $CA = shift; + + unless ($ca_dn->{$CA}) { + die "unknown CA $CA"; + } + + gendir($CA); + + chdir $CA; + + init(); + new_ca(); + + my @names = keys %$cert_dn; + + for my $name (@names) { + my @key_args = (); + if ($name =~ /_des3/) { + push @key_args, '-des3'; + } + + new_key($name, @key_args); + new_cert($name); + + if ($name =~ /_revoked$/) { + revoke_cert($name); + } + + if ($name =~ /^client_/) { + make_proxy_cert($name); + } + } + + hash_certs(crl => 'crl'); +} + +sub generate { + $Config = shift; + + $CA = shift || $Config->{vars}->{sslcaorg}; + + my $root = $Config->{vars}->{sslca}; + + return if -d $root; + + my $pwd = Cwd::cwd(); + my $base = dirname $root; + my $dir = basename $root; + + chdir $base; + + # Ensure the CNs used in the server certs match up with the + # hostname being used for testing. + while (my($key, $val) = each %$cert_dn) { + next unless $key =~ /^server/; + $val->{CN} = $Config->{vars}->{servername}; + } + + #make a note that we created the tree + $Config->clean_add_path($root); + + gendir($dir); + + chdir $dir; + + warning "generating SSL CA for $CA"; + + setup($CA); + + chdir $pwd; +} + +sub clean { + my $config = shift; + + #rel2abs adds same drive letter for win32 that clean_add_path added + my $dir = File::Spec->rel2abs($config->{vars}->{sslca}); + + unless ($config->{clean}->{dirs}->{$dir}) { + return; #we did not generate this ca + } + + unless ($config->{clean_level} > 1) { + #skip t/TEST -conf + warning "skipping regeneration of SSL CA; run t/TEST -clean to force"; + return; + } + + File::Path::rmtree([$dir], 1, 1); +} + +#not using Apache::TestConfig methods because the openssl commands +#will generate heaps of files we cannot keep track of + +sub writefile { + my($file, $content) = @_; + + my $fh = Symbol::gensym(); + open $fh, ">$file" or die "open $file: $!"; + print $fh $content; + close $fh; +} + +sub gendir { + my($dir) = @_; + + return if -d $dir; + mkdir $dir, 0755; +} + +sub version { + my $devnull = devnull(); + my $version = qx($openssl version 2>$devnull); + return $1 if $version =~ /^\S+SSL (\S+)/; + die "FATAL: unable to determine openssl version via `$openssl version` from: $version"; +} + +sub dgst { + return $dgst; +} + +sub email_field { + return $email_field; +} + +sub sslproto { + return $sslproto; +} + +1; +__END__ diff --git a/debian/perl-framework/Apache-Test/lib/Apache/TestServer.pm b/debian/perl-framework/Apache-Test/lib/Apache/TestServer.pm new file mode 100644 index 0000000..3a30a63 --- /dev/null +++ b/debian/perl-framework/Apache-Test/lib/Apache/TestServer.pm @@ -0,0 +1,724 @@ +# 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::TestServer; + +use strict; +use warnings FATAL => 'all'; + +use Config; +use Socket (); +use File::Spec::Functions qw(catfile); + +use Apache::TestTrace; +use Apache::TestRun; +use Apache::TestConfig (); +use Apache::TestRequest (); + +use constant COLOR => Apache::TestConfig::COLOR; +use constant WIN32 => Apache::TestConfig::WIN32; + +my $CTRL_M = COLOR ? "\r" : "\n"; + +# some debuggers use the same syntax as others, so we reuse the same +# code by using the following mapping +my %debuggers = ( + gdb => 'gdb', + ddd => 'gdb', + valgrind => 'valgrind', + strace => 'strace', +); + +sub new { + my $class = shift; + my $config = shift; + + my $self = bless { + config => $config || Apache::TestConfig->thaw, + }, $class; + + $self->{name} = join ':', + map { $self->{config}->{vars}->{$_} } qw(servername port); + + $self->{port_counter} = $self->{config}->{vars}->{port}; + + $self; +} + +# call this when you already know where httpd is +sub post_config { + my($self) = @_; + + $self->{version} = $self->{config}->httpd_version || ''; + $self->{mpm} = $self->{config}->httpd_mpm || ''; + + # try to get the revision number from the standard Apache version + # string and various variations made by distributions which mangle + # that string + + # Foo-Apache-Bar/x.y.z + ($self->{rev}) = $self->{version} =~ m|/(\d)\.|; + + if ($self->{rev}) { + debug "Matched Apache revision $self->{version} $self->{rev}"; + } + else { + # guessing is not good as it'll only mislead users + # and we can't die since a config object is required + # during Makefile.PL's write_perlscript when path to httpd may + # be unknown yet. so default to non-existing version 0 for now. + # and let TestRun.pm figure out the required pieces + debug "can't figure out Apache revision, from string: " . + "'$self->{version}', using a non-existing revision 0"; + $self->{rev} = 0; # unknown + } + + ($self->{revminor}) = $self->{version} =~ m|/\d\.(\d)|; + + if ($self->{revminor}) { + debug "Matched Apache revminor $self->{version} $self->{revminor}"; + } + else { + $self->{revminor} = 0; + } + + $self; +} + +sub version_of { + my($self, $thing) = @_; + die "Can't figure out what Apache server generation we are running" + unless $self->{rev}; + + $thing->{$self->{rev}}; +} + +my @apache_logs = qw( +error_log access_log httpd.pid +apache_runtime_status rewrite_log +ssl_engine_log ssl_request_log +cgisock +); + +sub clean { + my $self = shift; + + my $dir = $self->{config}->{vars}->{t_logs}; + + for (@apache_logs) { + my $file = catfile $dir, $_; + if (unlink $file) { + debug "unlink $file"; + } + } +} + +sub pid_file { + my $self = shift; + + my $vars = $self->{config}->{vars}; + + return $vars->{t_pid_file} || catfile $vars->{t_logs}, 'httpd.pid'; +} + +sub dversion { + my $self = shift; + + my $dv = "-D APACHE$self->{rev}"; + + if ($self->{rev} == 2 and $self->{revminor} == 4) { + $dv .= " -D APACHE2_4"; + } + + return $dv; +} + +sub config_defines { + my $self = shift; + + my @defines = (); + + for my $item (qw(useithreads)) { + next unless $Config{$item} and $Config{$item} eq 'define'; + push @defines, "-D PERL_\U$item"; + } + + if (my $defines = $self->{config}->{vars}->{defines}) { + push @defines, map { "-D $_" } split " ", $defines; + } + + "@defines"; +} + +sub args { + my $self = shift; + my $vars = $self->{config}->{vars}; + my $dversion = $self->dversion; #for .conf version conditionals + my $defines = $self->config_defines; + + "-d $vars->{serverroot} -f $vars->{t_conf_file} $dversion $defines"; +} + +my %one_process = (1 => '-X', 2 => '-D ONE_PROCESS'); + +sub start_cmd { + my $self = shift; + + my $args = $self->args; + my $config = $self->{config}; + my $vars = $config->{vars}; + my $httpd = $vars->{httpd}; + + my $one_process = $self->{run}->{opts}->{'one-process'} + ? $self->version_of(\%one_process) + : ''; + + #XXX: threaded mpm does not respond to SIGTERM with -D ONE_PROCESS + + return "$httpd $one_process $args"; +} + +sub default_gdbinit { + my $gdbinit = ""; + my @sigs = qw(PIPE); + + for my $sig (@sigs) { + for my $flag (qw(pass nostop)) { + $gdbinit .= "handle SIG$sig $flag\n"; + } + } + + $gdbinit; +} + +sub strace_cmd { + my($self, $strace, $file) = @_; + #XXX truss, ktrace, etc. + "$strace -f -o $file -s1024"; +} + +sub valgrind_cmd { + my($self, $valgrind) = @_; + "$valgrind -v --leak-check=yes --show-reachable=yes --error-limit=no"; +} + +sub start_valgrind { + my $self = shift; + my $opts = shift; + + my $config = $self->{config}; + my $args = $self->args; + my $one_process = $self->version_of(\%one_process); + my $valgrind_cmd = $self->valgrind_cmd($opts->{debugger}); + my $httpd = $config->{vars}->{httpd}; + + my $command = "$valgrind_cmd $httpd $one_process $args"; + + debug $command; + system $command; +} + +sub start_strace { + my $self = shift; + my $opts = shift; + + my $config = $self->{config}; + my $args = $self->args; + my $one_process = $self->version_of(\%one_process); + my $file = catfile $config->{vars}->{t_logs}, 'strace.log'; + my $strace_cmd = $self->strace_cmd($opts->{debugger}, $file); + my $httpd = $config->{vars}->{httpd}; + + $config->genfile($file); #just mark for cleanup + + my $command = "$strace_cmd $httpd $one_process $args"; + + debug $command; + system $command; +} + +sub start_gdb { + my $self = shift; + my $opts = shift; + + my $debugger = $opts->{debugger}; + my @breakpoints = @{ $opts->{breakpoint} || [] }; + my $config = $self->{config}; + my $args = $self->args; + my $one_process = $self->version_of(\%one_process); + + my $file = catfile $config->{vars}->{serverroot}, '.gdb-test-start'; + my $fh = $config->genfile($file); + + print $fh default_gdbinit(); + + if (@breakpoints) { + print $fh "b ap_run_pre_config\n"; + print $fh "run $one_process $args\n"; + print $fh "finish\n"; + for (@breakpoints) { + print $fh "b $_\n" + } + print $fh "continue\n"; + } + else { + print $fh "run $one_process $args\n"; + } + close $fh; + + my $command; + my $httpd = $config->{vars}->{httpd}; + + if ($debugger eq 'ddd') { + $command = qq{ddd --gdb --debugger "gdb -command $file" $httpd}; + } + else { + ## defaults to gdb if not set in %ENV or via -debug + $command = "$debugger $httpd -command $file"; + } + + $self->note_debugging; + debug $command; + system $command; + + unlink $file; +} + +sub debugger_file { + my $self = shift; + catfile $self->{config}->{vars}->{serverroot}, '.debugging'; +} + +#make a note that the server is running under the debugger +#remove note when this process exits via END + +sub note_debugging { + my $self = shift; + my $file = $self->debugger_file; + my $fh = $self->{config}->genfile($file); + eval qq(END { unlink "$file" }); +} + +sub start_debugger { + my $self = shift; + my $opts = shift; + + $opts->{debugger} ||= $ENV{MP_DEBUGGER} || 'gdb'; + + # XXX: FreeBSD 5.2+ + # gdb 6.1 and before segfaults when trying to + # debug httpd startup code. 6.5 has been proven + # to work. FreeBSD typically installs this as + # gdb65. + # Is it worth it to check the debugger and os version + # and die ? + + unless (grep { /^$opts->{debugger}/ } keys %debuggers) { + error "$opts->{debugger} is not a supported debugger", + "These are the supported debuggers: ". + join ", ", sort keys %debuggers; + die("\n"); + } + + my $debugger = $opts->{debugger}; + $debugger =~ s/\d+$//; + + my $method = "start_" . $debuggers{$debugger}; + + ## $opts->{debugger} is passed through unchanged + ## so when we try to run it next, its found. + $self->$method($opts); +} + +sub pid { + my $self = shift; + my $file = $self->pid_file; + my $fh = Symbol::gensym(); + open $fh, $file or do { + return 0; + }; + + # try to avoid the race condition when the pid file was created + # but not yet written to + for (1..8) { + last if -s $file > 0; + select undef, undef, undef, 0.25; + } + + chomp(my $pid = <$fh> || ''); + $pid; +} + +sub select_next_port { + my $self = shift; + + my $max_tries = 100; #XXX + while ($max_tries-- > 0) { + return $self->{port_counter} + if $self->port_available(++$self->{port_counter}); + } + + return 0; +} + +sub port_available { + my $self = shift; + my $port = shift || $self->{config}->{vars}->{port}; + local *S; + + my $proto = getprotobyname('tcp'); + + socket(S, Socket::PF_INET(), + Socket::SOCK_STREAM(), $proto) || die "socket: $!"; + setsockopt(S, Socket::SOL_SOCKET(), + Socket::SO_REUSEADDR(), + pack("l", 1)) || die "setsockopt: $!"; + + if (bind(S, Socket::sockaddr_in($port, Socket::INADDR_ANY()))) { + close S; + return 1; + } + else { + return 0; + } +} + +=head2 stop() + +attempt to stop the server. + +returns: + + on success: $pid of the server + on failure: -1 + +=cut + +sub stop { + my $self = shift; + my $aborted = shift; + + if (WIN32) { + require Win32::Process; + my $obj = $self->{config}->{win32obj}; + my $pid = -1; + if ($pid = $obj ? $obj->GetProcessID : $self->pid) { + if (kill(0, $pid)) { + Win32::Process::KillProcess($pid, 0); + warning "server $self->{name} shutdown"; + } + } + unlink $self->pid_file if -e $self->pid_file; + return $pid; + } + + my $pid = 0; + my $tries = 3; + my $tried_kill = 0; + + my $port = $self->{config}->{vars}->{port}; + + while ($self->ping) { + #my $state = $tried_kill ? "still" : "already"; + #print "Port $port $state in use\n"; + + if ($pid = $self->pid and !$tried_kill++) { + if (kill TERM => $pid) { + warning "server $self->{name} shutdown"; + sleep 1; + + for (1..6) { + if (! $self->ping) { + if ($_ == 1) { + unlink $self->pid_file if -e $self->pid_file; + return $pid; + } + last; + } + if ($_ == 1) { + warning "port $port still in use..."; + } + else { + print "..."; + } + sleep $_; + } + + if ($self->ping) { + error "\nserver was shutdown but port $port ". + "is still in use, please shutdown the service ". + "using this port or select another port ". + "for the tests"; + } + else { + print "done\n"; + } + } + else { + error "kill $pid failed: $!"; + } + } + else { + error "port $port is in use, ". + "cannot determine server pid to shutdown"; + return -1; + } + + if (--$tries <= 0) { + error "cannot shutdown server on Port $port, ". + "please shutdown manually"; + unlink $self->pid_file if -e $self->pid_file; + return -1; + } + } + + unlink $self->pid_file if -e $self->pid_file; + return $pid; +} + +sub ping { + my $self = shift; + my $pid = $self->pid; + + if ($pid and kill 0, $pid) { + return $pid; + } + elsif (! $self->port_available) { + return -1; + } + + return 0; +} + +sub failed_msg { + my $self = shift; + my($log, $rlog) = $self->{config}->error_log; + my $log_file_info = -e $log ? + "please examine $rlog" : + "$rlog wasn't created, start the server in the debug mode"; + error "@_ ($log_file_info)"; +} + +#this doesn't work well on solaris or hpux at the moment +use constant USE_SIGCHLD => $^O eq 'linux'; + +sub start { + my $self = shift; + + my $old_pid = -1; + if (WIN32) { + # Stale PID files (e.g. left behind from a previous test run + # that crashed) cannot be trusted on Windows because PID's are + # re-used too frequently, so just remove it. If there is an old + # server still running then the attempt to start a new one below + # will simply fail because the port will be unavailable. + if (-f $self->pid_file) { + error "Removing old PID file -- " . + "Unclean shutdown of previous test run?\n"; + unlink $self->pid_file; + } + $old_pid = 0; + } + else { + $old_pid = $self->stop; + } + my $cmd = $self->start_cmd; + my $config = $self->{config}; + my $vars = $config->{vars}; + my $httpd = $vars->{httpd} || 'unknown'; + + if ($old_pid == -1) { + return 0; + } + + local $| = 1; + + unless (-x $httpd) { + my $why = -e $httpd ? "is not executable" : "does not exist"; + error "cannot start server: httpd ($httpd) $why"; + return 0; + } + + print "$cmd\n"; + my $old_sig; + + if (WIN32) { + #make sure only 1 process is started for win32 + #else Kill will only shutdown the parent + my $one_process = $self->version_of(\%one_process); + require Win32::Process; + my $obj; + # We need the "1" below to inherit the calling processes + # handles when running Apache::TestSmoke so as to properly + # dup STDOUT/STDERR + Win32::Process::Create($obj, + $httpd, + "$cmd $one_process", + 1, + Win32::Process::NORMAL_PRIORITY_CLASS(), + '.'); + unless ($obj) { + die "Could not start the server: " . + Win32::FormatMessage(Win32::GetLastError()); + } + $config->{win32obj} = $obj; + } + else { + $old_sig = $SIG{CHLD}; + + if (USE_SIGCHLD) { + # XXX: try not to be POSIX dependent + require POSIX; + + #XXX: this is not working well on solaris or hpux + $SIG{CHLD} = sub { + while ((my $child = waitpid(-1, POSIX::WNOHANG())) > 0) { + my $status = $? >> 8; + #error "got child exit $status"; + if ($status) { + my $msg = "server has died with status $status"; + $self->failed_msg("\n$msg"); + Apache::TestRun->new(test_config => $config)->scan_core; + kill SIGTERM => $$; + } + } + }; + } + + defined(my $pid = fork) or die "Can't fork: $!"; + unless ($pid) { # child + my $status = system "$cmd"; + if ($status) { + $status = $? >> 8; + #error "httpd didn't start! $status"; + } + CORE::exit $status; + } + } + + while ($old_pid and $old_pid == $self->pid) { + warning "old pid file ($old_pid) still exists"; + sleep 1; + } + + my $version = $self->{version}; + my $mpm = $config->{mpm} || ""; + $mpm = "($mpm MPM)" if $mpm; + print "using $version $mpm\n"; + + my $timeout = $vars->{startup_timeout} || + $ENV{APACHE_TEST_STARTUP_TIMEOUT} || + 60; + + my $start_time = time; + my $preamble = "${CTRL_M}waiting $timeout seconds for server to start: "; + print $preamble unless COLOR; + while (1) { + my $delta = time - $start_time; + print COLOR + ? ($preamble, sprintf "%02d:%02d", (gmtime $delta)[1,0]) + : '.'; + sleep 1; + if ($self->pid) { + print $preamble, "ok (waited $delta secs)\n"; + last; + } + elsif ($delta > $timeout) { + my $suggestion = $timeout + 300; + print $preamble, "not ok\n"; + error <<EOI; +giving up after $delta secs. If you think that your system +is slow or overloaded try again with a longer timeout value. +by setting the environment variable APACHE_TEST_STARTUP_TIMEOUT +to a high value (e.g. $suggestion) and repeat the last command. +EOI + last; + } + } + + # now that the server has started don't abort the test run if it + # dies + $SIG{CHLD} = $old_sig || 'DEFAULT'; + + if (my $pid = $self->pid) { + print "server $self->{name} started\n"; + + my $vh = $config->{vhosts}; + my $by_port = sub { $vh->{$a}->{port} <=> $vh->{$b}->{port} }; + + for my $module (sort $by_port keys %$vh) { + print "server $vh->{$module}->{name} listening ($module)\n", + } + + if ($config->configure_proxy) { + print "tests will be proxied through $vars->{proxy}\n"; + } + } + else { + $self->failed_msg("server failed to start!"); + return 0; + } + + return 1 if $self->wait_till_is_up($timeout); + + $self->failed_msg("failed to start server!"); + return 0; +} + + +# wait till the server is up and return 1 +# if the waiting times out returns 0 +sub wait_till_is_up { + my($self, $timeout) = @_; + my $config = $self->{config}; + my $sleep_interval = 1; # secs + + my $server_up = sub { + local $SIG{__WARN__} = sub {}; #avoid "cannot connect ..." warnings + # avoid fatal errors when LWP is not available + return eval { + my $r=Apache::TestRequest::GET('/index.html'); + $r->code!=500 or $r->header('client-warning')!~/internal/i; + } || 0; + }; + + if ($server_up->()) { + return 1; + } + + my $start_time = time; + my $preamble = "${CTRL_M}still waiting for server to warm up: "; + print $preamble unless COLOR; + while (1) { + my $delta = time - $start_time; + print COLOR + ? ($preamble, sprintf "%02d:%02d", (gmtime $delta)[1,0]) + : '.'; + sleep $sleep_interval; + if ($server_up->()) { + print "${CTRL_M}the server is up (waited $delta secs) \n"; + return 1; + } + elsif ($delta > $timeout) { + print "${CTRL_M}the server is down, giving up after $delta secs\n"; + return 0; + } + else { + # continue + } + } +} + +1; diff --git a/debian/perl-framework/Apache-Test/lib/Apache/TestSmoke.pm b/debian/perl-framework/Apache-Test/lib/Apache/TestSmoke.pm new file mode 100644 index 0000000..decc11b --- /dev/null +++ b/debian/perl-framework/Apache-Test/lib/Apache/TestSmoke.pm @@ -0,0 +1,949 @@ +# 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::TestSmoke; + +use strict; +use warnings FATAL => 'all'; + +use Apache::Test (); +use Apache::TestConfig (); +use Apache::TestTrace; + +use Apache::TestHarness (); +use Apache::TestRun (); # for core scan functions +use Apache::TestSort; + +use Getopt::Long qw(GetOptions); +use File::Spec::Functions qw(catfile); +use FindBin; +use POSIX (); +use Symbol (); + +#use constant DEBUG => 1; + +# how many times to run all tests at the first iteration +use constant DEFAULT_TIMES => 10; + +# if after this number of tries to reduce the number of tests fails we +# give up on more tries +use constant MAX_REDUCTION_TRIES => 50; + +my @num_opts = qw(times); +my @string_opts = qw(order report); +my @flag_opts = qw(help verbose bug_mode); + +my %order = map {$_ => 1} qw(random repeat); + +my %usage = ( + 'times=N' => 'how many times to run the entire test suite' . + ' (default: ' . DEFAULT_TIMES . ')', + 'order=MODE' => 'modes: random, repeat' . + ' (default: random)', + 'report=FILENAME' => 'save report in a filename' . + ' (default: smoke-report-<date>.txt)', + 'verbose[=1]' => 'verbose output' . + ' (default: 0)', + 'bug_mode' => 'bug report mode' . + ' (default: 0)', +); + +sub new { + my($class, @argv) = @_; + + my $self = bless { + seen => {}, # seen sequences and tried them md5 hash + results => {}, # final reduced sequences md5 hash + smoking_completed => 0, + tests => [], + total_iterations => 0, + total_reduction_attempts => 0, + total_reduction_successes => 0, + total_tests_run => 0, + }, ref($class)||$class; + + $self->{test_config} = Apache::TestConfig->thaw; + + $self->getopts(\@argv); + my $opts = $self->{opts}; + + chdir "$FindBin::Bin/.."; + $self->{times} = $opts->{times} || DEFAULT_TIMES; + $self->{order} = $opts->{order} || 'random'; + $self->{verbose} = $opts->{verbose} || 0; + + $self->{run_iter} = $self->{times}; + + # this is like 'make test' but produces an output to be used in + # the bug report + if ($opts->{bug_mode}) { + $self->{bug_mode} = 1; + $self->{run_iter} = 1; + $self->{times} = 1; + $self->{verbose} = 1; + $self->{order} = 'random'; + $self->{trace} = 'debug'; + } + + # specific tests end up in $self->{tests} and $self->{subtests}; + # and get removed from $self->{argv} + $self->Apache::TestRun::split_test_args(); + + my $test_opts = { + verbose => $self->{verbose}, + tests => $self->{tests}, + order => $self->{order}, + subtests => $self->{subtests} || [], + }; + + @{ $self->{tests} } = $self->get_tests($test_opts); + + $self->{base_command} = "$^X $FindBin::Bin/TEST"; + + # options common to all + $self->{base_command} .= " -verbose" if $self->{verbose}; + + # options specific to the startup + $self->{start_command} = "$self->{base_command} -start"; + $self->{start_command} .= " -trace=" . $self->{trace} if $self->{trace}; + + # options specific to the run + $self->{run_command} = "$self->{base_command} -run"; + + # options specific to the stop + $self->{stop_command} = "$self->{base_command} -stop"; + + $self; +} + +sub getopts { + my($self, $argv) = @_; + my %opts; + local *ARGV = $argv; + + # permute : optional values can come before the options + # pass_through : all unknown things are to be left in @ARGV + Getopt::Long::Configure(qw(pass_through permute)); + + # grab from @ARGV only the options that we expect + GetOptions(\%opts, @flag_opts, + (map "$_=s", @string_opts), + (map "$_=i", @num_opts)); + + if (exists $opts{order} && !exists $order{$opts{order}}) { + error "unknown -order mode: $opts{order}"; + $self->opt_help(); + exit; + } + + if ($opts{help}) { + $self->opt_help; + exit; + } + + # min + $self->{opts} = \%opts; + + $self->{argv} = [@ARGV]; +} + +# XXX: need proper sub-classing +# from Apache::TestHarness +sub skip { Apache::TestHarness::skip(@_); } +sub prune { Apache::TestHarness::prune(@_); } +sub get_tests { Apache::TestHarness::get_tests(@_);} + +sub install_sighandlers { + my $self = shift; + + $SIG{INT} = sub { + # make sure that there the server is down + $self->kill_proc(); + + $self->report_finish; + exit; + }; +} + +END { + local $?; # preserve the exit status + eval { + Apache::TestRun->new(test_config => + Apache::TestConfig->thaw)->scan_core; + }; +} + +sub run { + my($self) = shift; + + $self->Apache::TestRun::warn_core(); + local $SIG{INT}; + $self->install_sighandlers; + + $self->report_start(); + + if ($self->{bug_mode}) { + # 'make test', but useful for bug reports + $self->run_bug_mode(); + } + else { + # normal smoke + my $iter = 0; + while ($iter++ < $self->{run_iter}) { + my $last = $self->run_iter($iter); + last if $last; + } + } + $self->{smoking_completed} = 1; + $self->report_finish(); + exit; +} + +sub sep { + my($char, $title) = @_; + my $width = 60; + if ($title) { + my $side = int( ($width - length($title) - 2) / 2); + my $pad = ($side+1) * 2 + length($title) < $width ? 1 : 0; + return $char x $side . " $title " . $char x ($side+$pad); + } + else { + return $char x $width; + } +} + +my %log_files = (); +use constant FH => 0; +use constant POS => 1; +sub logs_init { + my($self, @log_files) = @_; + + for my $path (@log_files) { + my $fh = Symbol::gensym(); + open $fh, "<$path" or die "Can't open $path: $!"; + seek $fh, 0, POSIX::SEEK_END(); + $log_files{$path}[FH] = $fh; + $log_files{$path}[POS] = tell $fh; + } +} + +sub logs_end { + for my $path (keys %log_files) { + close $log_files{$path}[FH]; + } +} + +sub log_diff { + my($self, $path) = @_; + + my $log = $log_files{$path}; + die "no such log file: $path" unless $log; + + my $fh = $log->[FH]; + # no checkpoints were made yet? + unless (defined $log->[POS]) { + seek $fh, 0, POSIX::SEEK_END(); + $log->[POS] = tell $fh; + return ''; + } + + seek $fh, $log->[POS], POSIX::SEEK_SET(); # not really needed + local $/; # slurp mode + my $diff = <$fh>; + seek $fh, 0, POSIX::SEEK_END(); # not really needed + $log->[POS] = tell $fh; + + return $diff || ''; +} + +# this is a special mode, which really just runs 't/TEST -start; +# t/TEST -run; t/TEST -stop;' but it runs '-run' separately for each +# test, and checks whether anything bad has happened after the run +# of each test (i.e. either a test has failed, or a test may be successful, +# but server may have dumped a core file, we detect that). +sub run_bug_mode { + my($self) = @_; + + my $iter = 0; + + warning "running t/TEST in the bug report mode"; + + my $reduce_iter = 0; + my @good = (); + + # first time run all tests, or all specified tests + my @tests = @{ $self->{tests} }; # copy + my $bad = $self->run_test($iter, $reduce_iter, \@tests, \@good); + $self->{total_iterations}++; + +} + + +# returns true if for some reason no more iterations should be made +sub run_iter { + my($self, $iter) = @_; + my $stop_now = 0; + my $reduce_iter = 0; + my @good = (); + warning "\n" . sep("-"); + warning sprintf "[%03d-%02d-%02d] running all tests", + $iter, $reduce_iter, $self->{times}; + + + # first time run all tests, or all specified tests + my @tests = @{ $self->{tests} }; # copy + + # hack to ensure a new random seed is generated + Apache::TestSort->run(\@tests, $self); + + my $bad = $self->run_test($iter, $reduce_iter, \@tests, \@good); + unless ($bad) { + $self->{total_iterations}++; + return $stop_now; + } + error "recorded a positive failure ('$bad'), " . + "will try to minimize the input now"; + + my $command = $self->{base_command}; + + # does the test fail on its own + { + $reduce_iter++; + warning sprintf "[%03d-%02d-%02d] trying '$bad' on its own", + $iter, $reduce_iter, 1; + my @good = (); + my @tests = ($bad); + my $bad = $self->run_test($iter, $reduce_iter, \@tests, \@good); + # if a test is failing on its own there is no point to + # continue looking for other sequences + if ($bad) { + $stop_now = 1; + $self->{total_iterations}++; + unless ($self->sequence_seen($self->{results}, [@good, $bad])) { + $self->report_success($iter, $reduce_iter, "$command $bad", 1); + } + return $stop_now; + } + } + + # positive failure + my $ok_tests = @good; + my $reduction_success = 0; + my $done = 0; + while (@good > 1) { + my $tries = 0; + my $reduce_sub = $self->reduce_stream(\@good); + $reduce_iter++; + while ($tries++ < MAX_REDUCTION_TRIES) { + $self->{total_reduction_attempts}++; + my @try = @{ $reduce_sub->() }; + + # reduction stream is empty (tried all?) + unless (@try) { + $done = 1; + last; + } + + warning sprintf "\n[%03d-%02d-%02d] trying %d tests", + $iter, $reduce_iter, $tries, scalar(@try); + my @ok = (); + my @tests = (@try, $bad); + my $new_bad = $self->run_test($iter, $reduce_iter, \@tests, \@ok); + if ($new_bad) { + # successful reduction + $reduction_success++; + @good = @ok; + $tries = 0; + my $num = @ok; + error "*** reduction $reduce_iter succeeded ($num tests) ***"; + $self->{total_reduction_successes}++; + $self->log_successful_reduction($iter, \@ok); + last; + } + } + + # last round of reducing has failed, so we give up + if ($done || $tries >= MAX_REDUCTION_TRIES){ + error "no further reductions were made"; + $done = 1; + last; + } + + } + + # we have a minimal failure sequence at this point (to the extend + # of success of our attempts to reduce) + + # report the sequence if we didn't see such one yet in the + # previous iterations + unless ($self->sequence_seen($self->{results}, [@good, $bad])) { + # if no reduction succeeded, it's 0 + $reduce_iter = 0 unless $reduction_success; + $self->report_success($iter, $reduce_iter, + "$command @good $bad", @good + 1); + } + + $self->{total_iterations}++; + + return $stop_now; +} + +# my $sub = $self->reduce_stream(\@items); +sub reduce_stream { + my($self) = shift; + my @items = @{+shift}; + + my $items = @items; + my $odd = $items % 2 ? 1 : 0; + my $middle = int($items/2) - 1; + my $c = 0; + + return sub { + $c++; # remember stream's state + + # a single item is not reduce-able + return \@items if $items == 1; + + my @try = (); + my $max_repeat_tries = 50; # avoid seen sequences + my $repeat = 0; + while ($repeat++ <= $max_repeat_tries) { + + # try to use a binary search + if ($c == 1) { + # right half + @try = @items[($middle+1)..($items-1)]; + } + elsif ($c == 2) { + # left half + @try = @items[0..$middle]; + } + + # try to use a random window size alg + else { + my $left = int rand($items); + $left = $items - 1 if $left == $items - 1; + my $right = $left + int rand($items - $left); + $right = $items - 1 if $right >= $items; + @try = @items[$left..$right]; + } + + if ($self->sequence_seen($self->{seen}, \@try)) { + @try = (); + } + else { + last; # found an unseen sequence + } + } + return \@try; + } +} + +sub sequence_seen { + my ($self, $rh_store, $ra_tests) = @_; + + require Digest::MD5; + my $digest = Digest::MD5::md5_hex(join '', @$ra_tests); + #error $self->{seen}; + return $rh_store->{$digest}++ ? 1 : 0 + +} + +sub run_test { + require IPC::Run3; + my($self, $iter, $count, $tests, $ra_ok) = @_; + my $bad = ''; + my $ra_nok = []; + + #warning "$self->{base_command} @$tests"; + + #$SIG{PIPE} = 'IGNORE'; + $SIG{PIPE} = sub { die "pipe broke" }; + + # start server + { + my $command = $self->{start_command}; + my $log = ''; + IPC::Run3::run3($command, undef, \$log, \$log); + my $started_ok = ($log =~ /started/) ? 1 : 0; + unless ($started_ok) { + error "failed to start server\n $log"; + exit 1; + } + } + + my $t_logs = $self->{test_config}->{vars}->{t_logs}; + my @log_files = map { catfile $t_logs, $_ } qw(error_log access_log); + $self->logs_init(@log_files); + + # run tests + { + my $command = $self->{run_command}; + + my $max_len = 1; + for my $test (@$tests) { + $max_len = length $test if length $test > $max_len; + } + + for my $test (@$tests) { + (my $test_name = $test) =~ s/\.t$//; + my $fill = "." x ($max_len - length $test_name); + $self->{total_tests_run}++; + + my $test_command = "$command $test"; + my $log = ''; + IPC::Run3::run3($test_command, undef, \$log, \$log); + my $ok = ($log =~ /All tests successful|NOTESTS/) ? 1 : 0; + + my @core_files_msg = $self->Apache::TestRun::scan_core_incremental(1); + + # if the test has caused core file(s) it's not ok + $ok = 0 if @core_files_msg; + + if ($ok == 1) { + push @$ra_ok, $test; + if ($self->{verbose}) { + + if ($log =~ m/NOTESTS/) { + print STDERR "$test_name${fill}skipped\n"; + } else { + print STDERR "$test_name${fill}ok\n"; + } + } + # need to run log_diff to reset the position of the fh + my %log_diffs = map { $_ => $self->log_diff($_) } @log_files; + + } + elsif ($ok == 0) { + push @$ra_nok, $test; + $bad = $test; + + if ($self->{verbose}) { + print STDERR "$test_name${fill}FAILED\n"; + error sep("-"); + + # give server some time to finish the + # logging. it's ok to wait long time since we have + # to deal with an error + sleep 5; + my %log_diffs = map { $_ => $self->log_diff($_) } @log_files; + + # client log + error "\t\t*** run log ***"; + $log =~ s/^/ /mg; + print STDERR "$log\n"; + + # server logs + for my $path (@log_files) { + next unless length $log_diffs{$path}; + error "\t\t*** $path ***"; + $log_diffs{$path} =~ s/^/ /mg; + print STDERR "$log_diffs{$path}\n"; + } + } + if (@core_files_msg) { + unless ($self->{verbose}) { + # currently the output of 'run log' already + # includes the information about core files once + # Test::Harness::Straps allows us to run callbacks + # after each test, and we move back to run all + # tests at once, we will log the message here + error "$test_name caused core"; + print STDERR join "\n", @core_files_msg, "\n"; + } + } + + if ($self->{verbose}) { + error sep("-"); + } + + unless ($self->{bug_mode}) { + # normal smoke stop the run, but in the bug_mode + # we want to complete all the tests + last; + } + } + + + } + } + + $self->logs_end(); + + # stop server + $self->kill_proc(); + + if ($self->{bug_mode}) { + warning sep("-"); + if (@$ra_nok == 0) { + printf STDERR "All tests successful (%d)\n", scalar @$ra_ok; + } + else { + error sprintf "error running %d tests out of %d\n", + scalar(@$ra_nok), scalar @$ra_ok + @$ra_nok; + } + } + else { + return $bad; + } + + +} + +sub report_start { + my($self) = shift; + + my $time = scalar localtime; + $self->{start_time} = $time; + $time =~ s/\s/_/g; + $time =~ s/:/-/g; # winFU + my $file = $self->{opts}->{report} || + catfile Apache::Test::vars('top_dir'), "smoke-report-$time.txt"; + $self->{runtime}->{report} = $file; + info "Report file: $file"; + + open my $fh, ">$file" or die "cannot open $file for writing: $!"; + $self->{fh} = $fh; + my $sep = sep("-"); + my $title = sep('=', "Special Tests Sequence Failure Finder Report"); + + print $fh <<EOM; +$title +$sep +First iteration used: +$self->{base_command} @{$self->{tests}} +$sep +EOM + +} + +sub report_success { + my($self, $iter, $reduce_iter, $sequence, $tests) = @_; + + my @report = ("iteration $iter ($tests tests):\n", + "\t$sequence\n", + "(made $reduce_iter successful reductions)\n\n"); + + print @report; + if (my $fh = $self->{fh}) { + print $fh @report; + } +} + +sub report_finish { + my($self) = @_; + + my $start_time = $self->{start_time}; + my $end_time = scalar localtime; + if (my $fh = delete $self->{fh}) { + my $failures = scalar keys %{ $self->{results} }; + + my $sep = sep("-"); + my $cfg_as_string = $self->build_config_as_string; + my $unique_seqs = scalar keys %{ $self->{results} }; + my $attempts = $self->{total_reduction_attempts}; + my $successes = $self->{total_reduction_successes}; + my $completion = $self->{smoking_completed} + ? "Completed" + : "Not Completed (aborted by user)"; + + my $status = "Unknown"; + if ($self->{total_iterations} > 0) { + if ($failures) { + $status = "*** NOT OK ***"; + } + else { + $status = "+++ OK +++"; + } + } + + my $title = sep('=', "Summary"); + + my $iter_made = sprintf "Iterations (%s) made : %d", + $self->{order}, $self->{total_iterations}; + + print $fh <<EOM; + +$title +Completion : $completion +Status : $status +Tests run : $self->{total_tests_run} +$iter_made +EOM + + if ($attempts > 0 && $failures) { + my $reduction_stats = sprintf "%d/%d (%d%% success)", + $attempts, $successes, $successes / $attempts * 100; + + print $fh <<EOM; +Unique sequences found : $unique_seqs +Reduction tries/success : $reduction_stats +EOM + } + + print $fh <<EOM; +$sep +--- Started at: $start_time --- +--- Ended at: $end_time --- +$sep +The smoke testing was run on the system with the following +parameters: + +$cfg_as_string + +-- this report was generated by $0 +EOM + close $fh; + } +} + +# in case the smoke gets killed before it had a chance to finish and +# write the report, at least we won't lose the last successful reduction +# XXX: this wasn't needed before we switched to IPC::Run3, since +# Ctrl-C would log the collected data, but it doesn't work with +# IPC::Run3. So if that gets fixed, we can remove that function +sub log_successful_reduction { + my($self, $iter, $tests) = @_; + + my $file = $self->{runtime}->{report} . ".$iter.temp"; + debug "saving in $file"; + open my $fh, ">$file" or die "cannot open $file for writing: $!"; + print $fh join " ", @$tests; + close $fh; +} + +sub build_config_as_string { + Apache::TestConfig::as_string(); +} + +sub kill_proc { + my($self) = @_; + + my $command = $self->{stop_command}; + my $log = ''; + require IPC::Run3; + IPC::Run3::run3($command, undef, \$log, \$log); + + my $stopped_ok = ($log =~ /shutdown/) ? 1 : 0; + unless ($stopped_ok) { + error "failed to stop server\n $log"; + } +} + +sub opt_help { + my $self = shift; + + print <<EOM; +usage: t/SMOKE [options ...] [tests] + where the options are: +EOM + + for (sort keys %usage){ + printf " -%-16s %s\n", $_, $usage{$_}; + } + print <<EOM; + + if 'tests' argument is not provided all available tests will be run +EOM +} + +# generate t/SMOKE script (or a different filename) which will drive +# Apache::TestSmoke +sub generate_script { + my ($class, $file) = @_; + + $file ||= catfile 't', 'SMOKE'; + + my $content = join "\n", + "BEGIN { eval { require blib && blib->import; } }", + Apache::TestConfig->perlscript_header, + "use $class;", + "$class->new(\@ARGV)->run;"; + + Apache::Test::basic_config()->write_perlscript($file, $content); +} + +1; +__END__ + +=head1 NAME + +Apache::TestSmoke - Special Tests Sequence Failure Finder + +=head1 SYNOPSIS + + # get the usage and the default values + % t/SMOKE -help + + # repeat all tests 5 times and save the report into + # the file 'myreport' + % t/SMOKE -times=5 -report=myreport + + # run all tests default number of iterations, and repeat tests + # default number of times + % t/SMOKE + + # same as above but work only the specified tests + % t/SMOKE foo/bar foo/tar + + # run once a sequence of tests in a non-random mode + # e.g. when trying to reduce a known long sequence that fails + % t/SMOKE -order=rotate -times=1 foo/bar foo/tar + + # show me each currently running test + # it's not the same as running the tests in the verbose mode + % t/SMOKE -verbose + + # run t/TEST, but show any problems after *each* tests is run + # useful for bug reports (it actually runs t/TEST -start, then + # t/TEST -run for each test separately and finally t/TEST -stop + % t/SMOKE -bug_mode + + # now read the created report file + +=head1 DESCRIPTION + +=head2 The Problem + +When we try to test a stateless machine (i.e. all tests are +independent), running all tests once ensures that all tested things +properly work. However when a state machine is tested (i.e. where a +run of one test may influence another test) it's not enough to run all +the tests once to know that the tested features actually work. It's +quite possible that if the same tests are run in a different order +and/or repeated a few times, some tests may fail. This usually +happens when some tests don't restore the system under test to its +pristine state at the end of the run, which may influence other tests +which rely on the fact that they start on pristine state, when in fact +it's not true anymore. In fact it's possible that a single test may +fail when run twice or three times in a sequence. + +=head2 The Solution + +To reduce the possibility of such dependency errors, it's helpful to +run random testing repeated many times with many different srand +seeds. Of course if no failures get spotted that doesn't mean that +there are no tests inter-dependencies, which may cause a failure in +production. But random testing definitely helps to spot many problems +and can give better test coverage. + +=head2 Resolving Sequence Problems + +When this kind of testing is used and a failure is detected there are +two problems: + +=over + +=item 1 + +First is to be able to reproduce the problem so if we think we fixed +it, we could verify the fix. This one is easy, just remember the +sequence of tests run till the failed test and rerun the same sequence +once again after the problem has been fixed. + +=item 2 + +Second is to be able to understand the cause of the problem. If during +the random test the failure has happened after running 400 tests, how +can we possibly know which previously running tests has caused to the +failure of the test 401. Chances are that most of the tests were clean +and don't have inter-dependency problem. Therefore it'd be very +helpful if we could reduce the long sequence to a minimum. Preferably +1 or 2 tests. That's when we can try to understand the cause of the +detected problem. + +=back + +This utility attempts to solve both problems, and at the end of each +iteration print a minimal sequence of tests causing to a failure. This +doesn't always succeed, but works in many cases. + +This utility: + +=over + +=item 1 + +Runs the tests randomly until the first failure is detected. Or +non-randomly if the option I<-order> is set to I<repeat> or I<rotate>. + +=item 2 + +Then it tries to reduce that sequence of tests to a minimum, and this +sequence still causes to the same failure. + +=item 3 + +(XXX: todo): then it reruns the minimal sequence in the verbose mode +and saves the output. + +=item 4 + +It reports all the successful reductions as it goes to STDOUT and +report file of the format: smoke-report-<date>.txt. + +In addition the systems build parameters are logged into the report +file, so the detected problems could be reproduced. + +=item 5 + +Goto 1 and run again using a new random seed, which potentially should +detect different failures. + +=back + +=head1 Reduction Algorithm + +Currently for each reduction path, the following reduction algorithms +get applied: + +=over + +=item 1 + +Binary search: first try the upper half then the lower. + +=item 2 + +Random window: randomize the left item, then the right item and return +the items between these two points. + +=back + +=head1 t/SMOKE.PL + +I<t/SMOKE.PL> is driving this module, if you don't have it, create it: + + #!perl + + use strict; + use warnings FATAL => 'all'; + + use FindBin; + use lib "$FindBin::Bin/../Apache-Test/lib"; + use lib "$FindBin::Bin/../lib"; + + use Apache::TestSmoke (); + + Apache::TestSmoke->new(@ARGV)->run; + +usually I<Makefile.PL> converts it into I<t/SMOKE> while adjusting the +perl path, but you create I<t/SMOKE> in first place as well. + +=head1 AUTHOR + +Stas Bekman + +=cut diff --git a/debian/perl-framework/Apache-Test/lib/Apache/TestSmokePerl.pm b/debian/perl-framework/Apache-Test/lib/Apache/TestSmokePerl.pm new file mode 100644 index 0000000..265a4f7 --- /dev/null +++ b/debian/perl-framework/Apache-Test/lib/Apache/TestSmokePerl.pm @@ -0,0 +1,34 @@ +# 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::TestSmokePerl; + +use strict; +use warnings FATAL => 'all'; + +use Apache::TestSmoke (); +use ModPerl::Config (); + +# a subclass of Apache::TestSmoke that configures mod_perlish things +use vars qw(@ISA); +@ISA = qw(Apache::TestSmoke); + +sub build_config_as_string { + ModPerl::Config::as_string(); +} + +1; +__END__ + diff --git a/debian/perl-framework/Apache-Test/lib/Apache/TestSort.pm b/debian/perl-framework/Apache-Test/lib/Apache/TestSort.pm new file mode 100644 index 0000000..33eabc2 --- /dev/null +++ b/debian/perl-framework/Apache-Test/lib/Apache/TestSort.pm @@ -0,0 +1,76 @@ +# 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::TestSort; + +use strict; +use warnings FATAL => 'all'; +use Apache::TestTrace; + +sub repeat { + my($list) = @_; + return @{$list}; +} + +sub random { + my($list) = @_; + + my $seed = $ENV{APACHE_TEST_SEED} || ''; + my $info = ""; + + if ($seed) { + $info = " (user defined)"; + # so we could reproduce the order + } + else { + $info = " (autogenerated)"; + $seed = time ^ ($$ + ($$ << 15)); + } + + warning "Using random number seed: $seed" . $info; + + srand($seed); + + #from perlfaq4.pod + for (my $i = @$list; --$i; ) { + my $j = int rand($i+1); + next if $i == $j; + @$list[$i,$j] = @$list[$j,$i]; + } +} + +sub run { + my($self, $list, $args) = @_; + + my $order = $args->{order} || 'repeat'; + if ($order =~ /^\d+$/) { + #dont want an explicit -seed option but env var can be a pain + #so if -order is number assume it is the random seed + $ENV{APACHE_TEST_SEED} = $order; + $order = 'random'; + } + my $sort = \&{$order}; + + # re-shuffle the list according to the requested order + if (defined &$sort) { + $sort->($list); + } + else { + error "unknown order '$order'"; + } + +} + +1; diff --git a/debian/perl-framework/Apache-Test/lib/Apache/TestTrace.pm b/debian/perl-framework/Apache-Test/lib/Apache/TestTrace.pm new file mode 100644 index 0000000..00426ea --- /dev/null +++ b/debian/perl-framework/Apache-Test/lib/Apache/TestTrace.pm @@ -0,0 +1,256 @@ +# 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::TestTrace; + +use strict; +use warnings FATAL => 'all'; + +use Exporter (); +use vars qw(@Levels @Utils @Level_subs @Util_subs + @ISA @EXPORT $VERSION $Level $LogFH); + +BEGIN { + @Levels = qw(emerg alert crit error warning notice info debug); + @Utils = qw(todo); + @Level_subs = map {($_, "${_}_mark", "${_}_sub")} (@Levels); + @Util_subs = map {($_, "${_}_mark", "${_}_sub")} (@Utils); +} + +@ISA = qw(Exporter); +@EXPORT = (@Level_subs); +$VERSION = '0.01'; +use subs (@Level_subs, @Util_subs); + +# default settings overrideable by users +$Level = undef; +$LogFH = \*STDERR; + +# private data +use constant COLOR => ($ENV{APACHE_TEST_COLOR} && -t STDOUT) ? 1 : 0; +use constant HAS_COLOR => eval { + #XXX: another way to color WINFU terms? + !(grep { $^O eq $_ } qw(MSWin32 cygwin NetWare)) and + COLOR and require Term::ANSIColor; +}; +use constant HAS_DUMPER => eval { require Data::Dumper; }; + +# emerg => 1, alert => 2, crit => 3, ... +my %levels; @levels{@Levels} = 1..@Levels; +$levels{todo} = $levels{debug}; +my $default_level = 'info'; # to prevent user typos + +my %colors = (); + +if (HAS_COLOR) { + %colors = ( + emerg => 'bold white on_blue', + alert => 'bold blue on_yellow', + crit => 'reverse', + error => 'bold red', + warning => 'yellow', + notice => 'green', + info => 'cyan', + debug => 'magenta', + reset => 'reset', + todo => 'underline', + ); + + $Term::ANSIColor::AUTORESET = 1; + + for (keys %colors) { + $colors{$_} = Term::ANSIColor::color($colors{$_}); + } +} + +*expand = HAS_DUMPER ? + sub { map { ref $_ ? Data::Dumper::Dumper($_) : $_ } @_ } : + sub { @_ }; + +sub prefix { + my $prefix = shift; + + if ($prefix eq 'mark') { + return join(":", (caller(3))[1..2]) . " : "; + } + elsif ($prefix eq 'sub') { + return (caller(3))[3] . " : "; + } + else { + return ''; + } +} + +sub c_trace { + my ($level, $prefix_type) = (shift, shift); + my $prefix = prefix($prefix_type); + print $LogFH + map { "$colors{$level}$prefix$_$colors{reset}\n"} + grep defined($_), expand(@_); +} + +sub nc_trace { + my ($level, $prefix_type) = (shift, shift); + my $prefix = prefix($prefix_type); + print $LogFH + map { sprintf "[%7s] %s%s\n", $level, $prefix, $_ } + grep defined($_), expand(@_); +} + +{ + my $trace = HAS_COLOR ? \&c_trace : \&nc_trace; + my @prefices = ('', 'mark', 'sub'); + # if the level is sufficiently high, enable the tracing for a + # given level otherwise assign NOP + for my $level (@Levels, @Utils) { + no strict 'refs'; + for my $prefix (@prefices) { + my $func = $prefix ? "${level}_$prefix" : $level; + *$func = sub { $trace->($level, $prefix, @_) + if trace_level() >= $levels{$level}; + }; + } + } +} + +sub trace_level { + # overriden by user/-trace + (defined $Level && $levels{$Level}) || + # or overriden by env var + (exists $ENV{APACHE_TEST_TRACE_LEVEL} && + $levels{$ENV{APACHE_TEST_TRACE_LEVEL}}) || + # or default + $levels{$default_level}; +} + +1; +__END__ + +=head1 NAME + +Apache::TestTrace - Helper output generation functions + +=head1 SYNOPSIS + + use Apache::TestTrace; + + debug "foo bar"; + + info_sub "missed it"; + + error_mark "something is wrong"; + + # test sub that exercises all the tracing functions + sub test { + print $Apache::TestTrace::LogFH + "TraceLevel: $Apache::TestTrace::Level\n"; + $_->($_,[1..3],$_) for qw(emerg alert crit error + warning notice info debug todo); + print $Apache::TestTrace::LogFH "\n\n" + }; + + # demo the trace subs using default setting + test(); + + { + # override the default trace level with 'crit' + local $Apache::TestTrace::Level = 'crit'; + # now only 'crit' and higher levels will do tracing lower level + test(); + } + + { + # set the trace level to 'debug' + local $Apache::TestTrace::Level = 'debug'; + # now only 'debug' and higher levels will do tracing lower level + test(); + } + + { + open OUT, ">/tmp/foo" or die $!; + # override the default Log filehandle + local $Apache::TestTrace::LogFH = \*OUT; + # now the traces will go into a new filehandle + test(); + close OUT; + } + + # override tracing level via -trace opt + % t/TEST -trace=debug + + # override tracing level via env var + % env APACHE_TEST_TRACE_LEVEL=debug t/TEST + +=head1 DESCRIPTION + +This module exports a number of functions that make it easier +generating various diagnostics messages in your programs in a +consistent way and saves some keystrokes as it handles the new lines +and sends the messages to STDERR for you. + +This module provides the same trace methods as syslog(3)'s log +levels. Listed from low level to high level: emerg(), alert(), crit(), +error(), warning(), notice(), info(), debug(). The only different +function is warning(), since warn is already taken by Perl. + +The module provides another trace function called todo() which is +useful for todo items. It has the same level as I<debug> (the +highest). + +There are two more variants of each of these functions. If the +I<_mark> suffix is appended (e.g., I<error_mark>) the trace will start +with the filename and the line number the function was called from. If +the I<_sub> suffix is appended (e.g., I<error_info>) the trace will +start with the name of the subroutine the function was called from. + +If you have C<Term::ANSIColor> installed the diagnostic messages will +be colorized, otherwise a special for each function prefix will be +used. + +If C<Data::Dumper> is installed and you pass a reference to a variable +to any of these functions, the variable will be dumped with +C<Data::Dumper::Dumper()>. + +Functions whose level is above the level set in +C<$Apache::TestTrace::Level> become NOPs. For example if the level is +set to I<alert>, only alert() and emerg() functions will generate the +output. The default setting of this variable is I<warning>. Other +valid values are: I<emerg>, I<alert>, I<crit>, I<error>, I<warning>, +I<notice>, I<info>, I<debug>. + +Another way to affect the trace level is to set +C<$ENV{APACHE_TEST_TRACE_LEVEL}>, which takes effect if +C<$Apache::TestTrace::Level> is not set. So an explicit setting of +C<$Apache::TestTrace::Level> always takes precedence. + +By default all the output generated by these functions goes to +STDERR. You can override the default filehandler by overriding +C<$Apache::TestTrace::LogFH> with a new filehandler. + +When you override this package's global variables, think about +localizing your local settings, so it won't affect other modules using +this module in the same run. + +=head1 TODO + + o provide an option to disable the coloring altogether via some flag + or import() + +=head1 AUTHOR + +Stas Bekman with contributions from Doug MacEachern + +=cut + diff --git a/debian/perl-framework/Apache-Test/lib/Apache/TestUtil.pm b/debian/perl-framework/Apache-Test/lib/Apache/TestUtil.pm new file mode 100644 index 0000000..3e3c9cd --- /dev/null +++ b/debian/perl-framework/Apache-Test/lib/Apache/TestUtil.pm @@ -0,0 +1,989 @@ +# 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::TestUtil; + +use strict; +use warnings FATAL => 'all'; + +use File::Find (); +use File::Path (); +use Exporter (); +use Carp (); +use Config; +use File::Basename qw(dirname); +use File::Spec::Functions qw(catfile catdir file_name_is_absolute tmpdir); +use Symbol (); +use Fcntl qw(SEEK_END); + +use Apache::Test (); +use Apache::TestConfig (); + +use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %CLEAN); + +$VERSION = '0.02'; +@ISA = qw(Exporter); + +@EXPORT = qw(t_cmp t_debug t_append_file t_write_file t_open_file + t_mkdir t_rmtree t_is_equal t_filepath_cmp t_write_test_lib + t_server_log_error_is_expected t_server_log_warn_is_expected + t_client_log_error_is_expected t_client_log_warn_is_expected +); + +@EXPORT_OK = qw(t_write_perl_script t_write_shell_script t_chown + t_catfile_apache t_catfile t_file_watch_for + t_start_error_log_watch t_finish_error_log_watch + t_start_file_watch t_read_file_watch t_finish_file_watch); + +%CLEAN = (); + +$Apache::TestUtil::DEBUG_OUTPUT = \*STDOUT; + +# 5.005's Data::Dumper has problems to dump certain datastructures +use constant HAS_DUMPER => eval { $] >= 5.006 && require Data::Dumper; }; +use constant INDENT => 4; + +{ + my %files; + sub t_start_file_watch (;$) { + my $name = defined $_[0] ? $_[0] : 'error_log'; + $name = File::Spec->catfile(Apache::Test::vars->{t_logs}, $name) + unless (File::Spec->file_name_is_absolute($name)); + + if (open my $fh, '<', $name) { + seek $fh, 0, SEEK_END; + $files{$name} = $fh; + } + else { + delete $files{$name}; + } + + return; + } + + sub t_finish_file_watch (;$) { + my $name = defined $_[0] ? $_[0] : 'error_log'; + $name = File::Spec->catfile(Apache::Test::vars->{t_logs}, $name) + unless (File::Spec->file_name_is_absolute($name)); + + my $fh = delete $files{$name}; + unless (defined $fh) { + open $fh, '<', $name or return; + return readline $fh; + } + + return readline $fh; + } + + sub t_read_file_watch (;$) { + my $name = defined $_[0] ? $_[0] : 'error_log'; + $name = File::Spec->catfile(Apache::Test::vars->{t_logs}, $name) + unless (File::Spec->file_name_is_absolute($name)); + + my $fh = $files{$name}; + unless (defined $fh) { + open $fh, '<', $name or return; + $files{$name} = $fh; + } + + return readline $fh; + } + + sub t_file_watch_for ($$$) { + my ($name, $re, $timeout) = @_; + local $/ = "\n"; + $re = qr/$re/ unless ref $re; + $timeout *= 10; + my $buf = ''; + my @acc; + while ($timeout >= 0) { + my $line = t_read_file_watch $name; + unless (defined $line) { # EOF + select undef, undef, undef, 0.1; + $timeout--; + next; + } + $buf .= $line; + next unless $buf =~ /\n$/; # incomplete line + + # found a complete line + $line = $buf; + $buf = ''; + + push @acc, $line; + return wantarray ? @acc : $line if $line =~ $re; + } + return; + } + + sub t_start_error_log_watch { + t_start_file_watch; + } + + sub t_finish_error_log_watch { + local $/ = "\n"; + return my @lines = t_finish_file_watch; + } +} + +# because of the prototype and recursive call to itself a forward +# declaration is needed +sub t_is_equal ($$); + +# compare any two datastructures (must pass references for non-scalars) +# undef()'s are valid args +sub t_is_equal ($$) { + my ($a, $b) = @_; + return 0 unless @_ == 2; + + # this was added in Apache::Test::VERSION 1.12 - remove deprecated + # logic sometime around 1.15 or mid September, 2004. + if (UNIVERSAL::isa($a, 'Regexp')) { + my @warning = ("WARNING!!! t_is_equal() argument order has changed.", + "use of a regular expression as the first argument", + "is deprecated. support will be removed soon."); + t_debug(@warning); + ($a, $b) = ($b, $a); + } + + if (defined $a && defined $b) { + my $ref_a = ref $a; + my $ref_b = ref $b; + if (!$ref_a && !$ref_b) { + return $a eq $b; + } + elsif ($ref_a eq 'ARRAY' && $ref_b eq 'ARRAY') { + return 0 unless @$a == @$b; + for my $i (0..$#$a) { + t_is_equal($a->[$i], $b->[$i]) || return 0; + } + } + elsif ($ref_a eq 'HASH' && $ref_b eq 'HASH') { + return 0 unless (keys %$a) == (keys %$b); + for my $key (sort keys %$a) { + return 0 unless exists $b->{$key}; + t_is_equal($a->{$key}, $b->{$key}) || return 0; + } + } + elsif ($ref_b eq 'Regexp') { + return $a =~ $b; + } + else { + # try to compare the references + return $a eq $b; + } + } + else { + # undef == undef! a valid test + return (defined $a || defined $b) ? 0 : 1; + } + return 1; +} + + + +sub t_cmp ($$;$) { + Carp::carp(join(":", (caller)[1..2]) . + ' usage: $res = t_cmp($received, $expected, [$comment])') + if @_ < 2 || @_ > 3; + + my ($received, $expected) = @_; + + # this was added in Apache::Test::VERSION 1.12 - remove deprecated + # logic sometime around 1.15 or mid September, 2004. + if (UNIVERSAL::isa($_[0], 'Regexp')) { + my @warning = ("WARNING!!! t_cmp() argument order has changed.", + "use of a regular expression as the first argument", + "is deprecated. support will be removed soon."); + t_debug(@warning); + ($received, $expected) = ($expected, $received); + } + + t_debug("testing : " . pop) if @_ == 3; + t_debug("expected: " . struct_as_string(0, $expected)); + t_debug("received: " . struct_as_string(0, $received)); + return t_is_equal($received, $expected); +} + +# Essentially t_cmp, but on Win32, first converts pathnames +# to their DOS long name. +sub t_filepath_cmp ($$;$) { + my @a = (shift, shift); + if (Apache::TestConfig::WIN32) { + $a[0] = Win32::GetLongPathName($a[0]) if defined $a[0] && -e $a[0]; + $a[1] = Win32::GetLongPathName($a[1]) if defined $a[1] && -e $a[1]; + } + return @_ == 1 ? t_cmp($a[0], $a[1], $_[0]) : t_cmp($a[0], $a[1]); +} + + +*expand = HAS_DUMPER ? + sub { map { ref $_ ? Data::Dumper::Dumper($_) : $_ } @_ } : + sub { @_ }; + +sub t_debug { + my $out = $Apache::TestUtil::DEBUG_OUTPUT; + print $out map {"# $_\n"} map {split /\n/} grep {defined} expand(@_); +} + +sub t_open_file { + my $file = shift; + + die "must pass a filename" unless defined $file; + + # create the parent dir if it doesn't exist yet + makepath(dirname $file); + + my $fh = Symbol::gensym(); + open $fh, ">$file" or die "can't open $file: $!"; + t_debug("writing file: $file"); + $CLEAN{files}{$file}++; + + return $fh; +} + +sub _temp_package_dir { + return catdir(tmpdir(), 'apache_test'); +} + +sub t_write_test_lib { + my $file = shift; + + die "must pass a filename" unless defined $file; + + t_write_file(catdir(_temp_package_dir(), $file), @_); +} + +sub t_write_file { + my $file = shift; + + die "must pass a filename" unless defined $file; + + # create the parent dir if it doesn't exist yet + makepath(dirname $file); + + my $fh = Symbol::gensym(); + open $fh, ">$file" or die "can't open $file: $!"; + t_debug("writing file: $file"); + print $fh join '', @_ if @_; + close $fh; + $CLEAN{files}{$file}++; +} + +sub t_append_file { + my $file = shift; + + die "must pass a filename" unless defined $file; + + # create the parent dir if it doesn't exist yet + makepath(dirname $file); + + # add to the cleanup list only if we created it now + $CLEAN{files}{$file}++ unless -e $file; + + my $fh = Symbol::gensym(); + open $fh, ">>$file" or die "can't open $file: $!"; + print $fh join '', @_ if @_; + close $fh; +} + +sub t_write_shell_script { + my $file = shift; + + my $code = join '', @_; + my($ext, $shebang); + + if (Apache::TestConfig::WIN32()) { + $code =~ s/echo$/echo./mg; #required to echo newline + $ext = 'bat'; + $shebang = "\@echo off\nREM this is a bat"; + } + else { + $ext = 'sh'; + $shebang = '#!/bin/sh'; + } + + $file .= ".$ext"; + t_write_file($file, "$shebang\n", $code); + $ext; +} + +sub t_write_perl_script { + my $file = shift; + + my $shebang = "#!$Config{perlpath}\n"; + my $warning = Apache::TestConfig->thaw->genwarning($file); + t_write_file($file, $shebang, $warning, @_); + chmod 0755, $file; +} + + +sub t_mkdir { + my $dir = shift; + makepath($dir); +} + +# returns a list of dirs successfully created +sub makepath { + my($path) = @_; + + return if !defined($path) || -e $path; + my $full_path = $path; + + # remember which dirs were created and should be cleaned up + while (1) { + $CLEAN{dirs}{$path} = 1; + $path = dirname $path; + last if -e $path; + } + + return File::Path::mkpath($full_path, 0, 0755); +} + +sub t_rmtree { + die "must pass a dirname" unless defined $_[0]; + File::Path::rmtree((@_ > 1 ? \@_ : $_[0]), 0, 1); +} + +#chown a file or directory to the test User/Group +#noop if chown is unsupported + +sub t_chown { + my $file = shift; + my $config = Apache::Test::config(); + my($uid, $gid); + + eval { + #XXX cache this lookup + ($uid, $gid) = (getpwnam($config->{vars}->{user}))[2,3]; + }; + + if ($@) { + if ($@ =~ /^The getpwnam function is unimplemented/) { + #ok if unsupported, e.g. win32 + return 1; + } + else { + die $@; + } + } + + CORE::chown($uid, $gid, $file) || die "chown $file: $!"; +} + +# $string = struct_as_string($indent_level, $var); +# +# return any nested datastructure via Data::Dumper or ala Data::Dumper +# as a string. undef() is a valid arg. +# +# $indent_level should be 0 (used for nice indentation during +# recursive datastructure traversal) +sub struct_as_string{ + return "???" unless @_ == 2; + my $level = shift; + + return "undef" unless defined $_[0]; + my $pad = ' ' x (($level + 1) * INDENT); + my $spad = ' ' x ($level * INDENT); + + if (HAS_DUMPER) { + local $Data::Dumper::Terse = 1; + $Data::Dumper::Terse = $Data::Dumper::Terse; # warn + my $data = Data::Dumper::Dumper(@_); + $data =~ s/\n$//; # \n is handled by the caller + return $data; + } + else { + if (ref($_[0]) eq 'ARRAY') { + my @data = (); + for my $i (0..$#{ $_[0] }) { + push @data, + struct_as_string($level+1, $_[0]->[$i]); + } + return join "\n", "[", map({"$pad$_,"} @data), "$spad\]"; + } elsif ( ref($_[0])eq 'HASH') { + my @data = (); + for my $key (keys %{ $_[0] }) { + push @data, + "$key => " . + struct_as_string($level+1, $_[0]->{$key}); + } + return join "\n", "{", map({"$pad$_,"} @data), "$spad\}"; + } else { + return $_[0]; + } + } +} + +my $banner_format = + "\n*** The following %s expected and harmless ***\n"; + +sub is_expected_banner { + my $type = shift; + my $count = @_ ? shift : 1; + sprintf $banner_format, $count == 1 + ? "$type entry is" + : "$count $type entries are"; +} + +sub t_server_log_is_expected { + print STDERR is_expected_banner(@_); +} + +sub t_client_log_is_expected { + my $vars = Apache::Test::config()->{vars}; + my $log_file = catfile $vars->{serverroot}, "logs", "error_log"; + + my $fh = Symbol::gensym(); + open $fh, ">>$log_file" or die "Can't open $log_file: $!"; + my $oldfh = select($fh); $| = 1; select($oldfh); + print $fh is_expected_banner(@_); + close $fh; +} + +sub t_server_log_error_is_expected { t_server_log_is_expected("error", @_);} +sub t_server_log_warn_is_expected { t_server_log_is_expected("warn", @_); } +sub t_client_log_error_is_expected { t_client_log_is_expected("error", @_);} +sub t_client_log_warn_is_expected { t_client_log_is_expected("warn", @_); } + +END { + # remove files that were created via this package + for (grep {-e $_ && -f _ } keys %{ $CLEAN{files} } ) { + t_debug("removing file: $_"); + unlink $_; + } + + # remove dirs that were created via this package + for (grep {-e $_ && -d _ } keys %{ $CLEAN{dirs} } ) { + t_debug("removing dir tree: $_"); + t_rmtree($_); + } +} + +# essentially File::Spec->catfile, but on Win32 +# returns the long path name, if the file is absolute +sub t_catfile { + my $f = catfile(@_); + return $f unless file_name_is_absolute($f); + return Apache::TestConfig::WIN32 && -e $f ? + Win32::GetLongPathName($f) : $f; +} + +# Apache uses a Unix-style specification for files, with +# forward slashes for directory separators. This is +# essentially File::Spec::Unix->catfile, but on Win32 +# returns the long path name, if the file is absolute +sub t_catfile_apache { + my $f = File::Spec::Unix->catfile(@_); + return $f unless file_name_is_absolute($f); + return Apache::TestConfig::WIN32 && -e $f ? + Win32::GetLongPathName($f) : $f; +} + +1; +__END__ + +=encoding utf8 + +=head1 NAME + +Apache::TestUtil - Utility functions for writing tests + +=head1 SYNOPSIS + + use Apache::Test; + use Apache::TestUtil; + + ok t_cmp("foo", "foo", "sanity check"); + t_write_file("filename", @content); + my $fh = t_open_file($filename); + t_mkdir("/foo/bar"); + t_rmtree("/foo/bar"); + t_is_equal($a, $b); + +=head1 DESCRIPTION + +C<Apache::TestUtil> automatically exports a number of functions useful +in writing tests. + +All the files and directories created using the functions from this +package will be automatically destroyed at the end of the program +execution (via END block). You should not use these functions other +than from within tests which should cleanup all the created +directories and files at the end of the test. + +=head1 FUNCTIONS + +=over + +=item t_cmp() + + t_cmp($received, $expected, $comment); + +t_cmp() prints the values of I<$comment>, I<$expected> and +I<$received>. e.g.: + + t_cmp(1, 1, "1 == 1?"); + +prints: + + # testing : 1 == 1? + # expected: 1 + # received: 1 + +then it returns the result of comparison of the I<$expected> and the +I<$received> variables. Usually, the return value of this function is +fed directly to the ok() function, like this: + + ok t_cmp(1, 1, "1 == 1?"); + +the third argument (I<$comment>) is optional, mostly useful for +telling what the comparison is trying to do. + +It is valid to use C<undef> as an expected value. Therefore: + + my $foo; + t_cmp(undef, $foo, "undef == undef?"); + +will return a I<true> value. + +You can compare any two data-structures with t_cmp(). Just make sure +that if you pass non-scalars, you have to pass their references. The +datastructures can be deeply nested. For example you can compare: + + t_cmp({1 => [2..3,{5..8}], 4 => [5..6]}, + {1 => [2..3,{5..8}], 4 => [5..6]}, + "hash of array of hashes"); + +You can also compare the second argument against the first as a +regex. Use the C<qr//> function in the second argument. For example: + + t_cmp("abcd", qr/^abc/, "regex compare"); + +will do: + + "abcd" =~ /^abc/; + +This function is exported by default. + +=item t_filepath_cmp() + +This function is used to compare two filepaths via t_cmp(). +For non-Win32, it simply uses t_cmp() for the comparison, +but for Win32, Win32::GetLongPathName() is invoked to convert +the first two arguments to their DOS long pathname. This is useful +when there is a possibility the two paths being compared +are not both represented by their long or short pathname. + +This function is exported by default. + +=item t_debug() + + t_debug("testing feature foo"); + t_debug("test", [1..3], 5, {a=>[1..5]}); + +t_debug() prints out any datastructure while prepending C<#> at the +beginning of each line, to make the debug printouts comply with +C<Test::Harness>'s requirements. This function should be always used +for debug prints, since if in the future the debug printing will +change (e.g. redirected into a file) your tests won't need to be +changed. + +the special global variable $Apache::TestUtil::DEBUG_OUTPUT can +be used to redirect the output from t_debug() and related calls +such as t_write_file(). for example, from a server-side test +you would probably need to redirect it to STDERR: + + sub handler { + plan $r, tests => 1; + + local $Apache::TestUtil::DEBUG_OUTPUT = \*STDERR; + + t_write_file('/tmp/foo', 'bar'); + ... + } + +left to its own devices, t_debug() will collide with the standard +HTTP protocol during server-side tests, resulting in a situation +both confusing difficult to debug. but STDOUT is left as the +default, since you probably don't want debug output under normal +circumstances unless running under verbose mode. + +This function is exported by default. + +=item t_write_test_lib() + + t_write_test_lib($filename, @lines) + +t_write_test_lib() creates a new file at I<$filename> or overwrites +the existing file with the content passed in I<@lines>. The file +is created in a temporary directory which is added to @INC at +test configuration time. It is intended to be used for creating +temporary packages for testing which can be modified at run time, +see the Apache::Reload unit tests for an example. + +=item t_write_file() + + t_write_file($filename, @lines); + +t_write_file() creates a new file at I<$filename> or overwrites the +existing file with the content passed in I<@lines>. If only the +I<$filename> is passed, an empty file will be created. + +If parent directories of C<$filename> don't exist they will be +automagically created. + +The generated file will be automatically deleted at the end of the +program's execution. + +This function is exported by default. + +=item t_append_file() + + t_append_file($filename, @lines); + +t_append_file() is similar to t_write_file(), but it doesn't clobber +existing files and appends C<@lines> to the end of the file. If the +file doesn't exist it will create it. + +If parent directories of C<$filename> don't exist they will be +automagically created. + +The generated file will be registered to be automatically deleted at +the end of the program's execution, only if the file was created by +t_append_file(). + +This function is exported by default. + +=item t_write_shell_script() + + Apache::TestUtil::t_write_shell_script($filename, @lines); + +Similar to t_write_file() but creates a portable shell/batch +script. The created filename is constructed from C<$filename> and an +appropriate extension automatically selected according to the platform +the code is running under. + +It returns the extension of the created file. + +=item t_write_perl_script() + + Apache::TestUtil::t_write_perl_script($filename, @lines); + +Similar to t_write_file() but creates a executable Perl script with +correctly set shebang line. + +=item t_open_file() + + my $fh = t_open_file($filename); + +t_open_file() opens a file I<$filename> for writing and returns the +file handle to the opened file. + +If parent directories of C<$filename> don't exist they will be +automagically created. + +The generated file will be automatically deleted at the end of the +program's execution. + +This function is exported by default. + +=item t_mkdir() + + t_mkdir($dirname); + +t_mkdir() creates a directory I<$dirname>. The operation will fail if +the parent directory doesn't exist. + +If parent directories of C<$dirname> don't exist they will be +automagically created. + +The generated directory will be automatically deleted at the end of +the program's execution. + +This function is exported by default. + +=item t_rmtree() + + t_rmtree(@dirs); + +t_rmtree() deletes the whole directories trees passed in I<@dirs>. + +This function is exported by default. + +=item t_chown() + + Apache::TestUtil::t_chown($file); + +Change ownership of $file to the test's I<User>/I<Group>. This +function is noop on platforms where chown(2) is unsupported +(e.g. Win32). + +=item t_is_equal() + + t_is_equal($a, $b); + +t_is_equal() compares any two datastructures and returns 1 if they are +exactly the same, otherwise 0. The datastructures can be nested +hashes, arrays, scalars, undefs or a combination of any of these. See +t_cmp() for an example. + +If C<$b> is a regex reference, the regex comparison C<$a =~ $b> is +performed. For example: + + t_is_equal($server_version, qr{^Apache}); + +If comparing non-scalars make sure to pass the references to the +datastructures. + +This function is exported by default. + +=item t_server_log_error_is_expected() + +If the handler's execution results in an error or a warning logged to +the I<error_log> file which is expected, it's a good idea to have a +disclaimer printed before the error itself, so one can tell real +problems with tests from expected errors. For example when testing how +the package behaves under error conditions the I<error_log> file might +be loaded with errors, most of which are expected. + +For example if a handler is about to generate a run-time error, this +function can be used as: + + use Apache::TestUtil; + ... + sub handler { + my $r = shift; + ... + t_server_log_error_is_expected(); + die "failed because ..."; + } + +After running this handler the I<error_log> file will include: + + *** The following error entry is expected and harmless *** + [Tue Apr 01 14:00:21 2003] [error] failed because ... + +When more than one entry is expected, an optional numerical argument, +indicating how many entries to expect, can be passed. For example: + + t_server_log_error_is_expected(2); + +will generate: + + *** The following 2 error entries are expected and harmless *** + +If the error is generated at compile time, the logging must be done in +the BEGIN block at the very beginning of the file: + + BEGIN { + use Apache::TestUtil; + t_server_log_error_is_expected(); + } + use DOES_NOT_exist; + +After attempting to run this handler the I<error_log> file will +include: + + *** The following error entry is expected and harmless *** + [Tue Apr 01 14:04:49 2003] [error] Can't locate "DOES_NOT_exist.pm" + in @INC (@INC contains: ... + +Also see C<t_server_log_warn_is_expected()> which is similar but used +for warnings. + +This function is exported by default. + +=item t_server_log_warn_is_expected() + +C<t_server_log_warn_is_expected()> generates a disclaimer for expected +warnings. + +See the explanation for C<t_server_log_error_is_expected()> for more +details. + +This function is exported by default. + +=item t_client_log_error_is_expected() + +C<t_client_log_error_is_expected()> generates a disclaimer for +expected errors. But in contrast to +C<t_server_log_error_is_expected()> called by the client side of the +script. + +See the explanation for C<t_server_log_error_is_expected()> for more +details. + +For example the following client script fails to find the handler: + + use Apache::Test; + use Apache::TestUtil; + use Apache::TestRequest qw(GET); + + plan tests => 1; + + t_client_log_error_is_expected(); + my $url = "/error_document/cannot_be_found"; + my $res = GET($url); + ok t_cmp(404, $res->code, "test 404"); + +After running this test the I<error_log> file will include an entry +similar to the following snippet: + + *** The following error entry is expected and harmless *** + [Tue Apr 01 14:02:55 2003] [error] [client 127.0.0.1] + File does not exist: /tmp/test/t/htdocs/error + +When more than one entry is expected, an optional numerical argument, +indicating how many entries to expect, can be passed. For example: + + t_client_log_error_is_expected(2); + +will generate: + + *** The following 2 error entries are expected and harmless *** + +This function is exported by default. + +=item t_client_log_warn_is_expected() + +C<t_client_log_warn_is_expected()> generates a disclaimer for expected +warnings on the client side. + +See the explanation for C<t_client_log_error_is_expected()> for more +details. + +This function is exported by default. + +=item t_catfile('a', 'b', 'c') + +This function is essentially C<File::Spec-E<gt>catfile>, but +on Win32 will use C<Win32::GetLongpathName()> to convert the +result to a long path name (if the result is an absolute file). +The function is not exported by default. + +=item t_catfile_apache('a', 'b', 'c') + +This function is essentially C<File::Spec::Unix-E<gt>catfile>, but +on Win32 will use C<Win32::GetLongpathName()> to convert the +result to a long path name (if the result is an absolute file). +It is useful when comparing something to that returned by Apache, +which uses a Unix-style specification with forward slashes for +directory separators. The function is not exported by default. + +=item t_start_error_log_watch(), t_finish_error_log_watch() + +This pair of functions provides an easy interface for checking +the presence or absense of any particular message or messages +in the httpd error_log that were generated by the httpd daemon +as part of a test suite. It is likely, that you should proceed +this with a call to one of the t_*_is_expected() functions. + + t_start_error_log_watch(); + do_it; + ok grep {...} t_finish_error_log_watch(); + +Another usage case could be a handler that emits some debugging messages +to the error_log. Now, if this handler is called in a series of other +test cases it can be hard to find the relevant messages manually. In such +cases the following sequence in the test file may help: + + t_start_error_log_watch(); + GET '/this/or/that'; + t_debug t_finish_error_log_watch(); + +=item t_start_file_watch() + + Apache::TestUtil::t_start_file_watch('access_log'); + +This function is similar to C<t_start_error_log_watch()> but allows for +other files than C<error_log> to be watched. It opens the given file +and positions the file pointer at its end. Subsequent calls to +C<t_read_file_watch()> or C<t_finish_file_watch()> will read lines that +have been appended after this call. + +A file name can be passed as parameter. If omitted +or undefined the C<error_log> is opened. Relative file name are +evaluated relative to the directory containing C<error_log>. + +If the specified file does not exist (yet) no error is returned. It is +assumed that it will appear soon. In this case C<t_{read,finish}_file_watch()> +will open the file silently and read from the beginning. + +=item t_read_file_watch(), t_finish_file_watch() + + local $/ = "\n"; + $line1=Apache::TestUtil::t_read_file_watch('access_log'); + $line2=Apache::TestUtil::t_read_file_watch('access_log'); + + @lines=Apache::TestUtil::t_finish_file_watch('access_log'); + +This pair of functions reads the file opened by C<t_start_error_log_watch()>. + +As does the core C<readline> function, they return one line if called in +scalar context, otherwise all lines until end of file. + +Before calling C<readline> these functions do not set C<$/> as does +C<t_finish_error_log_watch>. So, if the file has for example a fixed +record length use this: + + { + local $/=\$record_length; + @lines=t_finish_file_watch($name); + } + +=item t_file_watch_for() + + @lines=Apache::TestUtil::t_file_watch_for('access_log', + qr/condition/, + $timeout); + +This function reads the file from the current position and looks for the +first line that matches C<qr/condition/>. If no such line could be found +until end of file the function pauses and retries until either such a line +is found or the timeout (in seconds) is reached. + +In scalar or void context only the matching line is returned. In list +context all read lines are returned with the matching one in last position. + +The function uses C<\n> and end-of-line marker and waits for complete lines. + +The timeout although it can be specified with sub-second precision is not very +accurate. It is simply multiplied by 10. The result is used as a maximum loop +count. For the intented purpose this should be good enough. + +Use this function to check for logfile entries when you cannot be sure that +they are already written when the test program reaches the point, for example +to check for messages that are written in a PerlCleanupHandler or a +PerlLogHandler. + + ok t_file_watch_for 'access_log', qr/expected log entry/, 2; + +This call reads the C<access_log> and waits for maximum 2 seconds for the +expected entry to appear. + +=back + +=head1 AUTHOR + +Stas Bekman <stas@stason.org>, +Torsten Förtsch <torsten.foertsch@gmx.net> + +=head1 SEE ALSO + +perl(1) + +=cut + |