view release on metacpan or  search on metacpan

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

    else {
        $self->{revminor} = 0;
    }

    $self;
}

sub version_of {
    my($self, $thing) = @_;
    die "Can't figure out what Apache server generation we are running"
        unless $self->{rev};

    $thing->{$self->{rev}};
}

my @apache_logs = qw(
error_log access_log httpd.pid
apache_runtime_status rewrite_log
ssl_engine_log ssl_request_log
cgisock
);

sub clean {
    my $self = shift;

    my $dir = $self->{config}->{vars}->{t_logs};

    for (@apache_logs) {
        my $file = catfile $dir, $_;
        if (unlink $file) {
            debug "unlink $file";
        }
    }
}

sub pid_file {
    my $self = shift;

    my $vars = $self->{config}->{vars};

    return $vars->{t_pid_file} || catfile $vars->{t_logs}, 'httpd.pid';
}

sub dversion {
    my $self = shift;

    my $dv = "-D APACHE$self->{rev}";

    if ($self->{rev} == 2 and $self->{revminor} == 4) {
        $dv .= " -D APACHE2_4";
    }

    return $dv;
}

sub config_defines {
    my $self = shift;

    my @defines = ();

    for my $item (qw(useithreads)) {
        next unless $Config{$item} and $Config{$item} eq 'define';
        push @defines, "-D PERL_\U$item";
    }

    if (my $defines = $self->{config}->{vars}->{defines}) {
        push @defines, map { "-D $_" } split " ", $defines;
    }

    "@defines";
}

sub args {
    my $self = shift;
    my $vars = $self->{config}->{vars};
    my $dversion = $self->dversion; #for .conf version conditionals
    my $defines = $self->config_defines;

    "-d $vars->{serverroot} -f $vars->{t_conf_file} $dversion $defines";
}

my %one_process = (1 => '-X', 2 => '-D ONE_PROCESS');

sub start_cmd {
    my $self  = shift;

    my $args   = $self->args;
    my $config = $self->{config};
    my $vars   = $config->{vars};
    my $httpd  = $vars->{httpd};

    my $one_process = $self->{run}->{opts}->{'one-process'}
        ? $self->version_of(\%one_process)
        : '';

    #XXX: threaded mpm does not respond to SIGTERM with -D ONE_PROCESS

    return "$httpd $one_process $args";
}

sub default_gdbinit {
    my $gdbinit = "";
    my @sigs = qw(PIPE);

    for my $sig (@sigs) {
        for my $flag (qw(pass nostop)) {
            $gdbinit .= "handle SIG$sig $flag\n";
        }
    }

    $gdbinit;
}

sub strace_cmd {
    my($self, $strace, $file) = @_;
    #XXX truss, ktrace, etc.
    "$strace -f -o $file -s1024";
}

sub valgrind_cmd {
    my($self, $valgrind) = @_;
    "$valgrind -v --leak-check=yes --show-reachable=yes --error-limit=no";
}

sub start_valgrind {
    my $self = shift;
    my $opts = shift;

    my $config       = $self->{config};
    my $args         = $self->args;
    my $one_process  = $self->version_of(\%one_process);
    my $valgrind_cmd = $self->valgrind_cmd($opts->{debugger});
    my $httpd        = $config->{vars}->{httpd};

    my $command = "$valgrind_cmd $httpd $one_process $args";

    debug $command;
    system $command;
}

sub start_strace {
    my $self = shift;
    my $opts = shift;

    my $config      = $self->{config};
    my $args        = $self->args;
    my $one_process = $self->version_of(\%one_process);
    my $file        = catfile $config->{vars}->{t_logs}, 'strace.log';
    my $strace_cmd  = $self->strace_cmd($opts->{debugger}, $file);
    my $httpd       = $config->{vars}->{httpd};

    $config->genfile($file); #just mark for cleanup

    my $command = "$strace_cmd $httpd $one_process $args";

    debug $command;