Apache::Test - Test.pm wrapper with helpers for testing Apache

    use Apache::Test;

  my $basic_cfg = Apache::Test::basic_config();
  $basic_cfg->write_perlscript($file, $content);

  my $cfg = Apache::Test::config();
  my $server_rev = $cfg->{server}->{rev};
  ...

  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));

  $vars = Apache::Test::config()->{vars};

    use Apache::Test qw(:withtestmore);
    use Test::More;

    plan tests => 1;           # Test::More::plan()

    ok ('yes', 'testing ok');  # Test::More::ok()

    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()
    }

    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;

# 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.36';

my @need = qw(need_lwp need_http11 need_cgi need_access need_auth
              need_module need_apache need_min_apache_version
              need_apache_version need_perl need_min_perl_version
              need_min_module_version need_threads 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}, 'Net::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_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 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__