Got an error: $msg
"; } set_message(\&handle_errors); } In order to correctly intercept compile-time errors, you should call set_message() from within a BEGIN{} block. =head1 DOING MORE THAN PRINTING A MESSAGE IN THE EVENT OF PERL ERRORS If fatalsToBrowser in conjunction with set_message does not provide you with all of the functionality you need, you can go one step further by specifying a function to be executed any time a script calls "die", has a syntax error, or dies unexpectedly at runtime with a line like "undef->explode();". use CGI::Carp qw(set_die_handler); BEGIN { sub handle_errors { my $msg = shift; print "content-type: text/html\n\n"; print "Got an error: $msg
"; #proceed to send an email to a system administrator, #write a detailed message to the browser and/or a log, #etc.... } set_die_handler(\&handle_errors); } Notice that if you use set_die_handler(), you must handle sending HTML headers to the browser yourself if you are printing a message. If you use set_die_handler(), you will most likely interfere with the behavior of fatalsToBrowser, so you must use this or that, not both. Using set_die_handler() sets SIG{__DIE__} (as does fatalsToBrowser), and there is only one SIG{__DIE__}. This means that if you are attempting to set SIG{__DIE__} yourself, you may interfere with this module's functionality, or this module may interfere with your module's functionality. =head2 SUPPRESSING PERL ERRORS APPEARING IN THE BROWSER WINDOW A problem sometimes encountered when using fatalsToBrowser is when a C tags with in
fatalsToBrowser() output.
1.23 ineval() now checks both $^S and inspects the message for the "eval" pattern
(hack alert!) in order to accommodate various combinations of Perl and
mod_perl.
1.24 Patch from Scott Gifford (sgifford@suspectclass.com): Add support
for overriding program name.
1.26 Replaced CORE::GLOBAL::die with the evil $SIG{__DIE__} because the
former isn't working in some people's hands. There is no such thing
as reliable exception handling in Perl.
1.27 Replaced tell STDOUT with bytes=tell STDOUT.
=head1 AUTHORS
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.
Address bug reports and comments to: lstein@cshl.org
=head1 SEE ALSO
Carp, CGI::Base, CGI::BasePlus, CGI::Request, CGI::MiniSvr, CGI::Form,
CGI::Response
=cut
require 5.000;
use Exporter;
#use Carp;
BEGIN {
require Carp;
*CORE::GLOBAL::die = \&CGI::Carp::die;
}
use File::Spec;
@ISA = qw(Exporter);
@EXPORT = qw(confess croak carp);
@EXPORT_OK = qw(carpout fatalsToBrowser warningsToBrowser wrap set_message set_die_handler set_progname cluck ^name= die);
$main::SIG{__WARN__}=\&CGI::Carp::warn;
$CGI::Carp::VERSION = '3.51';
$CGI::Carp::CUSTOM_MSG = undef;
$CGI::Carp::DIE_HANDLER = undef;
$CGI::Carp::TO_BROWSER = 1;
# 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($oldlevel) = $Exporter::ExportLevel;
$Exporter::ExportLevel = 1;
Exporter::import($pkg,keys %routines);
$Exporter::ExportLevel = $oldlevel;
$main::SIG{__DIE__} =\&CGI::Carp::die if $routines{'fatalsToBrowser'};
# $pkg->export('CORE::GLOBAL','die');
}
# These are the originals
sub realwarn { CORE::warn(@_); }
sub realdie { CORE::die(@_); }
sub id {
my $level = shift;
my($pack,$file,$line,$sub) = caller($level);
my($dev,$dirs,$id) = File::Spec->splitpath($file);
return ($file,$line,$id);
}
sub stamp {
my $time = scalar(localtime);
my $frame = 0;
my ($id,$pack,$file,$dev,$dirs);
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);
$message .= " at $file line $line.\n" unless $message=~/\n$/;
_warn($message) if $WARN;
my $stamp = stamp;
$message=~s/^/$stamp/gm;
realwarn $message;
}
sub _warn {
my $msg = shift;
if ($EMIT_WARNINGS) {
# We need to mangle the message a bit to make it a valid HTML
# comment. This is done by substituting similar-looking ISO
# 8859-1 characters for <, > and -. This is a hack.
$msg =~ tr/<>-/\253\273\255/;
chomp $msg;
print STDOUT "\n";
} else {
push @WARNINGS, $msg;
}
}
# 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();
$message =~ s,eval[^\n]+(ModPerl|Apache)/(?:Registry|Dispatch)\w*\.pm.*,,s
if exists $ENV{MOD_PERL};
return $message;
}
sub ineval {
(exists $ENV{MOD_PERL} ? 0 : $^S) || _longmess() =~ /eval [\{\']/m
}
sub die {
# if no argument is passed, propagate $@ like
# the real die
my ($arg,@rest) = @_ ? @_
: $@ ? "$@\t...propagated"
: "Died"
;
&$DIE_HANDLER($arg,@rest) if $DIE_HANDLER;
# the "$arg" is done on purpose!
# if called as die( $object, 'string' ),
# all is stringified, just like with
# the real 'die'
$arg = join '' => "$arg", @rest if @rest;
my($file,$line,$id) = id(1);
$arg .= " at $file line $line.\n" unless ref $arg or $arg=~/\n$/;
realdie $arg if ineval();
&fatalsToBrowser($arg) if ($WRAP and $CGI::Carp::TO_BROWSER);
$arg=~s/^/ stamp() /gme if $arg =~ /\n$/ or not exists $ENV{MOD_PERL};
$arg .= "\n" unless $arg =~ /\n$/;
realdie $arg;
}
sub set_message {
$CGI::Carp::CUSTOM_MSG = shift;
return $CGI::Carp::CUSTOM_MSG;
}
sub set_die_handler {
my ($handler) = shift;
#setting SIG{__DIE__} here is necessary to catch runtime
#errors which are not called by literally saying "die",
#such as the line "undef->explode();". however, doing this
#will interfere with fatalsToBrowser, which also sets
#SIG{__DIE__} in the import() function above (or the
#import() function above may interfere with this). for
#this reason, you should choose to either set the die
#handler here, or use fatalsToBrowser, not both.
$main::SIG{__DIE__} = $handler;
$CGI::Carp::DIE_HANDLER = $handler;
return $CGI::Carp::DIE_HANDLER;
}
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.
sub carpout {
my($in) = @_;
my($no) = fileno(to_filehandle($in));
realdie("Invalid filehandle $in\n") unless defined $no;
open(SAVEERR, ">&STDERR");
open(STDERR, ">&$no") or
( print SAVEERR "Unable to redirect STDERR: $!\n" and exit(1) );
}
sub warningsToBrowser {
$EMIT_WARNINGS = @_ ? shift : 1;
_warn(shift @WARNINGS) while $EMIT_WARNINGS and @WARNINGS;
}
# headers
sub fatalsToBrowser {
my $msg = shift;
$msg = "$msg" if ref $msg;
$msg=~s/&/&/g;
$msg=~s/>/>/g;
$msg=~s/$ENV{SERVER_ADMIN})] :
"this site's webmaster";
my ($outer_message) = <Software error:
$msg
$outer_message
END
;
if ($mod_perl) {
my $r;
if ($ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) {
$mod_perl = 2;
require Apache2::RequestRec;
require Apache2::RequestIO;
require Apache2::RequestUtil;
require APR::Pool;
require ModPerl::Util;
require Apache2::Response;
$r = Apache2::RequestUtil->request;
}
else {
$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 {
# MSIE won't display a custom 500 response unless it is >512 bytes!
if ($ENV{HTTP_USER_AGENT} =~ /MSIE/) {
$mess = "\n$mess";
}
$r->custom_response(500,$mess);
}
} else {
my $bytes_written = eval{tell STDOUT};
if (defined $bytes_written && $bytes_written > 0) {
print STDOUT $mess;
}
else {
print STDOUT "Status: 500\n";
print STDOUT "Content-type: text/html\n\n";
print STDOUT $mess;
}
}
warningsToBrowser(1); # emit warnings before dying
}
# Cut and paste from CGI.pm so that we don't have the overhead of
# always loading the entire CGI module.
sub to_filehandle {
my $thingy = shift;
return undef unless $thingy;
return $thingy if UNIVERSAL::isa($thingy,'GLOB');
return $thingy if UNIVERSAL::isa($thingy,'FileHandle');
if (!ref($thingy)) {
my $caller = 1;
while (my $package = caller($caller++)) {
my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy";
return $tmp if defined(fileno($tmp));
}
}
return undef;
}
1;