Index: Apache-Test/Makefile.PL =================================================================== RCS file: /home/cvs/httpd-test/perl-framework/Apache-Test/Makefile.PL,v retrieving revision 1.8 diff -u -r1.8 Makefile.PL --- Apache-Test/Makefile.PL 29 Apr 2003 06:37:47 -0000 1.8 +++ Apache-Test/Makefile.PL 20 May 2003 00:03:35 -0000 @@ -2,6 +2,7 @@ use ExtUtils::MakeMaker; use Symbol; +use File::Spec::Functions qw(catfile); use lib qw(lib); @@ -19,6 +20,11 @@ Apache::TestMM::generate_script($_); } +my $Apache_test_file = catfile qw(lib Apache test.pm); +write_Apache_test($Apache_test_file); + +my @clean_files = ($Apache_test_file); + set_version(); WriteMakefile( @@ -27,6 +33,9 @@ dist => { COMPRESS => 'gzip -9f', SUFFIX=>'gz', }, + clean => { + FILES => "@clean_files", + }, ); sub set_version { @@ -59,3 +68,25 @@ return $string; } +sub write_Apache_test { + my $file = shift; + + my $fh = Symbol::gensym(); + open $fh, ">$file" or die "Can't open $file: $!"; + print $fh <<'EOF'; + +# WARNING: this file is autogenerated, change Makefile.PL instead + +# this is a workaround for a collision we have on the case-insensitive +# platforms which may have Apache/test.pm from mod_perl 1.0 +# installed. + +require Apache::TestReal; + +# this is a workaround for ExtUtils::MakeMaker::parse_version +$VERSION = do { require Apache::test_mp1; $Apache::test::VERSION }; + +1; +EOF + +} Index: Apache-Test/lib/Apache/Test.pm =================================================================== RCS file: /home/cvs/httpd-test/perl-framework/Apache-Test/lib/Apache/Test.pm,v retrieving revision 1.59 diff -u -r1.59 Test.pm --- Apache-Test/lib/Apache/Test.pm 3 May 2003 03:15:12 -0000 1.59 +++ Apache-Test/lib/Apache/Test.pm 20 May 2003 00:03:35 -0000 @@ -1,612 +1,10 @@ -package Apache::Test; +# this is a workaround for a collision we have on the case-insensitive +# platforms which may have Apache/test.pm from mod_perl 1.0 +# installed. -use strict; -use warnings FATAL => 'all'; +require Apache::test_mp1; -use Test qw(ok skip); -use Exporter (); -use Config; -use Apache::TestConfig (); - -use vars qw(@ISA @EXPORT $VERSION %SubTests @SkipReasons); - -@ISA = qw(Exporter); -@EXPORT = qw(ok skip sok plan have have_lwp have_http11 - have_cgi have_access have_auth have_module have_apache - have_min_apache_version have_apache_version have_perl - have_threads under_construction); -$VERSION = '1.03'; - -%SubTests = (); -@SkipReasons = (); - -if (my $subtests = $ENV{HTTPD_TEST_SUBTESTS}) { - %SubTests = map { $_, 1 } split /\s+/, $subtests; -} - -my $Config; - -sub config { - $Config ||= Apache::TestConfig->thaw; -} - -sub vars { - config()->{vars}; -} - -sub sok (&;$) { - my $sub = shift; - my $nok = shift || 1; #allow sok to have 'ok' within - - if (%SubTests and not $SubTests{ $Test::ntest }) { - for my $n (1..$nok) { - skip "skipping this subtest", 0; - } - return; - } - - ok $sub->(); -} - -#so Perl's Test.pm can be run inside mod_perl -sub test_pm_refresh { - $Test::TESTOUT = \*STDOUT; - $Test::planned = 0; - $Test::ntest = 1; - %Test::todo = (); -} - -sub init_test_pm { - my $r = shift; - - # needed to load Apache::RequestRec::TIEHANDLE - eval {require Apache::RequestIO}; - if (defined &Apache::RequestRec::TIEHANDLE) { - untie *STDOUT; - tie *STDOUT, $r; - require Apache::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 have_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 have_ssl { - my $vars = vars(); - have_module([$vars->{ssl_module_name}, 'Net::SSL']); -} - -sub have_lwp { - require Apache::TestRequest; - if (Apache::TestRequest::has_lwp()) { - return 1; - } - else { - push @SkipReasons, "libwww-perl is not installed"; - return 0; - } -} - -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 = have_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"; - exit; #XXX: Apache->exit - } - } - @SkipReasons = (); # reset - - Test::plan(@_); -} - -sub have { - my $have_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; - $have_all = 0; - } - } - else { - $have_all = 0 unless have_module($cond); - } - } - return $have_all; - -} - -sub have_module { - my $cfg = config(); - my @modules = ref($_[0]) ? @{ $_[0] } : @_; - - my @reasons = (); - for (@modules) { - if (/^[a-z0-9_.]+$/) { - my $mod = $_; - unless ($mod =~ /\.c$/) { - $mod = 'mod_' . $mod unless $mod =~ /^mod_/; - $mod .= '.c' - } - next if $cfg->{modules}->{$mod}; - if (exists $cfg->{cmodules_disabled}->{$mod}) { - push @reasons, $cfg->{cmodules_disabled}->{$mod}; - next; - } - } - die "bogus module name $_" unless /^[\w:.]+$/; - eval "require $_"; - #print $@ if $@; - if ($@) { - push @reasons, "cannot find module '$_'"; - } - } - if (@reasons) { - push @SkipReasons, @reasons; - return 0; - } - else { - return 1; - } -} - -sub have_cgi { - have_module('cgi') || have_module('cgid'); -} - -sub have_access { - have_module('access') || have_module('authz_host'); -} - -sub have_auth { - have_module('auth') || have_module('auth_basic'); -} - -sub have_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 have_min_apache_version { - my $wanted = shift; - my $cfg = Apache::Test::config(); - (my $current) = $cfg->{server}->{version} =~ m:^Apache/(\d\.\d+\.\d+):; - - if ($current lt $wanted) { - push @SkipReasons, - "apache version $wanted or higher is required," . - " this is version $current"; - return 0; - } - else { - return 1; - } -} - -sub have_apache_version { - my $wanted = shift; - my $cfg = Apache::Test::config(); - (my $current) = $cfg->{server}->{version} =~ m:^Apache/(\d\.\d+\.\d+):; - - if ($current ne $wanted) { - push @SkipReasons, - "apache version $wanted or higher is required," . - " this is version $current"; - return 0; - } - else { - return 1; - } -} - -sub config_enabled { - my $key = shift; - defined $Config{$key} and $Config{$key} eq 'define'; -} - -sub have_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 have_perl { - my $thing = shift; - #XXX: $thing could be a version - my $config; - - my $have = \&{"have_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 have_threads { - my $status = 1; - - # check APR support - my $build_config = Apache::TestConfig->modperl_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 under_construction { - push @SkipReasons, "This test is under construction"; - return 0; -} - -package Apache::TestToString; - -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; -} +# this is a workaround for ExtUtils::MakeMaker::parse_version +$VERSION = do { require Apache::TestReal; $Apache::Test::VERSION; }; 1; -__END__ - - -=head1 NAME - -Apache::Test - Test.pm wrapper with helpers for testing Apache - -=head1 SYNOPSIS - - use Apache::Test; - -=head1 DESCRIPTION - -B is a wrapper around the standard C with -helpers for testing an Apache server. - -=head1 FUNCTIONS - -=over 4 - -=item plan - -This function is a wrapper around C: - - plan tests => 3; - -just like using Test.pm, plan 3 tests. - -If the first argument is an object, such as an C -object, C will be tied to it. The C global state will -also be refreshed by calling C. 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 -(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 - -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 have(): - - plan tests => 5, - have 'LWP', - { "perl >= 5.7.3 is required" => sub { $] >= 5.007003 } }; - -see have() for more info. - -=item * an C reference - -have_module() is called for each value in this array. The test is -skipped if have_module() returns false (which happens when at least -one C or Perl module from the list cannot be found). - -=item * a C reference - -the tests will be skipped if the function returns a false value. For -example: - - plan tests => 5, \&have_lwp; - -the test will be skipped if LWP is not available - -=back - -All other arguments are passed through to I as is. - -=item ok - -Same as I, see I 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, see I documentation. - -=item test_pm_refresh - -Normally called by I, this function will refresh -the global state maintained by I, allowing C 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(): - -=over have_http11 - - plan tests => 5, &have_http11; - -Require HTTP/1.1 support. - -=item have_ssl - - plan tests => 5, &have_ssl; - -Require SSL support. - -Not exported by default. - -=item have_lwp - - plan tests => 5, &have_lwp; - -Require LWP support. - -=item have_cgi - - plan tests => 5, &have_cgi; - -Requires mod_cgi or mod_cgid to be installed. - -=item have_apache - - plan tests => 5, have_apache 2; - -Requires Apache 2nd generation httpd-2.x.xx - - plan tests => 5, have_apache 1; - -Requires Apache 1st generation (apache-1.3.xx) - -See also C. - -=item have_min_apache_version - -Used to require a minimum version of Apache. - -For example: - - plan tests => 5, have_min_apache_version("2.0.40"); - -requires Apache 2.0.40 or higher. - -=item have_apache_version - -Used to require a specific version of Apache. - -For example: - - plan tests => 5, have_apache_version("2.0.40"); - -requires Apache 2.0.40. - -=item have_perl - - plan tests => 5, have_perl 'iolayers'; - plan tests => 5, have_perl 'ithreads'; - -Requires a perl extension to be present, or perl compiled with certain -capabilities. - -The first example tests whether C is available, the second -whether: - - $Config{useithread} eq 'define'; - -=item have_module - - plan tests => 5, have_module 'CGI'; - plan tests => 5, have_module qw(CGI Find::File); - plan tests => 5, have_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 have_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 have_module 'mod_cgi' - -The I<.c> extension will be appended before the lookup, turning it into -I<'mod_cgi.c'>. - -=item 3 have_module 'cgi' - -The I<.c> extension and I prefix will be added before the -lookup, turning it into I<'mod_cgi.c'>. - -=back - -=item have - - plan tests => 5, - have 'LWP', - { "perl >= 5.8.0 is required" => ($] >= 5.008) }, - { "not Win32" => sub { $^O eq 'MSWin32' }, - "foo is disabled" => \&is_foo_enabled, - }, - 'cgid'; - -have() is more generic function which can impose multiple requirements -at once. All requirements must be satisfied. - -have()'s argument is a list of things to test. The list can include -scalars, which are passed to have_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 valuees are the -condition, which are satisfaction if they return true. If the value is -a scalar it's used as is. 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 presense of the C Perl -module, C, that we run under perl E= 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. - -Also see plan(). - -=back - -=head1 Apache::TestToString Class - -The I class is used to capture I 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; - -=cut --- /dev/null 1970-01-01 10:00:00.000000000 +1000 +++ Apache-Test/lib/Apache/TestReal.pm 2003-05-14 13:45:45.000000000 +1000 @@ -0,0 +1,617 @@ +package Apache::Test; +# this is a workaround for a collision we have on the case-insensitive +# platforms which may have Apache/test.pm from mod_perl 1.0 +# installed. So Apache/Test.pm doesn't exist anymore. Load +# Apache/TestPlan instead. +$Apache::Test::VERSION = '1.03'; + +use strict; +use warnings FATAL => 'all'; + +use Test qw(ok skip); +use Exporter (); +use Config; +use Apache::TestConfig (); + +use vars qw(@ISA @EXPORT $VERSION %SubTests @SkipReasons); + +@ISA = qw(Exporter); +@EXPORT = qw(ok skip sok plan have have_lwp have_http11 + have_cgi have_access have_auth have_module have_apache + have_min_apache_version have_apache_version have_perl + have_threads under_construction); + + +%SubTests = (); +@SkipReasons = (); + +if (my $subtests = $ENV{HTTPD_TEST_SUBTESTS}) { + %SubTests = map { $_, 1 } split /\s+/, $subtests; +} + +my $Config; + +sub config { + $Config ||= Apache::TestConfig->thaw; +} + +sub vars { + config()->{vars}; +} + +sub sok (&;$) { + my $sub = shift; + my $nok = shift || 1; #allow sok to have 'ok' within + + if (%SubTests and not $SubTests{ $Test::ntest }) { + for my $n (1..$nok) { + skip "skipping this subtest", 0; + } + return; + } + + ok $sub->(); +} + +#so Perl's Test.pm can be run inside mod_perl +sub test_pm_refresh { + $Test::TESTOUT = \*STDOUT; + $Test::planned = 0; + $Test::ntest = 1; + %Test::todo = (); +} + +sub init_test_pm { + my $r = shift; + + # needed to load Apache::RequestRec::TIEHANDLE + eval {require Apache::RequestIO}; + if (defined &Apache::RequestRec::TIEHANDLE) { + untie *STDOUT; + tie *STDOUT, $r; + require Apache::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 have_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 have_ssl { + my $vars = vars(); + have_module([$vars->{ssl_module_name}, 'Net::SSL']); +} + +sub have_lwp { + require Apache::TestRequest; + if (Apache::TestRequest::has_lwp()) { + return 1; + } + else { + push @SkipReasons, "libwww-perl is not installed"; + return 0; + } +} + +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 = have_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"; + exit; #XXX: Apache->exit + } + } + @SkipReasons = (); # reset + + Test::plan(@_); +} + +sub have { + my $have_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; + $have_all = 0; + } + } + else { + $have_all = 0 unless have_module($cond); + } + } + return $have_all; + +} + +sub have_module { + my $cfg = config(); + my @modules = ref($_[0]) ? @{ $_[0] } : @_; + + my @reasons = (); + for (@modules) { + if (/^[a-z0-9_.]+$/) { + my $mod = $_; + unless ($mod =~ /\.c$/) { + $mod = 'mod_' . $mod unless $mod =~ /^mod_/; + $mod .= '.c' + } + next if $cfg->{modules}->{$mod}; + if (exists $cfg->{cmodules_disabled}->{$mod}) { + push @reasons, $cfg->{cmodules_disabled}->{$mod}; + next; + } + } + die "bogus module name $_" unless /^[\w:.]+$/; + eval "require $_"; + #print $@ if $@; + if ($@) { + push @reasons, "cannot find module '$_'"; + } + } + if (@reasons) { + push @SkipReasons, @reasons; + return 0; + } + else { + return 1; + } +} + +sub have_cgi { + have_module('cgi') || have_module('cgid'); +} + +sub have_access { + have_module('access') || have_module('authz_host'); +} + +sub have_auth { + have_module('auth') || have_module('auth_basic'); +} + +sub have_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 have_min_apache_version { + my $wanted = shift; + my $cfg = Apache::Test::config(); + (my $current) = $cfg->{server}->{version} =~ m:^Apache/(\d\.\d+\.\d+):; + + if ($current lt $wanted) { + push @SkipReasons, + "apache version $wanted or higher is required," . + " this is version $current"; + return 0; + } + else { + return 1; + } +} + +sub have_apache_version { + my $wanted = shift; + my $cfg = Apache::Test::config(); + (my $current) = $cfg->{server}->{version} =~ m:^Apache/(\d\.\d+\.\d+):; + + if ($current ne $wanted) { + push @SkipReasons, + "apache version $wanted or higher is required," . + " this is version $current"; + return 0; + } + else { + return 1; + } +} + +sub config_enabled { + my $key = shift; + defined $Config{$key} and $Config{$key} eq 'define'; +} + +sub have_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 have_perl { + my $thing = shift; + #XXX: $thing could be a version + my $config; + + my $have = \&{"have_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 have_threads { + my $status = 1; + + # check APR support + my $build_config = Apache::TestConfig->modperl_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 under_construction { + push @SkipReasons, "This test is under construction"; + return 0; +} + +package Apache::TestToString; + +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 is a wrapper around the standard C with +helpers for testing an Apache server. + +=head1 FUNCTIONS + +=over 4 + +=item plan + +This function is a wrapper around C: + + plan tests => 3; + +just like using Test.pm, plan 3 tests. + +If the first argument is an object, such as an C +object, C will be tied to it. The C global state will +also be refreshed by calling C. 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 +(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 + +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 have(): + + plan tests => 5, + have 'LWP', + { "perl >= 5.7.3 is required" => sub { $] >= 5.007003 } }; + +see have() for more info. + +=item * an C reference + +have_module() is called for each value in this array. The test is +skipped if have_module() returns false (which happens when at least +one C or Perl module from the list cannot be found). + +=item * a C reference + +the tests will be skipped if the function returns a false value. For +example: + + plan tests => 5, \&have_lwp; + +the test will be skipped if LWP is not available + +=back + +All other arguments are passed through to I as is. + +=item ok + +Same as I, see I 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, see I documentation. + +=item test_pm_refresh + +Normally called by I, this function will refresh +the global state maintained by I, allowing C 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(): + +=over have_http11 + + plan tests => 5, &have_http11; + +Require HTTP/1.1 support. + +=item have_ssl + + plan tests => 5, &have_ssl; + +Require SSL support. + +Not exported by default. + +=item have_lwp + + plan tests => 5, &have_lwp; + +Require LWP support. + +=item have_cgi + + plan tests => 5, &have_cgi; + +Requires mod_cgi or mod_cgid to be installed. + +=item have_apache + + plan tests => 5, have_apache 2; + +Requires Apache 2nd generation httpd-2.x.xx + + plan tests => 5, have_apache 1; + +Requires Apache 1st generation (apache-1.3.xx) + +See also C. + +=item have_min_apache_version + +Used to require a minimum version of Apache. + +For example: + + plan tests => 5, have_min_apache_version("2.0.40"); + +requires Apache 2.0.40 or higher. + +=item have_apache_version + +Used to require a specific version of Apache. + +For example: + + plan tests => 5, have_apache_version("2.0.40"); + +requires Apache 2.0.40. + +=item have_perl + + plan tests => 5, have_perl 'iolayers'; + plan tests => 5, have_perl 'ithreads'; + +Requires a perl extension to be present, or perl compiled with certain +capabilities. + +The first example tests whether C is available, the second +whether: + + $Config{useithread} eq 'define'; + +=item have_module + + plan tests => 5, have_module 'CGI'; + plan tests => 5, have_module qw(CGI Find::File); + plan tests => 5, have_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 have_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 have_module 'mod_cgi' + +The I<.c> extension will be appended before the lookup, turning it into +I<'mod_cgi.c'>. + +=item 3 have_module 'cgi' + +The I<.c> extension and I prefix will be added before the +lookup, turning it into I<'mod_cgi.c'>. + +=back + +=item have + + plan tests => 5, + have 'LWP', + { "perl >= 5.8.0 is required" => ($] >= 5.008) }, + { "not Win32" => sub { $^O eq 'MSWin32' }, + "foo is disabled" => \&is_foo_enabled, + }, + 'cgid'; + +have() is more generic function which can impose multiple requirements +at once. All requirements must be satisfied. + +have()'s argument is a list of things to test. The list can include +scalars, which are passed to have_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 valuees are the +condition, which are satisfaction if they return true. If the value is +a scalar it's used as is. 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 presense of the C Perl +module, C, that we run under perl E= 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. + +Also see plan(). + +=back + +=head1 Apache::TestToString Class + +The I class is used to capture I 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; + +=cut --- /dev/null 1970-01-01 10:00:00.000000000 +1000 +++ Apache-Test/lib/Apache/test_mp1.pm 2003-05-14 13:55:30.000000000 +1000 @@ -0,0 +1,708 @@ +package Apache::test; + +use strict; +use vars qw(@EXPORT $USE_THREAD $USE_SFIO $PERL_DIR @EXPORT_OK); +use Exporter (); +use Config; +use FileHandle (); +*import = \&Exporter::import; + +$Apache::test::VERSION = 0.01; + +@EXPORT = qw(test fetch simple_fetch have_module skip_test + $USE_THREAD $USE_SFIO $PERL_DIR WIN32 grab run_test); +@EXPORT_OK = qw(have_httpd); + +BEGIN { + $ENV{PERL_LWP_USE_HTTP_10} = 1; #default to http/1.0 + + if(not $ENV{MOD_PERL}) { + eval { require "net/config.pl"; }; #for 'make test' + $PERL_DIR = $net::perldir; + } + if ($net::httpserver) { + # Validate that the OS knows the name of the server in $net::httpserver + # if 'localhost' is not defined, the tests wouldn't pass + (my $hostname) = ($net::httpserver =~ /(.*?):/); + warn qq{\n*** [Crucial] You must define "$hostname" (e.g. in /etc/hosts) in order for 'make test' to pass\n} + unless gethostbyname $hostname; + } +} + +$PERL_DIR = $ENV{PERL_DIR} if exists $ENV{PERL_DIR}; + +$USE_THREAD = ($Config{extensions} =~ /Thread/) || $Config{usethreads}; +$USE_SFIO = (($Config{'usesfio'} || '') eq 'true'); + +my $Is_Win32 = ($^O eq "MSWin32"); +sub WIN32 () { $Is_Win32 }; + +my $UA; + +eval { + require LWP::UserAgent; + require URI::URL; + $UA = LWP::UserAgent->new; +}; + +unless (defined &Apache::bootstrap) { + *Apache::bootstrap = sub {}; + *Apache::Constants::bootstrap = sub {}; +} + +sub write_httpd_conf { + my $pkg = shift; + my %args = (conf_file => 't/httpd.conf', @_); + my $DIR = `pwd`; chomp $DIR; + + local *CONF; + open CONF, ">$args{conf_file}" or die "Can't create $args{conf_file}: $!"; + print CONF < + use lib "$DIR/blib/lib", "$DIR/t/lib"; + + +$args{include} +EOF + + return 1; +} + +sub _ask { + # Just a function for asking the user questions + my ($prompt, $default, $mustfind, $canskip) = @_; + + my $skip = defined $canskip ? " ('$canskip' to skip)" : ''; + my $response; + do { + print "$prompt [$default]$skip: "; + chomp($response = ); + $response ||= $default; + } until (!$mustfind || ($response eq $canskip) || (-e $response || !print("$response not found\n"))); + + return $response; +} + +sub get_test_params { + my $pkg = shift; + + print("\nFor testing purposes, please give the full path to an httpd\n", + "with mod_perl enabled. The path defaults to \$ENV{APACHE}, if present."); + + my %conf; + + my $httpd = $ENV{'APACHE'} || which('apache') || which('httpd') || '/usr/lib/httpd/httpd'; + + $httpd = _ask("\n", $httpd, 1, '!'); + if ($httpd eq '!') { + print "Skipping.\n"; + return; + } + system "$Config{lns} $httpd t/httpd"; + + # Default: search for dynamic dependencies if mod_so is present, don't bother otherwise. + my $default = (`t/httpd -l` =~ /mod_so\.c/ ? 'y' : 'n'); + if (lc _ask("Search existing config file for dynamic module dependencies?", $default) eq 'y') { + my %compiled; + for (`t/httpd -V`) { + if (/([\w]+)="(.*)"/) { + $compiled{$1} = $2; + } + } + $compiled{SERVER_CONFIG_FILE} =~ s,^,$compiled{HTTPD_ROOT}/, + unless $compiled{SERVER_CONFIG_FILE} =~ m,^/,; + + my $file = _ask(" Config file", $compiled{SERVER_CONFIG_FILE}, 1); + $conf{modules} = $pkg->_read_existing_conf($file); + } + + # Get default user (apache doesn't like to run as root, special-case it) + my $defuser = ($< && getpwuid $<) || 'nobody'; + $conf{user} = _ask("User to run tests under", $defuser); + + my $defgroup = ($defuser eq 'nobody' ? 'nobody' : getgrgid((getpwnam $conf{user})[3])); + $conf{group} = _ask("Group to run tests under", $defgroup); + + $conf{port} = _ask("Port to run tests under", 8228); + + return %conf; +} + +sub _read_existing_conf { + # Returns some "(Add|Load)Module" config lines, generated from the + # existing config file and a few must-have modules. + my ($self, $server_conf) = @_; + + open SERVER_CONF, $server_conf or die "Couldn't open $server_conf: $!"; + my @lines = grep {!m/^\s*\#/} ; + close SERVER_CONF; + + my @modules = grep /^\s*(Add|Load)Module/, @lines; + my ($server_root) = (map /^\s*ServerRoot\s*(\S+)/, @lines); + $server_root =~ s/^"//; + $server_root =~ s/"$//; + + # Rewrite all modules to load from an absolute path. + foreach (@modules) { + s!(\s)([^/\s]\S+/)!$1$server_root/$2!; + } + + my $static_mods = $self->static_modules('t/httpd'); + + my @load; + # Have to make sure that dir, autoindex and perl are loaded. + foreach my $module (qw(dir autoindex perl)) { + unless ($static_mods->{"mod_$module"} or grep /$module/i, @modules) { + warn "Will attempt to load mod_$module dynamically.\n"; + push @load, $module; + } + } + + # Directories where apache DSOs live. + my @module_dirs = map {m,(/\S*/),} @modules; + + # Finally compute the directives to load modules that need to be loaded. + MODULE: + foreach my $module (@load) { + foreach my $module_dir (@module_dirs) { + foreach my $filename ("mod_$module.so", "lib$module.so", "ApacheModule\u$module.dll") { + if (-e "$module_dir/$filename") { + push @modules, "LoadModule ${module}_module $module_dir/$filename\n"; next MODULE; + } + } + } + warn "Warning: couldn't find anything to load for 'mod_$module'.\n"; + } + + print "Adding the following dynamic config lines: \n@modules"; + return join '', @modules; +} + +sub static_modules { + # Returns a hashref whose keys are each of the modules compiled + # statically into the given httpd binary. + my ($self, $httpd) = @_; + + my @l = `$httpd -l`; + return {map {lc($_) => 1} map /(\S+)\.c/, @l}; +} + +# Find an executable in the PATH. +sub which { + foreach (map { "$_/$_[0]" } split /:/, $ENV{PATH}) { + next unless m,^/,; + return $_ if -x; + } +} + +sub test { + shift() if UNIVERSAL::isa($_[0], __PACKAGE__); + my $s = $_[1] ? "ok $_[0]\n" : "not ok $_[0]\n"; + if($ENV{MOD_PERL}) { + Apache->request->print($s); + } + else { + print $s; + } +} + +sub fetch { + # Old code calls fetch() as a function, new code as a method + my $want_response; + $want_response = shift() if UNIVERSAL::isa($_[0], __PACKAGE__); + my ($ua, $url) = (@_ == 1 ? ($UA, shift()) : @_); + my $request = ref $url ? $url : {uri=>$url}; + + # Set some defaults + $ENV{PORT} ||= 8529; # For mod_perl's own tests + $request->{method} ||= 'GET'; + $request->{content} = '' unless exists $request->{content}; + $request->{uri} = "http://localhost:$ENV{PORT}$request->{uri}" + unless $request->{uri} =~ /^http/; + $request->{headers}{Content_Type} = 'application/x-www-form-urlencoded' + if (!$request->{headers} and $request->{method} eq 'POST'); # Is this necessary? + + # Create & send the request + $request->{headers} = new HTTP::Headers(%{$request->{headers}||{}}); + my $req = new HTTP::Request(@{$request}{'method','uri','headers','content'}); + my $response = $ua->request($req); + + return $want_response ? $response : $response->content; +} + +sub simple_fetch { + my $ua = LWP::UserAgent->new; + my $url = URI::URL->new("http://$net::httpserver"); + my($path,$q) = split /\?/, shift; + $url->path($path); + $url->query($q) if $q; + my $request = new HTTP::Request('GET', $url); + my $response = $ua->request($request, undef, undef); + $response->is_success; +} + +#even if eval $mod fails, the .pm ends up in %INC +#so the next eval $mod succeeds, when it shouldnot + +my %really_have = ( + 'Apache::Table' => sub { + if ($ENV{MOD_PERL}) { + return Apache::Table->can('TIEHASH'); + } + else { + return $net::callback_hooks{PERL_TABLE_API}; + } + }, +); + +for (qw(Apache::Cookie Apache::Request)) { + $really_have{$_} = $really_have{'Apache::Table'}; +} + +sub have_module { + my $mod = shift; + my $v = shift; + eval {# surpress "can't boostrap" warnings + local $SIG{__WARN__} = sub {}; + require Apache; + require Apache::Constants; + }; + + eval "require $mod"; + if($v and not $@) { + eval { + local $SIG{__WARN__} = sub {}; + $mod->UNIVERSAL::VERSION($v); + }; + if($@) { + warn $@; + return 0; + } + } + if($@ && ($@ =~ /Can.t locate/)) { + return 0; + } + elsif($@ && ($@ =~ /Can.t find loadable object for module/)) { + return 0; + } + elsif($@) { + warn "$@\n"; + } + + if (my $cv = $really_have{$mod}) { + return 0 unless $cv->(); + } + + print "module $mod is installed\n" unless $ENV{MOD_PERL}; + + return 1; +} + +sub skip_test { + print "1..0\n"; + exit; +} + +sub have_httpd { + return -e 't/httpd'; +} + +sub run { + require Test::Harness; + my $self = shift; + my $args = shift || {}; + my @tests = (); + + # First we check if we already are within the "t" directory + if (-d "t") { + # try to move into test directory + chdir "t" or die "Can't chdir: $!"; + + # fix all relative library locations + foreach (@INC) { + $_ = "../$_" unless m,^(/)|([a-f]:),i; + } + } + + # Pick up the library files from the ../blib directory + unshift(@INC, "../blib/lib", "../blib/arch"); + #print "@INC\n"; + + $Test::Harness::verbose = shift(@ARGV) + if $ARGV[0] =~ /^\d+$/ || $ARGV[0] eq "-v"; + + $Test::Harness::verbose ||= $args->{verbose}; + + if (@ARGV) { + for (@ARGV) { + if (-d $_) { + push(@tests, <$_/*.t>); + } + else { + $_ .= ".t" unless /\.t$/; + push(@tests, $_); + } + } + } + else { + push @tests, <*.t>, map { <$_/*.t> } @{ $args->{tdirs} || [] }; + } + + Test::Harness::runtests(@tests); +} + +sub MM_test { + # Writes the test section for the Makefile + shift(); # Don't need package name + my %conf = @_; + + my $section = < 0) { + die "usage: grab host:port path"; + } + + my($host, $port) = split ":", shift @args; + $port ||= 80; + my $url = shift @args || "/"; + + my $remote = IO::Socket::INET->new(Proto => "tcp", + PeerAddr => $host, + PeerPort => $port, + ); + unless ($remote) { + die "cannot connect to http daemon on $host"; + } + $remote->autoflush(1); + print $remote "GET $url HTTP/1.0\n\n"; + my $response_line = 0; + my $header_terminator = 0; + my @msg = (); + + while ( <$remote> ) { + #e.g. HTTP/1.1 200 OK + if(m:^(HTTP/\d+\.\d+)[ \t]+(\d+)[ \t]*([^\012]*):i) { + push @msg, $_; + $response_line = 1; + } + elsif(/^([a-zA-Z0-9_\-]+)\s*:\s*(.*)/) { + push @msg, $_; + } + elsif(/^\015?\012$/) { + $header_terminator = 1; + push @msg, $_; + } + + print; + } + close $remote; + + print "~" x 40, "\n", "Diagnostics:\n"; + if ($response_line and $header_terminator) { + print " HTTP response is valid:\n"; + } + else { + print " GET -> http://$host:$port$url\n"; + print " >>> No response line\n" unless $response_line; + print " >>> No header terminator\n" unless $header_terminator; + print " *** HTTP response is malformed\n"; + } + print "-" x 40, "\n", @msg, "-" x 40, "\n"; +} + +sub run_test { + my($test, $verbose) = @_; + my $cmd = "$^X -w $test|"; + my $fh = FileHandle->new; + $fh->open($cmd) or print "can't run $test. $!\n"; + my($ok,$next,$max,$files,$totok,$totmax); + $ok = $next = $max = 0; + my @failed = (); + while (<$fh>) { + if( $verbose ){ + print ">>> $_"; + } + if (/^1\.\.([0-9]+)/) { + $max = $1; + $totmax += $max; + $files++; + $next = 1; + } + elsif ($max && /^(not\s+)?ok\b/) { + my $this = $next; + if (/^not ok\s*(\d*)/){ + $this = $1 if $1 > 0; + push @failed, $this; + } + elsif (/^ok\s*(\d*)/) { + $this = $1 if $1 > 0; + $ok++; + $totok++; + } + if ($this > $next) { + # warn "Test output counter mismatch [test $this]\n"; + # no need to warn probably + push @failed, $next..$this-1; + } + elsif ($this < $next) { + #we have seen more "ok" lines than the number suggests + warn "Confused test output: test $this answered after test ", $next-1, "\n"; + $next = $this; + } + $next = $this + 1; + } + } + $fh->close; # must close to reap child resource values + return($max, \@failed); +} + +1; + +__END__ + +=head1 NAME + +Apache::test - Facilitates testing of Apache::* modules + +=head1 SYNOPSIS + + # In Makefile.PL + use Apache::test; + my %params = Apache::test->get_test_params(); + Apache::test->write_httpd_conf(%params, include => $more_directives); + *MY::test = sub { Apache::test->MM_test(%params) }; + + # In t/*.t script (or test.pl) + use Apache::test qw(skip_test have_httpd); + skip_test unless have_httpd; + (Some more methods of Doug's that I haven't reviewed or documented yet) + +=head1 DESCRIPTION + +This module helps authors of Apache::* modules write test suites that +can query an actual running Apache server with mod_perl and their +modules loaded into it. Its functionality is generally separated into +methods that go in a Makefile.PL to configure, start, and stop the +server, and methods that go in one of the test scripts to make HTTP +queries and manage the results. + +=head1 METHODS + +=head2 get_test_params() + +This will ask the user a few questions about where the httpd binary +is, and what user/group/port should be used when running the server. +It will return a hash of the information it discovers. This hash is +suitable for passing to the C method. + +=head2 write_httpd_conf(%params) + +This will write a basic C file suitable for starting a +HTTP server during the 'make test' stage. A hash of key/value pairs +that affect the written file can be passed as arguments. The +following keys are recognized: + +=over 4 + +=item * conf_file + +The path to the file that will be created. Default is 't/httpd.conf'. + +=item * port + +The port that the Apache server will listen on. + +=item * user + +The user that the Apache server will run as. + +=item * group + +The group that the Apache server will run as. + +=item * include + +Any additional text you want added at the end of the config file. +Typically you'll have some C and C +directives to pass control to the module you're testing. The C +directories will be added to the C<@INC> path when searching for +modules, so that's nice. + +=back + +=head2 MM_test(%params) + +This method helps write a Makefile that supports running a web server +during the 'make test' stage. When you execute 'make test', 'make' +will run 'make start_httpd', 'make run_tests', and 'make kill_httpd' +in sequence. You can also run these commands independently if you +want. + +Pass the hash of parameters returned by C as an +argument to C. + +To patch into the ExtUtils::MakeMaker wizardry (voodoo?), typically +you'll do the following in your Makefile.PL: + + *MY::test = sub { Apache::test->MM_test(%params) }; + +=head2 fetch + + Apache::test->fetch($request); + Apache::test->fetch($user_agent, $request); + +Call this method in a test script in order to fetch a page from the +running web server. If you pass two arguments, the first should be an +LWP::UserAgent object, and the second should specify the request to +make of the server. If you only pass one argument, it specifies the +request to make. + +The request can be specified either by a simple string indicating the +URI to fetch, or by a hash reference, which gives you more control +over the request. The following keys are recognized in the hash: + +=over 4 + +=item * uri + +The URI to fetch from the server. If the URI does not begin with +"http", we prepend "http://localhost:$PORT" so that we make requests +of the test server. + +=item * method + +The request method to use. Default is 'GET'. + +=item * content + +The request content body. Typically used to simulate HTML fill-out +form submission for POST requests. Default is null. + +=item * headers + +A hash of headers you want sent with the request. You might use this +to send cookies or provide some application-specific header. + +=back + +If you don't provide a 'headers' parameter and you set the 'method' +to 'POST', then we assume that you're trying to simulate HTML form +submission and we add a 'Content_Type' header with a value of +'application/x-www-form-urlencoded'. + +In a scalar context, fetch() returns the content of the web server's +response. In a list context, fetch() returns the content and the +HTTP::Response object itself. This can be handy if you need to check +the response headers, or the HTTP return code, or whatever. + +=head2 static_modules + + Example: $mods = Apache::test->static_modules('/path/to/httpd'); + +This method returns a hashref whose keys are all the modules +statically compiled into the given httpd binary. The corresponding +values are all 1. + +=head1 EXAMPLES + +No good examples yet. Example submissions are welcome. In the meantime, see +L , which +I'm retrofitting to use Apache::test. + +=head1 TO DO + +The MM_test method doesn't try to be very smart, it just writes the +text that seems to work in my configuration. I am morally against +using the 'make' command for installing Perl modules (though of course +I do it anyway), so I haven't looked into this very much. Send bug +reports or better (patches). + +I've got lots of code in my Apache::AuthCookie module (etc.) that +assists in actually making the queries of the running server. I plan +to add that to this module, but first I need to compare what's already +here that does the same stuff. + +=head1 KUDOS + +To Doug MacEachern for writing the first version of this module. + +To caelum@debian.org (Rafael Kitover) for contributing the code to +parse existing httpd.conf files for --enable-shared=max and DSOs. + +=head1 CAVEATS + +Except for making sure that the mod_perl distribution itself can run +'make test' okay, I haven't tried very hard to keep compatibility with +older versions of this module. In particular MM_test() has changed +and probably isn't usable in the old ways, since some of its +assumptions are gone. But none of this was ever documented, and +MM_test() doesn't seem to actually be used anywhere in the mod_perl +disribution, so I don't feel so bad about it. + +=head1 AUTHOR + +Doug MacEachern (original version) + +Ken Williams (latest changes and this documentation) + +=cut