view release on metacpan or  search on metacpan

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

    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 = ();
    finddepth({ no_chdir => 1,
                wanted   => sub {
        return unless -f $_;
        my $file = basename $File::Find::name;
        return unless $file =~ /$core_pat/o;
        my $core = $File::Find::name;
        unless (exists $core_files{$core} && $core_files{$core} == -M $core) {
            # new core file!

            # XXX: could rename the file if it doesn't include the pid
            # in its name (i.e., just called 'core', instead of 'core.365')

            # XXX: could pass the test name and rename the core file
            # to use that name as a suffix, plus pid, time or some
            # other unique identifier, in case the same test is run
            # more than once and each time it caused a segfault
            $core_files{$core} = -M $core;
            push @msg, "server dumped core, for stacktrace, run:\n" .
                "gdb $vars->{httpd} -core $core";
        }
    }}, $vars->{top_dir});

    return @msg;

}

sub scan_core {
    my $self = shift;
    my $vars = $self->{test_config}->{vars};
    my $times = 0;

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

    finddepth({ no_chdir => 1,
                wanted   => sub {
        return unless -f $_;
        my $file = basename $File::Find::name;
        return unless $file =~ /$core_pat/o;
        my $core = $File::Find::name;
        if (exists $core_files{$core} && $core_files{$core} == -M $core) {
            # we have seen this core file before the start of the test
            info "an old core file has been found: $core";
        }
        else {
            my $oh = oh();
            my $again = $times++ ? "again" : "";
            error "oh $oh, server dumped core $again";
            error "for stacktrace, run: gdb $vars->{httpd} -core $core";
        }
    }}, $vars->{top_dir});
}

# warn the user that there is a core file before the tests
# start. suggest to delete it before proceeding or a false alarm can
# be generated at the end of the test routine run.
sub warn_core {
    my $self = shift;
    my $vars = $self->{test_config}->{vars};
    %core_files = (); # reset global

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

    finddepth(sub {
        return unless -f $_;
        return unless /$core_pat/o;
        my $core = "$File::Find::dir/$_";
        info "consider removing an old $core file before running tests";
        # remember the timestamp of $core so we can check if it's the
        # old core file at the end of the run and not complain then
        $core_files{$core} = -M $core;
    }, $vars->{top_dir});