sub handle_errors {
my $msg = shift;
print "<h1>Oh gosh</h1>";
- print "Got an error: $msg";
+ print "<p>Got an error: $msg</p>";
}
set_message(\&handle_errors);
}
content where HTML comments are not allowed:
warningsToBrowser(0); # disable warnings
- print "<SCRIPT type=javascript><!--\n";
+ print "<script type=\"text/javascript\"><!--\n";
print_some_javascript_code();
- print "//--></SCRIPT>\n";
+ print "//--></script>\n";
warningsToBrowser(1); # re-enable warnings
Note: In this respect warningsToBrowser() differs fundamentally from
fatalsToBrowser(), which you should never call yourself!
+=head1 OVERRIDING THE NAME OF THE PROGRAM
+
+CGI::Carp includes the name of the program that generated the error or
+warning in the messages written to the log and the browser window.
+Sometimes, Perl can get confused about what the actual name of the
+executed program was. In these cases, you can override the program
+name that CGI::Carp will use for all messages.
+
+The quick way to do that is to tell CGI::Carp the name of the program
+in its use statement. You can do that by adding
+"name=cgi_carp_log_name" to your "use" statement. For example:
+
+ use CGI::Carp qw(name=cgi_carp_log_name);
+
+. If you want to change the program name partway through the program,
+you can use the C<set_progname()> function instead. It is not
+exported by default, you must import it explicitly by saying
+
+ use CGI::Carp qw(set_progname);
+
+Once you've done that, you can change the logged name of the program
+at any time by calling
+
+ set_progname(new_program_name);
+
+You can set the program back to the default by calling
+
+ set_progname(undef);
+
+Note that this override doesn't happen until after the program has
+compiled, so any compile-time errors will still show up with the
+non-overridden program name
+
=head1 CHANGE LOG
1.05 carpout() added and minor corrections by Marc Hedlund
warningsToBrowser(). Replaced <CODE> tags with <PRE> in
fatalsToBrowser() output.
+1.23 ineval() now checks both $^S and inspects the message for the "eval" pattern
+ (hack alert!) in order to accomodate various combinations of Perl and
+ mod_perl.
+
+1.24 Patch from Scott Gifford (sgifford@suspectclass.com): Add support
+ for overriding program name.
+
=head1 AUTHORS
-Copyright 1995-1998, Lincoln D. Stein. All rights reserved.
+Copyright 1995-2002, Lincoln D. Stein. All rights reserved.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
Carp, CGI::Base, CGI::BasePlus, CGI::Request, CGI::MiniSvr, CGI::Form,
CGI::Response
+ if (defined($CGI::Carp::PROGNAME))
+ {
+ $file = $CGI::Carp::PROGNAME;
+ }
=cut
@ISA = qw(Exporter);
@EXPORT = qw(confess croak carp);
-@EXPORT_OK = qw(carpout fatalsToBrowser warningsToBrowser wrap set_message cluck);
+@EXPORT_OK = qw(carpout fatalsToBrowser warningsToBrowser wrap set_message set_progname cluck ^name=);
$main::SIG{__WARN__}=\&CGI::Carp::warn;
-$main::SIG{__DIE__}=\&CGI::Carp::die;
-$CGI::Carp::VERSION = '1.22';
+*CORE::GLOBAL::die = \&CGI::Carp::die;
+$CGI::Carp::VERSION = '1.25';
$CGI::Carp::CUSTOM_MSG = undef;
# fancy import routine detects and handles 'errorWrap' specially.
sub import {
my $pkg = shift;
my(%routines);
+ my(@name);
+
+ if (@name=grep(/^name=/,@_))
+ {
+ my($n) = (split(/=/,$name[0]))[1];
+ set_progname($n);
+ @_=grep(!/^name=/,@_);
+ }
+
grep($routines{$_}++,@_,@EXPORT);
$WRAP++ if $routines{'fatalsToBrowser'} || $routines{'wrap'};
$WARN++ if $routines{'warningsToBrowser'};
my $time = scalar(localtime);
my $frame = 0;
my ($id,$pack,$file,$dev,$dirs);
- do {
- $id = $file;
- ($pack,$file) = caller($frame++);
- } until !$file;
+ if (defined($CGI::Carp::PROGNAME)) {
+ $id = $CGI::Carp::PROGNAME;
+ } else {
+ do {
+ $id = $file;
+ ($pack,$file) = caller($frame++);
+ } until !$file;
+ }
($dev,$dirs,$id) = File::Spec->splitpath($id);
return "[$time] $id: ";
}
+sub set_progname {
+ $CGI::Carp::PROGNAME = shift;
+ return $CGI::Carp::PROGNAME;
+}
+
+
sub warn {
my $message = shift;
my($file,$line,$id) = id(1);
}
}
-sub ineval { $^S }
# 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 {
return $CGI::Carp::CUSTOM_MSG;
}
-sub confess { CGI::Carp::die Carp::longmess \@_; }
-sub croak { CGI::Carp::die Carp::shortmess \@_; }
-sub carp { CGI::Carp::warn Carp::shortmess \@_; }
-sub cluck { CGI::Carp::warn Carp::longmess \@_; }
+sub confess { CGI::Carp::die Carp::longmess @_; }
+sub croak { CGI::Carp::die Carp::shortmess @_; }
+sub carp { CGI::Carp::warn Carp::shortmess @_; }
+sub cluck { CGI::Carp::warn Carp::longmess @_; }
# We have to be ready to accept a filehandle as a reference
# or a string.
# 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;
-<H1>Software error:</H1>
-<PRE>$msg</PRE>
-<P>
+ 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