Apache-Test

 view release on metacpan or  search on metacpan

lib/Apache/TestConfig.pm  view on Meta::CPAN

    my @vars;

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

    "@vars";
}

sub server { shift->{server} }

sub modperl_build_config {

    my $self = shift;

    my $server = ref $self ? $self->server : new_test_server();

    # we can't do this if we're using httpd 1.3.X
    # even if mod_perl2 is installed on the box
    # similarly, we shouldn't be loading mp2 if we're not
    # absolutely certain we're in a 2.X environment yet
    # (such as mod_perl's own build or runtime environment)
    if (($server->{rev} && $server->{rev} == 2) ||
        IS_MOD_PERL_2_BUILD || $ENV{MOD_PERL_API_VERSION}) {
        eval {
            require Apache2::Build;
        } or return;

        return Apache2::Build->build_config;
    }

    return;
}

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

# setup httpd-independent components
# for httpd-specific call $self->httpd_config()
sub new {
    my $class = shift;

    my $args;

    $args = shift if $_[0] and ref $_[0];

    $args = $args ? {%$args} : {@_}; #copy

    #see Apache::TestMM::{filter_args,generate_script}
    #we do this so 'perl Makefile.PL' can be passed options such as apxs
    #without forcing regeneration of configuration and recompilation of c-modules
    #as 't/TEST apxs /path/to/apache/bin/apxs' would do
    while (my($key, $val) = each %Apache::TestConfig::Argv) {
        $args->{$key} = $val;
    }

    my $top_dir = fastcwd;
    $top_dir = pop_dir($top_dir, 't');
    # untaint as we are going to use it a lot later on in -T sensitive
    # operations (.e.g @INC)
    $top_dir = $1 if $top_dir =~ /(.*)/;

    # make sure that t/conf/apache_test_config.pm is found
    # (unfortunately sometimes we get thrown into / by Apache so we
    # can't just rely on $top_dir
    lib->import($top_dir);

    my $thaw = {};
    #thaw current config
    for (qw(conf t/conf)) {
        last if eval {
            require "$_/apache_test_config.pm";
            $thaw = 'apache_test_config'->new;
            delete $thaw->{save};
            #incase class that generated the config was
            #something else, which we can't be sure how to load
            bless $thaw, 'Apache::TestConfig';
        };
    }

    if ($args->{thaw} and ref($thaw) ne 'HASH') {
        #dont generate any new config
        $thaw->{vars}->{$_} = $args->{$_} for keys %$args;
        $thaw->{server} = $thaw->new_test_server;
        $thaw->add_inc;
        return $thaw;
    }

    #regenerating config, so forget old
    if ($args->{save}) {
        for (qw(vhosts inherit_config modules inc cmodules)) {
            delete $thaw->{$_} if exists $thaw->{$_};
        }
    }

    my $self = bless {
        clean => {},
        vhosts => {},
        inherit_config => {},
        modules => {},
        inc => [],
        %$thaw,
        mpm => "",
        httpd_defines => {},
        vars => $args,
        postamble => [],
        preamble => [],
        postamble_hooks => [],
        preamble_hooks => [],
    }, ref($class) || $class;

    my $vars = $self->{vars}; #things that can be overridden

    for (qw(save verbose)) {
        next unless exists $args->{$_};
        $self->{$_} = delete $args->{$_};
    }

    $vars->{top_dir} ||= $top_dir;

lib/Apache/TestConfig.pm  view on Meta::CPAN

    my $fh = $self->genfile($file, undef, 1);

    my $shebang = make_shebang();
    print $fh $shebang;

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

    print $fh $content if $content;

    close $fh;
    chmod 0755, $file;
}

sub make_shebang {
    # if perlpath is longer than 62 chars, some shells on certain
    # platforms won't be able to run the shebang line, so when seeing
    # a long perlpath use the eval workaround.
    # see: http://en.wikipedia.org/wiki/Shebang
    # http://homepages.cwi.nl/~aeb/std/shebang/
    my $shebang = length $Config{perlpath} < 62
        ? "#!$Config{perlpath}\n"
        : <<EOI;
$Config{'startperl'}
    eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
        if \$running_under_some_shell;
EOI

    return $shebang;
}

sub cpfile {
    my($self, $from, $to) = @_;
    File::Copy::copy($from, $to);
    $self->clean_add_file($to);
}

sub symlink {
    my($self, $from, $to) = @_;
    CORE::symlink($from, $to);
    $self->clean_add_file($to);
}

sub gendir {
    my($self, $dir) = @_;
    $self->makepath($dir);
}

# returns a list of dirs successfully created
sub makepath {
    my($self, $path) = @_;

    return if !defined($path) || -e $path;

    $self->clean_add_path($path);

    return File::Path::mkpath($path, 0, 0755);
}

sub open_cmd {
    my($self, $cmd) = @_;
    # untaint some %ENV fields
    local @ENV{ qw(IFS CDPATH ENV BASH_ENV) };
    local $ENV{PATH} = untaint_path($ENV{PATH});

    # launder for -T
    $cmd = $1 if $cmd =~ /(.*)/;

    my $handle = Symbol::gensym();
    open $handle, "$cmd|" or die "$cmd failed: $!";

    return $handle;
}

sub clean {
    my $self = shift;
    $self->{clean_level} = shift || 2; #2 == really clean, 1 == reconfigure

    $self->new_test_server->clean;
    $self->cmodules_clean;
    $self->sslca_clean;

    for (sort keys %{ $self->{clean}->{files} }) {
        if (-e $_) {
            debug "unlink $_";
            unlink $_;
        }
        else {
            debug "unlink $_: $!";
        }
    }

    # if /foo comes before /foo/bar, /foo will never be removed
    # hence ensure that sub-dirs are always treated before a parent dir
    for (reverse sort keys %{ $self->{clean}->{dirs} }) {
        if (-d $_) {
            my $dh = Symbol::gensym();
            opendir($dh, $_);
            my $notempty = grep { ! /^\.{1,2}$/ } readdir $dh;
            closedir $dh;
            next if $notempty;
            debug "rmdir $_";
            rmdir $_;
        }
    }
}

my %special_tokens = (
    nextavailableport => sub { shift->server->select_next_port }
);

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

    s[@(\w+)@]
     [ my $key = lc $1;
       if (my $callback = $special_tokens{$key}) {
           $self->$callback;
       }
       elsif (exists $self->{vars}->{$key}) {
           $self->{vars}->{$key};
       }

lib/Apache/TestConfig.pm  view on Meta::CPAN

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

    # No need to search PATH components
    # if $program already contains a path
    return $program if !OSX and !WINFU and
        $program =~ /\// and -f $program and -x $program;

    my @dirs = File::Spec->path();

    require Config;
    my $perl_bin = $Config::Config{bin} || '';
    push @dirs, $perl_bin if $perl_bin and -d $perl_bin;

    for my $base (map { catfile $_, $program } @dirs) {
        if ($ENV{HOME} and not WIN32) {
            # only works on Unix, but that's normal:
            # on Win32 the shell doesn't have special treatment of '~'
            $base =~ s/~/$ENV{HOME}/o;
        }

        return $base if -x $base && -f _;

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

sub apxs {
    my($self, $q, $ok_fail) = @_;
    return unless $self->{APXS};
    my $val;
    unless (exists $self->{_apxs}{$q}) {
        local @ENV{ qw(IFS CDPATH ENV BASH_ENV) };
        local $ENV{PATH} = untaint_path($ENV{PATH});
        my $devnull = devnull();
        my $apxs = shell_ready($self->{APXS});
        $val = qx($apxs -q $q 2>$devnull);
        chomp $val if defined $val; # apxs post-2.0.40 adds a new line
        if ($val) {
            $self->{_apxs}{$q} = $val;
        }
        unless ($val) {
            if ($ok_fail) {
                return "";
            }
            else {
                warn "APXS ($self->{APXS}) query for $q failed\n";
                return $val;
            }
        }
    }
    $self->{_apxs}{$q};
}

# return an untainted PATH
sub untaint_path {
    my $path = shift;
    return '' unless defined $path;
    ($path) = ( $path =~ /(.*)/ );
    # win32 uses ';' for a path separator, assume others use ':'
    my $sep = WIN32 ? ';' : ':';
    # -T disallows relative and empty directories in the PATH
    return join $sep, grep File::Spec->file_name_is_absolute($_),
        grep length($_), split /$sep/, $path;
}

sub pop_dir {
    my $dir = shift;

    my @chunks = splitdir $dir;
    while (my $remove = shift) {
        pop @chunks if $chunks[-1] eq $remove;
    }

    catfile @chunks;
}

sub add_inc {
    my $self = shift;
    return if $ENV{MOD_PERL}; #already setup by mod_perl
    require lib;
    # make sure that Apache-Test/lib will be first in @INC,
    # followed by modperl-2.0/lib (or some other project's lib/),
    # followed by blib/ and finally system-wide libs.
    my $top_dir = $self->{vars}->{top_dir};
    my @dirs = map { catdir $top_dir, "blib", $_ } qw(lib arch);

    my $apache_test_dir = catdir $top_dir, "Apache-Test";
    unshift @dirs, $apache_test_dir if -d $apache_test_dir;

    lib::->import(@dirs);

    if ($ENV{APACHE_TEST_LIVE_DEV}) {
        # add lib/ in a separate call to ensure that it'll end up on
        # top of @INC
        my $lib_dir = catdir $top_dir, "lib";
        lib::->import($lib_dir) if -d $lib_dir;
    }

    #print join "\n", "add_inc", @INC, "";
}

#freeze/thaw so other processes can access config

sub thaw {
    my $class = shift;
    $class->new({thaw => 1, @_});
}

sub freeze {
    require Data::Dumper;
    local $Data::Dumper::Terse = 1;
    my $data = Data::Dumper::Dumper(shift);
    chomp $data;
    $data;
}