view release on metacpan or  search on metacpan

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

    # - httpd will be always set
    # - apxs is optional

    $orig_cwd ||= Cwd::cwd();
    chdir $orig_cwd;
    my $new_opts = " -httpd $vars->{httpd}";
    $new_opts .= " -apxs $vars->{apxs}" if $vars->{apxs};

    my $new_command = $orig_command;

    # strip any old bogus -httpd/-apxs
    $new_command =~ s/--?httpd\s+$orig_conf_opts->{httpd}//
        if $orig_conf_opts->{httpd};
    $new_command =~ s/--?httpd\s+$orig_conf_opts->{httpd}//
        if $orig_conf_opts->{httpd} and $vars->{apxs};

    # add new opts
    $new_command .= $new_opts;

    warning "running with new config opts: $new_command";

    # use 'or die' to avoid warnings due to possible overrides of die
    exec $new_command or die "exec $new_command has failed";
}


# make it easy to move the whole distro w/o running
# 't/TEST -clean' before moving. when moving the whole package,
# the old cached config will stay, so we want to nuke it only if
# we realize that it's no longer valid. we can't just check the
# existance of the saved top_dir value, since the project may have
# been copied and the old dir could be still there, but that's not
# the one that we work in
sub detect_relocation {
    my($self, $cur_top_dir) = @_;

    my $config_file = catfile qw(t conf apache_test_config.pm);
    return unless -e $config_file;

    my %inc = %INC;
    eval { require "./$config_file" };
    %INC = %inc; # be stealth
    warn($@), return if $@;

    my $cfg = 'apache_test_config'->new;

    # if the top_dir from saved config doesn't match the current
    # top_dir, that means that the whole project was relocated to a
    # different directory, w/o running t/TEST -clean first (in each
    # directory with a test suite)
    my $cfg_top_dir = $cfg->{vars}->{top_dir};
    return unless $cfg_top_dir;
    return if $cfg_top_dir eq $cur_top_dir;

    # if that's the case silently fixup the saved config to use the
    # new paths, and force a complete cleanup. if we don't fixup the
    # config files, the cleanup process won't be able to locate files
    # to delete and re-configuration will fail
    {
        # in place editing
        local @ARGV = $config_file;
        local $^I = ".bak";  # Win32 needs a backup
        while (<>) {
            s{$cfg_top_dir}{$cur_top_dir}g;
            print;
        }
        unlink $config_file . $^I;
    }

    my $cleanup_cmd = "$^X $0 -clean";
    warning "cleaning up the old config";
    # XXX: do we care to check success?
    system $cleanup_cmd;

    # XXX: I tried hard to accomplish that w/o starting a new process,
    # but too many things get on the way, so for now just keep it as an
    # external process, as it's absolutely transparent to the normal
    # app-run
}

my @oh = qw(jeez golly gosh darn shucks dangit rats nuts dangnabit crap);
sub oh {
    $oh[ rand scalar @oh ];
}

#e.g. t/core or t/core.12499
my $core_pat = '^core(\.\d+)?' . "\$";

# $self->scan_core_incremental([$only_top_dir])
# normally would be called after each test
# and since it updates the list of seen core files
# scan_core() won't report these again
# currently used in Apache::TestSmoke
#
# if $only_t_dir arg is true only the t_dir dir (t/) will be scanned
sub scan_core_incremental {
    my($self, $only_t_dir) = @_;
    my $vars = $self->{test_config}->{vars};

    # no core files dropped on win32
    return () if Apache::TestConfig::WIN32;

    if ($only_t_dir) {
        require IO::Dir;
        my @cores = ();
        for (IO::Dir->new($vars->{t_dir})->read) {
            my $file = catfile $vars->{t_dir}, $_;
            next unless -f $file;
            next unless /$core_pat/o;
            next if exists $core_files{$file} &&
                $core_files{$file} == -M $file;
            $core_files{$file} = -M $file;
            push @cores, $file;
        }
        return @cores
            ? join "\n", "server dumped core, for stacktrace, run:",
                map { "gdb $vars->{httpd} -core $_" } @cores
            : ();
    }

    my @msg = ();