Apache-Defaults

 view release on metacpan or  search on metacpan

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

package Apache::Defaults;
use strict;
use warnings;
use File::Spec;
use IPC::Open3;
use Shell::GetEnv;
use DateTime::Format::Strptime;
use Text::ParseWords;
use Symbol 'gensym';
use Carp;

our $VERSION = '1.03';

sub new {
    my $class = shift;
    my $self = bless { on_error => 'croak' }, $class;
    local %_ = @_;
    my $v;

    if (my $v = delete $_{on_error}) {
	croak "invalid on_error value"
	    unless grep { $_ eq $v } qw(croak return);
	$self->{on_error} = $v;
    }
    
    my @servlist;
    if ($v = delete $_{server}) {
	if (ref($v) eq 'ARRAY') {
	    @servlist = @$v;
	} else {
	    @servlist = ( $v );
	}
    } else {
	@servlist = qw(/usr/sbin/apachectl /usr/sbin/httpd /usr/sbin/apache2);
    }
    
    if (my @select = grep { -x $_->[0] }
                      map { [ shellwords($_) ] } @servlist) {
	$self->{server} = shift @select;
    } elsif ($self->{on_error} eq 'return') {
	$self->{status} = 127;
	$self->{error} = "No suitable httpd binary found";
    } else {
	croak "No suitable httpd binary found";
    }

    my $envfile = delete $_{environ};
    croak "unrecognized arguments" if keys(%_);

    if ($envfile) {
	unless (-f $envfile) {
	    if ($self->{on_error} eq 'return') {
                $self->{status} = 127;
		$self->{error} = "environment file $envfile does not exist";
		return $self;
	    } else {
		croak "environment file $envfile does not exist";
	    }
	}
	unless (-r $envfile) {
	    if ($self->{on_error} eq 'return') {
                $self->{status} = 127;
		$self->{error} = "environment file $envfile is not readable";
		return $self;
	    } else {
		croak "environment file $envfile is not readable";
	    }

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

sub server { shift->{server}[0] }
sub server_command { @{shift->{server}} }
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}}{@_};

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

the B<$?> perl variable after B<waitpid>). The caller should inspect
this value, after constructing an B<Apache::Defaults> object with
the C<on_error> attribute set to C<return>.

=head2 error

Returns additional diagnostics if B<$x-E<gt>status != 0>. Normally, these are
diagnostic messages that B<httpd> printed to standard error before
termination.    
    
=head2 server

    $s = $x->server;
    
Returns the pathname of the B<httpd> binary.

=head2 server_command

    @cmd = $x->server_command;

Returns the full command line of the B<httpd> binary.

=head2 server_config

    $s = $x->server_config;

Returns the full pathname of the server configuration file.
    
=head2 environ

    $hashref = $x->environ;

Returns a reference to the environment used when invoking the server.

=head2 name

    $s = $x->name;

Returns server implementation name (normally C<Apache>).

=head2 version

    $v = $x->version;

Returns server version (as string).

=head2 platform

    $s = $x->platform;

Platform (distribution) on which the binary is compiled.

=head2 architecture

Architecture for which the server is built.
    
=head2 built

    $d = $x->built;

Returns a B<DateTime> object, representing the time when the server
was built.

=head2 loaded_with

APR tools with which the server is loaded.
    
=head2 compiled_with

APR tools with which the server is compiled.
    
=head2 MPM

MPM module loaded in the configuration.

=head2 MPM_threaded

True if the MPM is threaded.

=head2 MPM_forked

True if the MPM is forked.

=head2 defines

    @names = $x->defines;

Returns the list of symbolic names defined during the compilation. The
names are in lexical order.

    @values = $x->defines(@names);

Returns values of the named defines.

=head2 server_root

    $s = $x->server_root;
    
Returns default server root directory. This is equivalent to

    $x->defines('HTTPD_ROOT');

=head2 preloaded

    @ids = $x->preloaded;

Returns the list of the preloaded module identifiers, in lexical order.

    @sources = $x->preloaded(@ids);

Returns the list of module source names for the given source identifiers.
For non-existing identifiers, B<undef> is returned.

=head1 LICENSE

GPLv3+: GNU GPL version 3 or later, see
L<http://gnu.org/licenses/gpl.html>.
    
This  is  free  software:  you  are free to change and redistribute it.
There is NO WARRANTY, to the extent permitted by law.