diff options
author | Sergey Poznyakoff <gray@gnu.org> | 2018-02-22 16:17:11 +0200 |
---|---|---|
committer | Sergey Poznyakoff <gray@gnu.org> | 2018-02-22 16:17:11 +0200 |
commit | a69997afd7c96a6f6c91a6a88653c37387b09190 (patch) | |
tree | 11802f0584b088729127814ff561993109f0b86b /lib/Apache | |
parent | c16f2363476167d59a2eaad38ef9e98f032ebdd1 (diff) | |
download | apache-defaults-a69997afd7c96a6f6c91a6a88653c37387b09190.tar.gz apache-defaults-a69997afd7c96a6f6c91a6a88653c37387b09190.tar.bz2 |
Provide alternative error handling
New constructor parameter on_error controls error handling.
Diffstat (limited to 'lib/Apache')
-rw-r--r-- | lib/Apache/Defaults.pm | 103 |
1 files changed, 72 insertions, 31 deletions
diff --git a/lib/Apache/Defaults.pm b/lib/Apache/Defaults.pm index 08c4865..b980333 100644 --- a/lib/Apache/Defaults.pm +++ b/lib/Apache/Defaults.pm @@ -13,9 +13,16 @@ our $VERSION = '0.10'; sub new { my $class = shift; - my $self = bless {}, $class; + 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') { @@ -30,6 +37,9 @@ sub new { 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"; } @@ -38,12 +48,22 @@ sub new { my $env = Shell::GetEnv->new('sh', ". $v", { startup => 0 }); if ($env->status) { - croak "Got status ".$env->status." trying to inherit environment"; + if ($self->{on_error} eq 'return') { + $self->{status} = $env->status; + $self->{error} = "Failed to inherit environment"; + } else { + croak sprintf("Got status %d trying to inherit environment", + $env->status); + } } $self->{environ} = $env->envs; } croak "unrecognized arguments" if keys(%_); + + $self->_get_version_info unless $self->status; + $self->_get_module_info unless $self->status; + return $self; } @@ -67,16 +87,22 @@ sub probe { 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>); + 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; @@ -94,8 +120,7 @@ sub dequote { sub _get_version_info { my $self = shift; - unless ($self->{has_version_info}) { - $self->probe(sub { + $self->probe(sub { local $_ = shift; if (m{^Server version:\s+(.+?)/(\S+)\s+\((.*?)\)}) { $self->{name} = $1; @@ -129,11 +154,10 @@ sub _get_version_info { } return 1; }, '-V'); - } - $self->{has_version_info} = 1; } -my @ATTRIBUTES = qw(name +my @ATTRIBUTES = qw(status error + name version platform built @@ -146,11 +170,7 @@ my @ATTRIBUTES = qw(name { no strict 'refs'; foreach my $attribute (@ATTRIBUTES) { - *{ __PACKAGE__ . '::' . $attribute } = sub { - my $self = shift; - $self->_get_version_info; - $self->{$attribute}; - } + *{ __PACKAGE__ . '::' . $attribute } = sub { shift->{$attribute} } } } @@ -158,7 +178,6 @@ sub server_root { shift->defines('HTTPD_ROOT') } sub defines { my $self = shift; - $self->_get_version_info; if (@_) { return @{$self->{defines}}{@_}; } @@ -290,7 +309,6 @@ my %modlist = ( sub preloaded { my $self = shift; - $self->_get_module_info; if (@_) { return @{$self->{preloaded}}{@_}; } @@ -299,8 +317,7 @@ sub preloaded { sub _get_module_info { my $self = shift; - unless ($self->{has_module_info}) { - $self->probe(sub { + $self->probe(sub { local $_ = shift; # print "GOT $_\n"; if (/^\s*(\S+\.c)$/ && exists($modlist{$1})) { @@ -308,8 +325,6 @@ sub _get_module_info { } return 1; }, '-l'); - $self->{has_module_info} = 1; - } } 1; @@ -371,12 +386,38 @@ 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) - + +=item C<on_error> + +Controls the error handling. Allowed values are C<croak> and C<return>. +If the value is C<croak> (the default), the method will I<croak> if an +error occurs. If set to C<return>, the constructor will return a valid +object. The B<httpd> exit status and diagnostics emitted to the stderr +will be available via the B<status> and B<error> methods. + =back The method will I<croak> if an error occurs (e.g. the server binary is not found or exits with failure). +=head2 status + + $x = new Apache::Defaults(on_error => 'return'); + if ($x->status) { + die $x->error; + } + +Returns the status of the last B<httpd> invocation (i.e. the value of +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; @@ -387,11 +428,11 @@ Returns the pathname of the B<httpd> binary. @cmd = $x->server_command; -Returns full command line of the B<httpd> binary. +Returns the full command line of the B<httpd> binary. =head2 environ - $hashref = $x->environ + $hashref = $x->environ; Returns a reference to the environment used when invoking the server. |