view release on metacpan or  search on metacpan

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

sub environ { shift->{environ} }

sub probe {
    my ($self, $cb, @opt) = @_;

    open(my $nullin, '<', File::Spec->devnull);

    my $out = gensym;
    my $err = gensym;
    local %ENV = %{$self->{environ}} if $self->{environ};
    if (my $pid = open3($nullin, $out, $err,
			$self->server_command, @opt)) {
	while (<$out>) {
	    chomp;
	    last unless &{$cb}($_);
	}
	waitpid($pid, 0);
	if ($self->{on_error} eq 'croak') {
	    if ($? == -1) {
		croak "failed to execute " .$self->server . ": $!";
	    } elsif ($? & 127) {
		croak sprintf("%s died with signal %d%s",
			      $self->server, $? & 127,
			      ($? & 128) ? ' (core dumped)' : '');
	    } elsif (my $code = $? >> 8) {
		local $/ = undef;
		croak sprintf("%s terminated with status %d; error message: %s",
			      $self->server, $code, <$err>);
	    }
	} elsif ($?) {
	    local $/ = undef;
	    $self->{status} = $?;
	    $self->{error} = <$err>;
	}
    }
    close $nullin;
    close $out;
    close $err;
}    

sub dequote {
    my ($self, $arg) = @_;
    if ($arg =~ s{^"(.*?)"$}{$1}) {
	$arg =~ s{\\([\\"])}{$1}g;
    }
    return $arg;
}

sub _get_version_info {
    my $self = shift;
    $self->probe(sub {
	    local $_ = shift;
	    if (m{^Server version:\s+(.+?)/(\S+)\s+\((.*?)\)}) {
		$self->{name} = $1;
		$self->{version} = $2;
		$self->{platform} = $3;
	    } elsif (/^Server built:\s+(.+)/) {
		$self->{built} =
		    DateTime::Format::Strptime->new(
			pattern => '%b %d %Y %H:%M%S',
			locale => 'en_US',
			time_zone => 'UTC',
			on_error => 'undef'
		    )->parse_datetime($1);
			
	    } elsif (/^Server loaded:\s+(.+)$/) {
		$self->{loaded_with} = $1;
	    } elsif (/^Compiled using:\s+(.+)$/) {
		$self->{compiled_with} = $1;
	    } elsif (/^Architecture:\s+(.+)$/) {
		$self->{architecture} = $1;
	    } elsif (/^Server MPM:\s+(.+)$/) {
		$self->{MPM} = $1;
            } elsif (/^\s+threaded:\s+(?<b>yes|no)/) {
		$self->{MPM_threaded} = $+{b} eq 'yes';
	    } elsif (/^\s+forked:\s+(?<b>yes|no)/) {
		$self->{MPM_forked} = $+{b} eq 'yes';
	    } elsif (/^\s+-D\s+(?<name>.+?)=(?<val>.+)$/) {
		$self->{defines}{$+{name}} = $self->dequote($+{val});
	    } elsif (/^\s+-D\s+(?<name>\S+)(?:\s*(?<com>.+))?$/) {
		$self->{defines}{$+{name}} = 1;
	    }
	    return 1;
        }, '-V');
}

my @ATTRIBUTES = qw(status error
                    name
                    version
                    platform
                    built
                    loaded_with
                    compiled_with
                    architecture
                    MPM
                    MPM_threaded
                    MPM_forked);
{
    no strict 'refs';
    foreach my $attribute (@ATTRIBUTES) {
	*{ __PACKAGE__ . '::' . $attribute } = sub { shift->{$attribute} }
    }
}

sub server_root { shift->defines('HTTPD_ROOT') }

sub server_config {
    my $self = shift;
    my $conf = $self->defines('SERVER_CONFIG_FILE');
    if ($conf && !File::Spec->file_name_is_absolute($conf)) {
	$conf = File::Spec->catfile($self->server_root, $conf);
    }
    return $conf;
}

sub defines {
    my $self = shift;
    if (@_) {
	return @{$self->{defines}}{@_};
    }
    return sort keys %{$self->{defines}};