view release on metacpan or  search on metacpan

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

        else {
            warning "removing stale debugger note: $file";
            unlink $file;
        }
    }

    $self->check_runtime_user();

    if ($opts->{'start-httpd'}) {
        exit_perl 0 unless $server->start;
    }
    elsif ($opts->{'run-tests'}) {
        my $is_up = $server->ping
            || (exists $self->{opts}->{ping}
                && $self->{opts}->{ping}  eq 'block'
                && $server->wait_till_is_up(STARTUP_TIMEOUT));
        unless ($is_up) {
            error "server is not ready yet, try again.";
            exit_perl 0;
        }
    }
}

sub run_tests {
    my $self = shift;

    my $test_opts = {
        verbose => $self->{opts}->{verbose},
        tests   => $self->{tests},
        order   => $self->{opts}->{order},
        subtests => $self->{subtests} || [],
    };

    if (grep { exists $self->{opts}->{$_} } @request_opts) {
        run_request($self->{test_config}, $self->{opts});
    }
    else {
        Apache::TestHarness->run($test_opts)
            if $self->{opts}->{'run-tests'};
    }
}

sub stop {
    my $self = shift;

    return $self->{server}->stop if $self->{opts}->{'stop-httpd'};
}

sub new_test_config {
    my $self = shift;

    Apache::TestConfig->new($self->{conf_opts});
}

sub set_ulimit_via_sh {
    return if Apache::TestConfig::WINFU;
    return if $ENV{APACHE_TEST_ULIMIT_SET};

    # only root can allow unlimited core dumps on Solaris (8 && 9?)
    if (Apache::TestConfig::SOLARIS) {
        my $user = getpwuid($>) || '';
        if ($user ne 'root') {
            warning "Skipping 'set unlimited ulimit for coredumps', " .
                "since we are running as a non-root user on Solaris";
            return;
        }
    }

    my $binsh = '/bin/sh';
    return unless -e $binsh;
    $ENV{APACHE_TEST_ULIMIT_SET} = 1;

    my $sh = Symbol::gensym();
    open $sh, "echo ulimit -a | $binsh|" or die;
    local $_;
    while (<$sh>) {
        if (/^core.*unlimited$/) {
            #already set to unlimited
            $ENV{APACHE_TEST_ULIMIT_SET} = 1;
            return;
        }
    }
    close $sh;

    $orig_command = "ulimit -c unlimited; $orig_command";
    warning "setting ulimit to allow core files\n$orig_command";
    # use 'or die' to avoid warnings due to possible overrides of die
    exec $orig_command or die "exec $orig_command has failed";
}

sub set_ulimit {
    my $self = shift;
    #return if $self->set_ulimit_via_bsd_resource;
    eval { $self->set_ulimit_via_sh };
}

sub set_env {
    #export some environment variables for t/modules/env.t
    #(the values are unimportant)
    $ENV{APACHE_TEST_HOSTNAME} = 'test.host.name';
    $ENV{APACHE_TEST_HOSTTYPE} = 'z80';
}

sub run {
    my $self = shift;

    # assuming that test files are always in the same directory as the
    # driving script, make it possible to run the test suite from any place
    # use a full path, which will work after chdir (e.g. ./TEST)
    $0 = File::Spec->rel2abs($0);
    if (-e $0) {
        my $top = dirname dirname $0;
        chdir $top if $top and -d $top;
    }

    # reconstruct argv, preserve multiwords args, eg 'PerlTrace all'
    my $argv = join " ", map { /^-/ ? $_ : qq['$_'] } @ARGV;
    $orig_command = "$^X $0 $argv";
    $orig_cwd = Cwd::cwd();
    $self->set_ulimit;
    $self->set_env; #make sure these are always set

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

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

# catch any attempts to ./t/TEST the tests as root user

sub check_runtime_user {
    my $self = shift;

    return if Apache::TestConfig::WINFU;

    my $user = getpwuid($>) || '';

    if ($user eq 'root') {
        error "Apache cannot spawn child processes as root, therefore the test suite must be run as a non-privileged user.";
        exit_perl(1);
    }

    return 1;
}

sub run_request {
    my($test_config, $opts) = @_;

    my @args = (%{ $opts->{header} }, %{ $opts->{req_args} });

    my($request, $url) = ("", "");

    for (@request_opts) {
        next unless exists $opts->{$_};
        $url = $opts->{$_} if $opts->{$_};
        $request = join $request ? '_' : '', $request, $_;
    }

    if ($request) {
        my $method = \&{"Apache::TestRequest::\U$request"};
        my $res = $method->($url, @args);
        print Apache::TestRequest::to_string($res);
    }
}

sub opt_clean {
    my($self, $level) = @_;
    my $test_config = $self->{test_config};
    $test_config->server->stop;
    $test_config->clean($level);
    1;
}

sub opt_ping {
    my($self) = @_;

    my $test_config = $self->{test_config};
    my $server = $test_config->server;
    my $pid = $server->ping;
    my $name = $server->{name};
    # support t/TEST -ping=block -run ...
    my $exit = not $self->{opts}->{'run-tests'};

    if ($pid) {
        if ($pid == -1) {
            error "port $test_config->{vars}->{port} is in use, ".
                  "but cannot determine server pid";
        }
        else {
            my $version = $server->{version};
            warning "server $name running (pid=$pid, version=$version)";
        }
        return $exit;
    }

    if (exists $self->{opts}->{ping} && $self->{opts}->{ping} eq 'block') {