path: root/lib/Apache/Defaults.pm

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 = '0.10';

sub new {
    my $class = shift;
    my $self = bless {}, $class;
    local %_ = @_;
    my $v;
    my @servlist;
    if ($v = delete $_{server}) {
	if (ref($v) eq 'ARRAY') {
	    @servlist = @$v;
	} else {
	    @servlist = ( $v );
	}
    } else {
	@servlist = qw(/usr/sbin/httpd /usr/sbin/apache2);
    }
    
    if (my @select = grep { -x $_->[0] }
                      map { [ shellwords($_) ] } @servlist) {
	$self->{server} = shift @select;
    } else {
	croak "No suitable httpd binary found";
    }

    if ($v = delete $_{environ}) {
	my $env = Shell::GetEnv->new('sh', ". $v",
				     { startup => 0 });
	if ($env->status) {
	    croak "Got status ".$env->status." trying to inherit environment";
	}
	$self->{environ} = $env->envs;
     }

    croak "unrecognized arguments" if keys(%_);
    return $self;
}	    

sub server { shift->{server}[0] }
sub server_command { @{shift->{server}} }
sub environ { shift->{environ} }

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

    open(my $nullout, '>', File::Spec->devnull);
    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 ($? == -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>);
	}
    }
    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;
    unless ($self->{has_version_info}) {
	$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');
    }
    $self->{has_version_info} = 1;
}

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

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

sub defines {
    my $self = shift;
    $self->_get_version_info;
    if (@_) {
	return @{$self->{defines}}{@_};
    }
    return sort keys %{$self->{defines}};
}

# List of module sources and corresponding identifiers, obtained from the
# httpd-2.4.6 source.
my %modlist = (
    'event.c' => 'mpm_event_module',
    'prefork.c' => 'mpm_prefork_module',
    'worker.c' => 'mpm_worker_module',
    'mod_access_compat.c' => 'access_compat_module',
    'mod_actions.c' => 'actions_module',
    'mod_alias.c' => 'alias_module',
    'mod_allowmethods.c' => 'allowmethods_module',
    'mod_asis.c' => 'asis_module',
    'mod_auth_basic.c' => 'auth_basic_module',
    'mod_auth_digest.c' => 'auth_digest_module',
    'mod_auth_form.c' => 'auth_form_module',
    'mod_authn_anon.c' => 'authn_anon_module',
    'mod_authn_core.c' => 'authn_core_module',
    'mod_authn_dbd.c' => 'authn_dbd_module',
    'mod_authn_dbm.c' => 'authn_dbm_module',
    'mod_authn_file.c' => 'authn_file_module',
    'mod_authn_socache.c' => 'authn_socache_module',
    'mod_authnz_ldap.c' => 'authnz_ldap_module',
    'mod_authz_core.c' => 'authz_core_module',
    'mod_authz_dbd.c' => 'authz_dbd_module',
    'mod_authz_dbm.c' => 'authz_dbm_module',
    'mod_authz_groupfile.c' => 'authz_groupfile_module',
    'mod_authz_host.c' => 'authz_host_module',
    'mod_authz_owner.c' => 'authz_owner_module',
    'mod_authz_user.c' => 'authz_user_module',
    'mod_autoindex.c' => 'autoindex_module',
    'mod_buffer.c' => 'buffer_module',
    'mod_cache.c' => 'cache_module',
    'mod_cache_disk.c' => 'cache_disk_module',
    'mod_cache_socache.c' => 'cache_socache_module',
    'mod_cern_meta.c' => 'cern_meta_module',
    'mod_cgi.c' => 'cgi_module',
    'mod_cgid.c' => 'cgid_module',
    'mod_charset_lite.c' => 'charset_lite_module',
    'mod_data.c' => 'data_module',
    'mod_dav.c' => 'dav_module',
    'mod_dav_fs.c' => 'dav_fs_module',
    'mod_dav_lock.c' => 'dav_lock_module',
    'mod_dbd.c' => 'dbd_module',
    'mod_deflate.c' => 'deflate_module',
    'mod_dialup.c' => 'dialup_module',
    'mod_dir.c' => 'dir_module',
    'mod_dumpio.c' => 'dumpio_module',
    'mod_echo.c' => 'echo_module',
    'mod_env.c' => 'env_module',
    'mod_example.c' => 'example_module',
    'mod_expires.c' => 'expires_module',
    'mod_ext_filter.c' => 'ext_filter_module',
    'mod_file_cache.c' => 'file_cache_module',
    'mod_filter.c' => 'filter_module',
    'mod_headers.c' => 'headers_module',
    'mod_heartbeat' => 'heartbeat_module',
    'mod_heartmonitor.c' => 'heartmonitor_module',
    'mod_ident.c' => 'ident_module',
    'mod_imagemap.c' => 'imagemap_module',
    'mod_include.c' => 'include_module',
    'mod_info.c' => 'info_module',
    'mod_isapi.c' => 'isapi_module',
    'mod_lbmethod_bybusyness.c' => 'lbmethod_bybusyness_module',
    'mod_lbmethod_byrequests.c' => 'lbmethod_byrequests_module',
    'mod_lbmethod_bytraffic.c' => 'lbmethod_bytraffic_module',
    'mod_lbmethod_heartbeat.c' => 'lbmethod_heartbeat_module',
    'util_ldap.c' => 'ldap_module',
    'mod_log_config.c' => 'log_config_module',
    'mod_log_debug.c' => 'log_debug_module',
    'mod_log_forensic.c' => 'log_forensic_module',
    'mod_logio.c' => 'logio_module',
    'mod_lua.c' => 'lua_module',
    'mod_macro.c' => 'macro_module',
    'mod_mime.c' => 'mime_module',
    'mod_mime_magic.c' => 'mime_magic_module',
    'mod_negotiation.c' => 'negotiation_module',
    'mod_nw_ssl.c' => 'nwssl_module',
    'mod_privileges.c' => 'privileges_module',
    'mod_proxy.c' => 'proxy_module',
    'mod_proxy_ajp.c' => 'proxy_ajp_module',
    'mod_proxy_balancer.c' => 'proxy_balancer_module',
    'mod_proxy_connect.c' => 'proxy_connect_module',
    'mod_proxy_express.c' => 'proxy_express_module',
    'mod_proxy_fcgi.c' => 'proxy_fcgi_module',
    'mod_proxy_fdpass.c' => 'proxy_fdpass_module',
    'mod_proxy_ftp.c' => 'proxy_ftp_module',
    'mod_proxy_html.c' => 'proxy_html_module',
    'mod_proxy_http.c' => 'proxy_http_module',
    'mod_proxy_scgi.c' => 'proxy_scgi_module',
    'mod_proxy_wstunnel.c' => 'proxy_wstunnel_module',
    'mod_ratelimit.c' => 'ratelimit_module',
    'mod_reflector.c' => 'reflector_module',
    'mod_remoteip.c' => 'remoteip_module',
    'mod_reqtimeout.c' => 'reqtimeout_module',
    'mod_request.c' => 'request_module',
    'mod_rewrite.c' => 'rewrite_module',
    'mod_sed.c' => 'sed_module',
    'mod_session.c' => 'session_module',
    'mod_session_cookie.c' => 'session_cookie_module',
    'mod_session_crypto.c' => 'session_crypto_module',
    'mod_session_dbd.c' => 'session_dbd_module',
    'mod_setenvif.c' => 'setenvif_module',
    'mod_slotmem_plain.c' => 'slotmem_plain_module',
    'mod_slotmem_shm.c' => 'slotmem_shm_module',
    'mod_so.c' => 'so_module',
    'mod_socache_dbm.c' => 'socache_dbm_module',
    'mod_socache_dc.c' => 'socache_dc_module',
    'mod_socache_memcache.c' => 'socache_memcache_module',
    'mod_socache_shmcb.c' => 'socache_shmcb_module',
    'mod_speling.c' => 'speling_module',
    'mod_ssl.c' => 'ssl_module',
    'mod_status.c' => 'status_module',
    'mod_substitute.c' => 'substitute_module',
    'mod_suexec.c' => 'suexec_module',
    'mod_unique_id.c' => 'unique_id_module',
    'mod_unixd.c' => 'unixd_module',
    'mod_userdir.c' => 'userdir_module',
    'mod_usertrack.c' => 'usertrack_module',
    'mod_version.c' => 'version_module',
    'mod_vhost_alias.c' => 'vhost_alias_module',
    'mod_watchdog.c' => 'watchdog_module',
    'mod_xml2enc.c' => 'xml2enc_module'
);

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

sub _get_module_info {
    my $self = shift;
    unless ($self->{has_module_info}) {
	$self->probe(sub {
	                    local $_ = shift;
#			    print "GOT $_\n";
			    if (/^\s*(\S+\.c)$/ && exists($modlist{$1})) {
				$self->{preloaded}{$modlist{$1}} = $1;
			    }
			    return 1;
		     }, '-l');
	$self->{has_module_info} = 1;
    }
}

1;
__END__
=head1 NAME

Apache::Defaults - Get default settings for Apache httpd daemon

=head1 SYNOPSIS

    $x = new Apache::Defaults;
    print $x->name;
    print $x->version;
    print $x->server_root;
    print $x->built;
    print $x->architecture;
    print $x->MPM;
    print $x->defines('DYNAMIC_MODULE_LIMIT');
    print $x->preloaded('cgi_module');

=head1 DESCRIPTION

Detects the default settings of the Apache httpd daemon by invoking
it with appropriate options and analyzing its output.

=head1 METHODS

=head2 new

    $x = new Apache::Defaults(%attrs);

Detects the settings of the apache server and returns the object representing
them. Attributes (I<%attrs>) are:

=over 4

=item C<server>

Full pathname of the B<httpd> binary to inspect. The argument can also be
a reference to the list of possible pathnames. In this case, the first of
them that exists on disk and has executable privileges will be used. Full
command line can also be used, e.g.:

    server => '/usr/sbin/httpd -d /etc/httpd'

The default used in the absense of this attribute is:

    [ '/usr/sbin/httpd', '/usr/sbin/apache2' ]

=item C<environ>

Name of the shell script that sets the environment for B<httpd> invocation.
For some obscure reason, B<httpd> attempts to read its configuration file
even if invoked with the B<-V> option (which is intended to print the version
and build parameters of the daemon). It will fail if its configuration refers
to the environment variables, defined elsewhere. This situation is quite
common in Debian-based distributions, which define the environment variables
in file F</etc/apache2/envvars>. This attribute is intended to cope with
such problems, e.g.:

    $x = new Apache::Defaults(environ => /etc/apache2/envvars)
    
=back

The method will I<croak> if an error occurs (e.g. the server binary
is not found or exits with failure).

=head2 server

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

=head2 server_command

    @cmd = $x->server_command;

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

=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.    
    
=head1 AUTHORS

Sergey Poznyakoff <gray@gnu.org>        
    
=cut