warn "I'm confused";
die "I'm dying.\n";
+ use CGI::Carp qw(cluck);
+ cluck "I wouldn't do that if I were you";
+
+ use CGI::Carp qw(fatalsToBrowser);
+ die "Fatal error messages are now sent to browser";
+
=head1 DESCRIPTION
CGI scripts have a nasty habit of leaving warning messages in the error
In order to correctly intercept compile-time errors, you should call
set_message() from within a BEGIN{} block.
+=head1 MAKING WARNINGS APPEAR AS HTML COMMENTS
+
+It is now also possible to make non-fatal errors appear as HTML
+comments embedded in the output of your program. To enable this
+feature, export the new "warningsToBrowser" subroutine. Since sending
+warnings to the browser before the HTTP headers have been sent would
+cause an error, any warnings are stored in an internal buffer until
+you call the warningsToBrowser() subroutine with a true argument:
+
+ use CGI::Carp qw(fatalsToBrowser warningsToBrowser);
+ use CGI qw(:standard);
+ print header();
+ warningsToBrowser(1);
+
+You may also give a false argument to warningsToBrowser() to prevent
+warnings from being sent to the browser while you are printing some
+content where HTML comments are not allowed:
+
+ warningsToBrowser(0); # disable warnings
+ print "<SCRIPT type=javascript><!--\n";
+ print_some_javascript_code();
+ print "//--></SCRIPT>\n";
+ warningsToBrowser(1); # re-enable warnings
+
+Note: In this respect warningsToBrowser() differs fundamentally from
+fatalsToBrowser(), which you should never call yourself!
+
=head1 CHANGE LOG
1.05 carpout() added and minor corrections by Marc Hedlund
1.10 Patch from Chris Dean (ctdean@cogit.com) to allow
module to run correctly under mod_perl.
+1.11 Changed order of > and < escapes.
+
+1.12 Changed die() on line 217 to CORE::die to avoid B<-w> warning.
+
+1.13 Added cluck() to make the module orthogonal with Carp.
+ More mod_perl related fixes.
+
+1.20 Patch from Ilmari Karonen (perl@itz.pp.sci.fi): Added
+ warningsToBrowser(). Replaced <CODE> tags with <PRE> in
+ fatalsToBrowser() output.
+
=head1 AUTHORS
-Lincoln D. Stein <lstein@genome.wi.mit.edu>. Feel free to redistribute
-this under the Perl Artistic License.
+Copyright 1995-1998, 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
@ISA = qw(Exporter);
@EXPORT = qw(confess croak carp);
-@EXPORT_OK = qw(carpout fatalsToBrowser wrap set_message);
+@EXPORT_OK = qw(carpout fatalsToBrowser warningsToBrowser wrap set_message cluck);
$main::SIG{__WARN__}=\&CGI::Carp::warn;
$main::SIG{__DIE__}=\&CGI::Carp::die;
-$CGI::Carp::VERSION = '1.101';
+$CGI::Carp::VERSION = '1.20';
$CGI::Carp::CUSTOM_MSG = undef;
# fancy import routine detects and handles 'errorWrap' specially.
my(%routines);
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);
}
# These are the originals
-# XXX Why not just use CORE::die etc., instead of these two? GSAR
sub realwarn { CORE::warn(@_); }
sub realdie { CORE::die(@_); }
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 "<!-- warning: $msg -->\n";
+ } else {
+ push @WARNINGS, $msg;
+ }
+}
+
+sub ineval { _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 = ($ENV{'GATEWAY_INTERFACE'}
- && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl\//);
+ my $mod_perl = exists $ENV{MOD_PERL};
$message =~ s,eval[^\n]+Apache/Registry\.pm.*,,s if $mod_perl;
- return( $message );
+ return $message;
}
sub die {
- my $message = shift;
- my $time = scalar(localtime);
- my($file,$line,$id) = id(1);
- $message .= " at $file line $line.\n" unless $message=~/\n$/;
- &fatalsToBrowser($message) if $WRAP && _longmess() !~ /eval [{\']/m;
- my $stamp = stamp;
- $message=~s/^/$stamp/gm;
- realdie $message;
+ 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;
}
sub set_message {
local $^W=0;
eval <<EOF;
sub confess { CGI::Carp::die Carp::longmess \@_; }
-sub croak { CGI::Carp::die Carp::shortmess \@_; }
-sub carp { CGI::Carp::warn Carp::shortmess \@_; }
+sub croak { CGI::Carp::die Carp::shortmess \@_; }
+sub carp { CGI::Carp::warn Carp::shortmess \@_; }
+sub cluck { CGI::Carp::warn Carp::longmess \@_; }
EOF
;
}
sub carpout {
my($in) = @_;
my($no) = fileno(to_filehandle($in));
- realdie "Invalid filehandle $in\n" unless defined $no;
+ 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) = @_;
+ $msg=~s/&/&/g;
$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>)] :
and the time and date of the error.
END
;
- print STDOUT "Content-type: text/html\n\n";
+ 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') {
}
}
- print STDOUT <<END;
+ my $mess = <<END;
<H1>Software error:</H1>
-<CODE>$msg</CODE>
+<PRE>$msg</PRE>
<P>
-$outer_message;
+$outer_message
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);
+ }
+ } else {
+ print STDOUT $mess;
+ }
}
# Cut and paste from CGI.pm so that we don't have the overhead of
projects / p5sagit/p5-mst-13.2.git / blobdiff