X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCGI%2FCarp.pm;h=3ae9c5be7dab52b286d77a20f0767d89ec6ad29d;hb=8f3ccfa25e524ac7012f7d988353f2de4c217ccb;hp=ce9b40719f4e3cd26d7370b02252f46cec193dbf;hpb=13e345655fd69fad07c7c1d3f491abb9523bfcbd;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/lib/CGI/Carp.pm b/lib/CGI/Carp.pm
index ce9b407..3ae9c5b 100644
--- a/lib/CGI/Carp.pm
+++ b/lib/CGI/Carp.pm
@@ -271,7 +271,7 @@ use File::Spec;
 
 $main::SIG{__WARN__}=\&CGI::Carp::warn;
 *CORE::GLOBAL::die = \&CGI::Carp::die;
-$CGI::Carp::VERSION = '1.24';
+$CGI::Carp::VERSION = '1.25';
 $CGI::Carp::CUSTOM_MSG = undef;
 
 # fancy import routine detects and handles 'errorWrap' specially.
@@ -353,30 +353,37 @@ sub _warn {
     }
 }
 
-sub ineval { 
-  (exists $ENV{MOD_PERL} ? 0 : $^S) || _longmess() =~ /eval [\{\']/m 
-}
-
 
 # The mod_perl package Apache::Registry loads CGI programs by calling
 # eval.  These evals don't count when looking at the stack backtrace.
 sub _longmess {
     my $message = Carp::longmess();
-    my $mod_perl = exists $ENV{MOD_PERL};
-    $message =~ s,eval[^\n]+Apache/Registry\.pm.*,,s if $mod_perl;
-    return $message;    
+    $message =~ s,eval[^\n]+(ModPerl|Apache)/Registry\w*\.pm.*,,s
+        if exists $ENV{MOD_PERL};
+    return $message;
+}
+
+sub ineval {
+  (exists $ENV{MOD_PERL} ? 0 : $^S) || _longmess() =~ /eval [\{\']/m
 }
 
 sub die {
+  my ($arg) = @_;
   realdie @_ if ineval;
-  my ($message) = @_;
-  my $time = scalar(localtime);
-  my($file,$line,$id) = id(1);
-  $message .= " at $file line $line." unless $message=~/\n$/;
-  &fatalsToBrowser($message) if $WRAP;
-  my $stamp = stamp;
-  $message=~s/^/$stamp/gm;
-  realdie $message;
+  if (!ref($arg)) {
+    $arg = join("", @_);
+    my($file,$line,$id) = id(1);
+    $arg .= " at $file line $line." unless $arg=~/\n$/;
+    &fatalsToBrowser($arg) if $WRAP;
+    if (($arg =~ /\n$/) || !exists($ENV{MOD_PERL})) {
+      my $stamp = stamp;
+      $arg=~s/^/$stamp/gm;
+    }
+    if ($arg !~ /\n$/) {
+      $arg .= "\n";
+    }
+  }
+  realdie $arg;
 }
 
 sub set_message {
@@ -408,58 +415,76 @@ sub warningsToBrowser {
 
 # headers
 sub fatalsToBrowser {
-    my($msg) = @_;
-    $msg=~s/&/&/g;
-    $msg=~s/>/>/g;
-    $msg=~s/</&lt;/g;
-    $msg=~s/\"/&quot;/g;
-    my($wm) = $ENV{SERVER_ADMIN} ? 
-	qq[the webmaster (<a href="mailto:$ENV{SERVER_ADMIN}">$ENV{SERVER_ADMIN}</a>)] :
-	"this site's webmaster";
-    my ($outer_message) = <<END;
+  my($msg) = @_;
+  $msg=~s/&/&amp;/g;
+  $msg=~s/>/&gt;/g;
+  $msg=~s/</&lt;/g;
+  $msg=~s/\"/&quot;/g;
+  my($wm) = $ENV{SERVER_ADMIN} ? 
+    qq[the webmaster (<a href="mailto:$ENV{SERVER_ADMIN}">$ENV{SERVER_ADMIN}</a>)] :
+      "this site's webmaster";
+  my ($outer_message) = <<END;
 For help, please send mail to $wm, giving this error message 
 and the time and date of the error.
 END
-    ;
-    my $mod_perl = exists $ENV{MOD_PERL};
-    print STDOUT "Content-type: text/html\n\n" 
-	unless $mod_perl;
-
-    warningsToBrowser(1);    # emit warnings before dying
-
-    if ($CUSTOM_MSG) {
-	if (ref($CUSTOM_MSG) eq 'CODE') {
-	    &$CUSTOM_MSG($msg); # nicer to perl 5.003 users
-	    return;
-	} else {
-	    $outer_message = $CUSTOM_MSG;
-	}
+  ;
+  my $mod_perl = exists $ENV{MOD_PERL};
+  print STDOUT "Content-type: text/html\n\n" 
+    unless $mod_perl;
+
+  warningsToBrowser(1);    # emit warnings before dying
+
+  if ($CUSTOM_MSG) {
+    if (ref($CUSTOM_MSG) eq 'CODE') {
+      &$CUSTOM_MSG($msg); # nicer to perl 5.003 users
+      return;
+    } else {
+      $outer_message = $CUSTOM_MSG;
     }
+  }
     
-    my $mess = <<END;
+  my $mess = <<END;
 <h1>Software error:</h1>
 <pre>$msg</pre>
 <p>
 $outer_message
 </p>
 END
-    ;
-
-    if ($mod_perl && (my $r = Apache->request)) {
-	# If bytes have already been sent, then
-	# we print the message out directly.
-	# Otherwise we make a custom error
-	# handler to produce the doc for us.
-	if ($r->bytes_sent) {
-	    $r->print($mess);
-	    $r->exit;
-	} else {
-	    $r->status(500);
-	    $r->custom_response(500,$mess);
-	}
+  ;
+  
+  if ($mod_perl) {
+    require mod_perl;
+    if ($mod_perl::VERSION >= 1.99) {
+      $mod_perl = 2;
+      require Apache::RequestRec;
+      require Apache::RequestIO;
+      require Apache::RequestUtil;
+      require APR::Pool;
+      require ModPerl::Util;
+      require Apache::Response;
+    }
+    my $r = Apache->request;
+    # If bytes have already been sent, then
+    # we print the message out directly.
+    # Otherwise we make a custom error
+    # handler to produce the doc for us.
+    if ($r->bytes_sent) {
+      $r->print($mess);
+      $mod_perl == 2 ? ModPerl::Util::exit(0) : $r->exit;
     } else {
-	print STDOUT $mess;
+      # MSIE browsers don't show the $mess when sent
+      # a custom 500 response.
+      if ($ENV{HTTP_USER_AGENT} =~ /MSIE/) {
+	$r->send_http_header('text/html');
+	$r->print($mess);
+	$mod_perl == 2 ? ModPerl::Util::exit(0) : $r->exit;
+      } else {
+	$r->custom_response(500,$mess);
+      }
     }
+  } else {
+    print STDOUT $mess;
+  }
 }
 
 # Cut and paste from CGI.pm so that we don't have the overhead of