PC Professionell 2004 December/PCpro_2004_12.ISO/files/webserver/tsw/TSW_3.4.0.exe/Apache2/perl/TestConfig.pm

Perl POD Document | 2003-11-12 | 46.7 KB | 1,779 lines

package Apache::TestConfig;

use strict;
use warnings FATAL => 'all';

use constant WIN32   => $^O eq 'MSWin32';
use constant CYGWIN  => $^O eq 'cygwin';
use constant NETWARE => $^O eq 'NetWare';
use constant WINFU   => WIN32 || CYGWIN || 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_perl } && $mod_perl::VERSION >= 1.99;

use constant IS_MOD_PERL_2_BUILD => IS_MOD_PERL_2 &&
    require Apache::Build && Apache::Build::IS_MOD_PERL_BUILD();

use Symbol ();
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 Apache::TestConfigPerl ();
use Apache::TestConfigParse ();
use Apache::TestTrace;
use Apache::TestServer ();
use Socket ();

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_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 Apache::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)',
   maxclients      => 'maximum number of concurrent clients (default is 1)',
   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)',
   libmodperl      => 'path to mod_perl\'s .so (full or relative to LIBEXECDIR)',
   (map { $_ . '_module_name', "$_ module name"} qw(cgi ssl thread access auth)),
);

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{
APXS APACHE APACHE_GROUP APACHE_USER APACHE_PORT
};

sub passenv {
    \%passenv;
}

sub passenv_makestr {
    my @vars;

    for (keys %passenv) {
        push @vars, "$_=\$($_)";
    }

    "@vars";
}

sub server { shift->{server} }

sub modperl_2_inc_fixup {
    (IS_MOD_PERL_2 && !IS_MOD_PERL_2_BUILD) ? "use Apache2;\n" : '';
}

sub modperl_build_config {
    eval {
        require Apache::Build;
    } or return undef;
    return Apache::Build->build_config;
}

sub new_test_server {
    my($self, $args) = @_;
    Apache::TestServer->new($args || $self)
}

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 $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} ||= fastcwd;
    $vars->{top_dir} = pop_dir($vars->{top_dir}, 't');

    $self->add_inc;

    #help to find libmodperl.so
    my $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';
    $vars->{t_logs}       ||= catfile $vars->{serverroot}, 'logs';
    $vars->{t_conf_file}  ||= catfile $vars->{t_conf},   'httpd.conf';

    if (WINFU) {
        for (keys %$vars) {
            $vars->{$_} =~ s|\\|\/|g;
        }
    }

    $vars->{scheme}       ||= 'http';
    $vars->{servername}   ||= $self->default_servername;
    $vars->{port}           = $self->select_port;
    $vars->{remote_addr}  ||= $self->our_remote_addr;

    $vars->{user}         ||= $self->default_user;
    $vars->{group}        ||= $self->default_group;
    $vars->{serveradmin}  ||= $self->default_serveradmin;
    $vars->{maxclients}   ||= 1;
    $vars->{proxy}        ||= 'off';
    $vars->{proxyssl_url} ||= '';

    $self->configure_apxs;
    $self->configure_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->{hostport} = $self->hostport;

    $self->{server} = $self->new_test_server;

    $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};

    $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) {
        $vars->{maxclients}++;
        $vars->{proxy} = $self->{vhosts}->{'mod_proxy'}->{hostport};
        return $vars->{proxy};
    }

    return undef;
}

sub add_config {
    my $self = shift;
    my $where = 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 {
            $args .= "    $data";
        }
        $args .= "</$directive>\n";
    }
    elsif (ref($directive) eq 'ARRAY') {
        $args = join "\n", @$directive;
    }
    else {
        $args = "$directive " .
          (ref($arg) && (ref($arg) eq 'ARRAY') ? "@$arg" : $arg || "");
    }

    push @{ $self->{$where} }, $args;
}

sub postamble {
    shift->add_config(postamble => @_);
}

sub preamble {
    shift->add_config(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;
        print $out "$_\n";
    }
}

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_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_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
        }
    }

    $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 = modperl_build_config()) {
        return $build_config->{MP_APXS};
    }

    $ENV{APXS} || which('apxs');
}

sub default_httpd {
    my $vars = shift->{vars};

    if (my $build_config = modperl_build_config()) {
        if (my $p = $build_config->{MP_AP_PREFIX}) {
            for my $bindir (qw(bin sbin)) {
                my $httpd = "$p/$bindir/$vars->{target}";
                return $httpd if -e $httpd;
            }
        }
    }

    $ENV{APACHE} || which($vars->{target});
}

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_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.
#
sub select_port {
    my $self = shift;

    my $port ||= $ENV{APACHE_PORT} || $self->{vars}{port} || DEFAULT_PORT;

    # memoize
    $ENV{APACHE_PORT} = $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
    $ENV{APACHE_PORT} = $port;

    return $port;
}

my $remote_addr;

sub our_remote_addr {
    my $self = shift;
    my $name = $self->default_servername;
    $remote_addr ||= Socket::inet_ntoa((gethostbyname($name))[-1]);
}

sub default_loopback {
    '127.0.0.1';
}

sub port {
    my($self, $module) = @_;

    unless ($module) {
        my $vars = $self->{vars};
        return $self->select_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};
    my $resolve = \$self->{resolved}->{$name};

    unless ($$resolve) {
        if (gethostbyname $name) {
            $$resolve = $name;
        }
        else {
            $$resolve = $self->default_loopback;
            warn "lookup $name failed, using $$resolve for client tests\n";
        }
    }

    join ':', $$resolve || 'localhost', $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 { "/* @_ */" },
    default => sub { join '', grep {s/^/\# /gm} @_ },
);

my %file_ext = (
    map({$_ => 'html'} qw(htm html)),
    map({$_ => 'c'   } qw(c h)),
);

# 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 $warning = "WARNING: this file is generated";
    $warning .= " (from $from_filename)" if defined $from_filename;
    $warning .= ", do not edit\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 $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);

    # shebang
    print $fh "#!$Config{perlpath}\n";

    $self->genfile_warning($file, undef, $fh);

    print $fh $content if $content;

    close $fh;
    chmod 0755, $file;
}

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(PATH IFS CDPATH ENV BASH_ENV) };

    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 (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 $_;
        }
    }
}

sub replace {
    my $self = shift;
    my $file = $Apache::TestConfig::File
        ? "in file $Apache::TestConfig::File" : '';

    s[@(\w+)@]
     [ my $key = lc $1;
      exists $self->{vars}->{$key}
      ? $self->{vars}->{$key}
      : 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 = (
    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 => $port]);

        if ($self->{vhosts}->{$module}->{namebased}) {
            push @out_config => [NameVirtualHost => "*:$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 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
    my $mod_mime = $self->find_apache_module('mod_mime.so');
    if ($mod_mime && -e $mod_mime) {
        $self->preamble(IfModule => '!mod_mime.c',
                        qq{LoadModule mime_module "$mod_mime"\n});
    }

    unless ($self->{inherit_config}->{TypesConfig}) {
        my $types = catfile $self->{vars}->{t_conf}, 'mime.types';
        unless (-e $types) {
            my $fh = $self->genfile($types);
            print $fh $self->types_config_template;
            close $fh;
        }
        $self->postamble(TypesConfig => qq("$types"));
    }
}

sub httpd_conf_template {
    my($self, $try) = @_;

    my $in = Symbol::gensym();
    if (open $in, $try) {
        return $in;
    }
    else {
        return \*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}) {
            $vars->{maxclients}++;
        }
    }
}

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) {
        local $Apache::TestConfig::File = $file;

        (my $generated = $file) =~ s/\.in$//;
        push @extra_conf, $generated;

        debug "Including $generated config file";

        next if -e $generated
            && -M $generated < -M $file;

        my $in = Symbol::gensym();
        open($in, $file) or next;

        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;

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

    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->preamble_run($out);

    for my $name (qw(user group)) { #win32/cygwin do not support
        if ($vars->{$name}) {
            print $out "\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
    my $mod_alias = $self->find_apache_module('mod_alias.so');
    if ($mod_alias && -e $mod_alias) {
        print $out <<EOF;
<IfModule !mod_alias.c>
    LoadModule alias_module "$mod_alias"
</IfModule>
EOF
    }

    print $out "<IfModule mod_alias.c>\n";
    for (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 = shift;
    my @reasons = ();
    my $vars = $self->{vars};

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

    # if .in files are newer than their derived versions
    if (my $extra_conf = $self->generate_extra_conf) {
        for my $file (@$extra_conf) {
            push @reasons, "$file.in is newer than $file"
                if -e $file && -M "$file.in" < -M $file;
        }
    }

    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 @results = ();

    for my $base (map { catfile($_, $program) } File::Spec->path()) {
        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;

        if (WIN32) {
            for my $ext (@path_ext) {
                return "$base.$ext" if -x "$base.$ext";
            }
        }
    }
}

sub apxs {
    my($self, $q, $ok_fail) = @_;
    return unless $self->{APXS};
    my $devnull = devnull();
    my $val = qx($self->{APXS} -q $q 2>$devnull);
    chomp $val if defined $val; # apxs post-2.0.40 adds a new line
    unless ($val) {
        if ($ok_fail) {
            return "";
        }
        else {
            warn "APXS ($self->{APXS}) query for $q failed\n";
        }
    }
    $val;
}

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;

    if ($ENV{APACHE_TEST_LIVE_DEV}) {
        my $lib_dir = catdir $top_dir, "lib";
        push @dirs, $lib_dir if -d $lib_dir;
    }

    lib::->import(@dirs);
    #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};

    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});
    if (my $httpd = $test_config->{vars}->{httpd}) {
        $command = "$httpd -V";
        $cfg .= "\n*** $command\n";
        $cfg .= qx{$command};
    } else {
        $cfg .= "\n\n*** The httpd binary was not found\n";
    }

    # perl opts
    my $perl = $^X;
    $command = "$perl -V";
    $cfg .= "\n\n*** $command\n";
    $cfg .= qx{$command};

    return $cfg;
}

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 AUTHOR

=head1 SEE ALSO

perl(1), Apache::Test(3)

=cut


__DATA__
Listen     @Port@

ServerRoot   "@ServerRoot@"
DocumentRoot "@DocumentRoot@"

PidFile     @t_logs@/httpd.pid
ErrorLog    @t_logs@/error_log
LogLevel    debug

<IfModule mod_log_config.c>
    TransferLog @t_logs@/access_log
</IfModule>

ServerAdmin @ServerAdmin@

#needed for http/1.1 testing
KeepAlive       On

HostnameLookups Off

<Directory />
    Options FollowSymLinks
    AllowOverride None
</Directory>

<IfModule @THREAD_MODULE@>
    StartServers         1
    MaxClients           @MaxClients@
    MinSpareThreads      @MaxClients@
    MaxSpareThreads      @MaxClients@
    ThreadsPerChild      @MaxClients@
    MaxRequestsPerChild  0
</IfModule>

<IfModule perchild.c>
    NumServers           1
    StartThreads         @MaxClients@
    MinSpareThreads      @MaxClients@
    MaxSpareThreads      @MaxClients@
    MaxThreadsPerChild   @MaxClients@
    MaxRequestsPerChild  0
</IfModule>

<IfModule prefork.c>
    StartServers         1
    MaxClients           @MaxClients@
    MaxRequestsPerChild  0
</IfModule>

<IfDefine APACHE1>
    StartServers         1
    MaxClients           @MaxClients@
    MaxRequestsPerChild  0
</IfDefine>

<IfModule mpm_winnt.c>
    ThreadsPerChild      20
    MaxRequestsPerChild  0
</IfModule>

<Location /server-info>
    SetHandler server-info
</Location>

<Location /server-status>
    SetHandler server-status
</Location>