$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.
}
}
-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 {
# headers
sub fatalsToBrowser {
- my($msg) = @_;
- $msg=~s/&/&/g;
- $msg=~s/>/>/g;
- $msg=~s/</</g;
- $msg=~s/\"/"/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/&/&/g;
+ $msg=~s/>/>/g;
+ $msg=~s/</</g;
+ $msg=~s/\"/"/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