Provide alternative error handling

New constructor parameter on_error controls error handling.

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.