view release on metacpan or  search on metacpan

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

use strict;
use warnings FATAL => 'all';

use Config;
use Socket ();
use File::Spec::Functions qw(catfile);

use Apache::TestTrace;
use Apache::TestRun;
use Apache::TestConfig ();
use Apache::TestRequest ();

use constant COLOR => Apache::TestConfig::COLOR;
use constant WIN32 => Apache::TestConfig::WIN32;

my $CTRL_M = COLOR ? "\r" : "\n";

# some debuggers use the same syntax as others, so we reuse the same
# code by using the following mapping
my %debuggers = (
    gdb      => 'gdb',
    ddd      => 'gdb',
    valgrind => 'valgrind',
    strace   => 'strace',
);

sub new {
    my $class = shift;
    my $config = shift;

    my $self = bless {
        config => $config || Apache::TestConfig->thaw,
    }, $class;

    $self->{name} = join ':',
      map { $self->{config}->{vars}->{$_} } qw(servername port);

    $self->{port_counter} = $self->{config}->{vars}->{port};

    $self;
}

# call this when you already know where httpd is
sub post_config {
    my($self) = @_;

    $self->{version} = $self->{config}->httpd_version || '';
    $self->{mpm}     = $self->{config}->httpd_mpm     || '';

    # try to get the revision number from the standard Apache version
    # string and various variations made by distributions which mangle
    # that string

    # Foo-Apache-Bar/x.y.z
    ($self->{rev}) = $self->{version} =~ m|/(\d)\.|;

    if ($self->{rev}) {
        debug "Matched Apache revision $self->{version} $self->{rev}";
    }
    else {
        # guessing is not good as it'll only mislead users
        # and we can't die since a config object is required
        # during Makefile.PL's write_perlscript when path to httpd may
        # be unknown yet. so default to non-existing version 0 for now.
        # and let TestRun.pm figure out the required pieces
        debug "can't figure out Apache revision, from string: " .
            "'$self->{version}', using a non-existing revision 0";
        $self->{rev} = 0; # unknown
    }

    ($self->{revminor}) = $self->{version} =~ m|/\d\.(\d)|;

    if ($self->{revminor}) {
        debug "Matched Apache revminor $self->{version} $self->{revminor}";
    }
    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;