[p5sagit/p5-mst-13.2.git] / lib / CGI / Carp.pm

package CGI::Carp;

=head1 NAME

B<CGI::Carp> - CGI routines for writing to the HTTPD (or other) error log

=head1 SYNOPSIS

    use CGI::Carp;

    croak "We're outta here!";
    confess "It was my fault: $!";
    carp "It was your fault!";   
    warn "I'm confused";
    die  "I'm dying.\n";

=head1 DESCRIPTION

CGI scripts have a nasty habit of leaving warning messages in the error
logs that are neither time stamped nor fully identified.  Tracking down
the script that caused the error is a pain.  This fixes that.  Replace
the usual

    use Carp;

with

    use CGI::Carp

And the standard warn(), die (), croak(), confess() and carp() calls
will automagically be replaced with functions that write out nicely
time-stamped messages to the HTTP server error log.

For example:

   [Fri Nov 17 21:40:43 1995] test.pl: I'm confused at test.pl line 3.
   [Fri Nov 17 21:40:43 1995] test.pl: Got an error message: Permission denied.
   [Fri Nov 17 21:40:43 1995] test.pl: I'm dying.

=head1 REDIRECTING ERROR MESSAGES

By default, error messages are sent to STDERR.  Most HTTPD servers
direct STDERR to the server's error log.  Some applications may wish
to keep private error logs, distinct from the server's error log, or
they may wish to direct error messages to STDOUT so that the browser
will receive them.

The C<carpout()> function is provided for this purpose.  Since
carpout() is not exported by default, you must import it explicitly by
saying

   use CGI::Carp qw(carpout);

The carpout() function requires one argument, which should be a
reference to an open filehandle for writing errors.  It should be
called in a C<BEGIN> block at the top of the CGI application so that
compiler errors will be caught.  Example:

   BEGIN {
     use CGI::Carp qw(carpout);
     open(LOG, ">>/usr/local/cgi-logs/mycgi-log") or
       die("Unable to open mycgi-log: $!\n");
     carpout(LOG);
   }

carpout() does not handle file locking on the log for you at this point.

The real STDERR is not closed -- it is moved to SAVEERR.  Some
servers, when dealing with CGI scripts, close their connection to the
browser when the script closes STDOUT and STDERR.  SAVEERR is used to
prevent this from happening prematurely.

You can pass filehandles to carpout() in a variety of ways.  The "correct"
way according to Tom Christiansen is to pass a reference to a filehandle 
GLOB:

    carpout(\*LOG);

This looks weird to mere mortals however, so the following syntaxes are
accepted as well:

    carpout(LOG);
    carpout(main::LOG);
    carpout(main'LOG);
    carpout(\LOG);
    carpout(\'main::LOG');

    ... and so on

FileHandle and other objects work as well.

Use of carpout() is not great for performance, so it is recommended
for debugging purposes or for moderate-use applications.  A future
version of this module may delay redirecting STDERR until one of the
CGI::Carp methods is called to prevent the performance hit.

=head1 MAKING PERL ERRORS APPEAR IN THE BROWSER WINDOW

If you want to send fatal (die, confess) errors to the browser, ask to 
import the special "fatalsToBrowser" subroutine:

    use CGI::Carp qw(fatalsToBrowser);
    die "Bad error here";

Fatal errors will now be echoed to the browser as well as to the log.  CGI::Carp
arranges to send a minimal HTTP header to the browser so that even errors that
occur in the early compile phase will be seen.
Nonfatal errors will still be directed to the log file only (unless redirected
with carpout).

=head2 Changing the default message

By default, the software error message is followed by a note to
contact the Webmaster by e-mail with the time and date of the error.
If this message is not to your liking, you can change it using the
set_message() routine.  This is not imported by default; you should
import it on the use() line:

    use CGI::Carp qw(fatalsToBrowser set_message);
    set_message("It's not a bug, it's a feature!");

You may also pass in a code reference in order to create a custom
error message.  At run time, your code will be called with the text
of the error message that caused the script to die.  Example:

    use CGI::Carp qw(fatalsToBrowser set_message);
    BEGIN {
       sub handle_errors {
          my $msg = shift;
          print "<h1>Oh gosh</h1>";
          print "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 CHANGE LOG

1.05 carpout() added and minor corrections by Marc Hedlund
     <hedlund@best.com> on 11/26/95.

1.06 fatalsToBrowser() no longer aborts for fatal errors within
     eval() statements.

1.08 set_message() added and carpout() expanded to allow for FileHandle
     objects.

1.09 set_message() now allows users to pass a code REFERENCE for 
     really custom error messages.  croak and carp are now
     exported by default.  Thanks to Gunther Birznieks for the
     patches.

1.10 Patch from Chris Dean (ctdean@cogit.com) to allow 
     module to run correctly under mod_perl.

=head1 AUTHORS

Lincoln D. Stein <lstein@genome.wi.mit.edu>.  Feel free to redistribute
this under the Perl Artistic License.


=head1 SEE ALSO

Carp, CGI::Base, CGI::BasePlus, CGI::Request, CGI::MiniSvr, CGI::Form,
CGI::Response

=cut

require 5.000;
use Exporter;
use Carp;

@ISA = qw(Exporter);
@EXPORT = qw(confess croak carp);
@EXPORT_OK = qw(carpout fatalsToBrowser wrap set_message);

$main::SIG{__WARN__}=\&CGI::Carp::warn;
$main::SIG{__DIE__}=\&CGI::Carp::die;
$CGI::Carp::VERSION = '1.10';
$CGI::Carp::CUSTOM_MSG = undef;

# fancy import routine detects and handles 'errorWrap' specially.
sub import {
    my $pkg = shift;
    my(%routines);
    grep($routines{$_}++,@_,@EXPORT);
    $WRAP++ if $routines{'fatalsToBrowser'} || $routines{'wrap'};
    my($oldlevel) = $Exporter::ExportLevel;
    $Exporter::ExportLevel = 1;
    Exporter::import($pkg,keys %routines);
    $Exporter::ExportLevel = $oldlevel;
}

# These are the originals
sub realwarn { warn(@_); }
sub realdie { die(@_); }

sub id {
    my $level = shift;
    my($pack,$file,$line,$sub) = caller($level);
    my($id) = $file=~m|([^/]+)$|;
    return ($file,$line,$id);
}

sub stamp {
    my $time = scalar(localtime);
    my $frame = 0;
    my ($id,$pack,$file);
    do {
	$id = $file;
	($pack,$file) = caller($frame++);
    } until !$file;
    ($id) = $id=~m|([^/]+)$|;
    return "[$time] $id: ";
}

sub warn {
    my $message = shift;
    my($file,$line,$id) = id(1);
    $message .= " at $file line $line.\n" unless $message=~/\n$/;
    my $stamp = stamp;
    $message=~s/^/$stamp/gm;
    realwarn $message;
}

# 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\//);
    $message =~ s,eval[^\n]+Apache/Registry\.pm.*,,s if $mod_perl;
    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;
}

sub set_message {
    $CGI::Carp::CUSTOM_MSG = shift;
    return $CGI::Carp::CUSTOM_MSG;
}

# Avoid generating "subroutine redefined" warnings with the following
# hack:
{
    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 \@_; }
EOF
    ;
}

# 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));
    die "Invalid filehandle $in\n" unless defined $no;
    
    open(SAVEERR, ">&STDERR");
    open(STDERR, ">&$no") or 
	( print SAVEERR "Unable to redirect STDERR: $!\n" and exit(1) );
}

# headers
sub fatalsToBrowser {
    my($msg) = @_;
    $msg=~s/>/&gt;/g;
    $msg=~s/</&lt;/g;
    $msg=~s/&/&amp;/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
    ;
    print STDOUT "Content-type: text/html\n\n";

    if ($CUSTOM_MSG) {
	if (ref($CUSTOM_MSG) eq 'CODE') {
	    &$CUSTOM_MSG($msg); # nicer to perl 5.003 users
	    return;
	} else {
	    $outer_message = $CUSTOM_MSG;
	}
    }
    
    print STDOUT <<END;
<H1>Software error:</H1>
<CODE>$msg</CODE>
<P>
$outer_message;
END
    ;
}

# 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;
Commit	Line	Data
54310121	1	package CGI::Carp;
	2
	3	=head1 NAME
	4
	5	B<CGI::Carp> - CGI routines for writing to the HTTPD (or other) error log
	6
	7	=head1 SYNOPSIS
	8
	9	use CGI::Carp;
	10
	11	croak "We're outta here!";
	12	confess "It was my fault: $!";
	13	carp "It was your fault!";
	14	warn "I'm confused";
	15	die "I'm dying.\n";
	16
	17	=head1 DESCRIPTION
	18
	19	CGI scripts have a nasty habit of leaving warning messages in the error
	20	logs that are neither time stamped nor fully identified. Tracking down
	21	the script that caused the error is a pain. This fixes that. Replace
	22	the usual
	23
	24	use Carp;
	25
	26	with
	27
	28	use CGI::Carp
	29
	30	And the standard warn(), die (), croak(), confess() and carp() calls
	31	will automagically be replaced with functions that write out nicely
	32	time-stamped messages to the HTTP server error log.
	33
	34	For example:
	35
	36	[Fri Nov 17 21:40:43 1995] test.pl: I'm confused at test.pl line 3.
	37	[Fri Nov 17 21:40:43 1995] test.pl: Got an error message: Permission denied.
	38	[Fri Nov 17 21:40:43 1995] test.pl: I'm dying.
	39
	40	=head1 REDIRECTING ERROR MESSAGES
	41
	42	By default, error messages are sent to STDERR. Most HTTPD servers
	43	direct STDERR to the server's error log. Some applications may wish
	44	to keep private error logs, distinct from the server's error log, or
	45	they may wish to direct error messages to STDOUT so that the browser
	46	will receive them.
	47
	48	The C<carpout()> function is provided for this purpose. Since
	49	carpout() is not exported by default, you must import it explicitly by
	50	saying
	51
	52	use CGI::Carp qw(carpout);
	53
	54	The carpout() function requires one argument, which should be a
	55	reference to an open filehandle for writing errors. It should be
	56	called in a C<BEGIN> block at the top of the CGI application so that
	57	compiler errors will be caught. Example:
	58
	59	BEGIN {
	60	use CGI::Carp qw(carpout);
	61	open(LOG, ">>/usr/local/cgi-logs/mycgi-log") or
	62	die("Unable to open mycgi-log: $!\n");
	63	carpout(LOG);
	64	}
65
66	carpout() does not handle file locking on the log for you at this point.
67
68	The real STDERR is not closed -- it is moved to SAVEERR. Some
69	servers, when dealing with CGI scripts, close their connection to the
70	browser when the script closes STDOUT and STDERR. SAVEERR is used to
71	prevent this from happening prematurely.
72
73	You can pass filehandles to carpout() in a variety of ways. The "correct"
74	way according to Tom Christiansen is to pass a reference to a filehandle
75	GLOB:
76
77	carpout(\*LOG);
78
79	This looks weird to mere mortals however, so the following syntaxes are
80	accepted as well:
81
82	carpout(LOG);
83	carpout(main::LOG);
84	carpout(main'LOG);
85	carpout(\LOG);
86	carpout(\'main::LOG');
87
88	... and so on
89
424ec8fa	90	FileHandle and other objects work as well.
424ec8fa	91
54310121	92	Use of carpout() is not great for performance, so it is recommended
	93	for debugging purposes or for moderate-use applications. A future
	94	version of this module may delay redirecting STDERR until one of the
	95	CGI::Carp methods is called to prevent the performance hit.
	96
	97	=head1 MAKING PERL ERRORS APPEAR IN THE BROWSER WINDOW
	98
	99	If you want to send fatal (die, confess) errors to the browser, ask to
	100	import the special "fatalsToBrowser" subroutine:
	101
	102	use CGI::Carp qw(fatalsToBrowser);
	103	die "Bad error here";
	104
	105	Fatal errors will now be echoed to the browser as well as to the log. CGI::Carp
	106	arranges to send a minimal HTTP header to the browser so that even errors that
	107	occur in the early compile phase will be seen.
	108	Nonfatal errors will still be directed to the log file only (unless redirected
	109	with carpout).
	110
424ec8fa	111	=head2 Changing the default message
	112
	113	By default, the software error message is followed by a note to
	114	contact the Webmaster by e-mail with the time and date of the error.
	115	If this message is not to your liking, you can change it using the
	116	set_message() routine. This is not imported by default; you should
	117	import it on the use() line:
	118
	119	use CGI::Carp qw(fatalsToBrowser set_message);
	120	set_message("It's not a bug, it's a feature!");
	121
	122	You may also pass in a code reference in order to create a custom
	123	error message. At run time, your code will be called with the text
	124	of the error message that caused the script to die. Example:
	125
	126	use CGI::Carp qw(fatalsToBrowser set_message);
	127	BEGIN {
	128	sub handle_errors {
	129	my $msg = shift;
	130	print "<h1>Oh gosh</h1>";
	131	print "Got an error: $msg";
	132	}
	133	set_message(\&handle_errors);
	134	}
	135
	136	In order to correctly intercept compile-time errors, you should call
	137	set_message() from within a BEGIN{} block.
	138
54310121	139	=head1 CHANGE LOG
	140
	141	1.05 carpout() added and minor corrections by Marc Hedlund
	142	<hedlund@best.com> on 11/26/95.
	143
	144	1.06 fatalsToBrowser() no longer aborts for fatal errors within
	145	eval() statements.
	146
424ec8fa	147	1.08 set_message() added and carpout() expanded to allow for FileHandle
	148	objects.
	149
	150	1.09 set_message() now allows users to pass a code REFERENCE for
	151	really custom error messages. croak and carp are now
	152	exported by default. Thanks to Gunther Birznieks for the
	153	patches.
	154
	155	1.10 Patch from Chris Dean (ctdean@cogit.com) to allow
	156	module to run correctly under mod_perl.
	157
54310121	158	=head1 AUTHORS
	159
	160	Lincoln D. Stein <lstein@genome.wi.mit.edu>. Feel free to redistribute
	161	this under the Perl Artistic License.
	162
	163
	164	=head1 SEE ALSO
	165
	166	Carp, CGI::Base, CGI::BasePlus, CGI::Request, CGI::MiniSvr, CGI::Form,
	167	CGI::Response
	168
	169	=cut
	170
	171	require 5.000;
	172	use Exporter;
	173	use Carp;
	174
	175	@ISA = qw(Exporter);
	176	@EXPORT = qw(confess croak carp);
424ec8fa	177	@EXPORT_OK = qw(carpout fatalsToBrowser wrap set_message);
54310121	178
	179	$main::SIG{__WARN__}=\&CGI::Carp::warn;
	180	$main::SIG{__DIE__}=\&CGI::Carp::die;
424ec8fa	181	$CGI::Carp::VERSION = '1.10';
424ec8fa	182	$CGI::Carp::CUSTOM_MSG = undef;
54310121	183
	184	# fancy import routine detects and handles 'errorWrap' specially.
	185	sub import {
	186	my $pkg = shift;
	187	my(%routines);
424ec8fa	188	grep($routines{$_}++,@_,@EXPORT);
424ec8fa	189	$WRAP++ if $routines{'fatalsToBrowser'} \|\| $routines{'wrap'};
54310121	190	my($oldlevel) = $Exporter::ExportLevel;
	191	$Exporter::ExportLevel = 1;
	192	Exporter::import($pkg,keys %routines);
	193	$Exporter::ExportLevel = $oldlevel;
	194	}
	195
	196	# These are the originals
	197	sub realwarn { warn(@_); }
	198	sub realdie { die(@_); }
	199
	200	sub id {
	201	my $level = shift;
	202	my($pack,$file,$line,$sub) = caller($level);
	203	my($id) = $file=~m\|([^/]+)$\|;
	204	return ($file,$line,$id);
	205	}
	206
	207	sub stamp {
	208	my $time = scalar(localtime);
	209	my $frame = 0;
	210	my ($id,$pack,$file);
	211	do {
	212	$id = $file;
	213	($pack,$file) = caller($frame++);
	214	} until !$file;
	215	($id) = $id=~m\|([^/]+)$\|;
	216	return "[$time] $id: ";
	217	}
	218
	219	sub warn {
	220	my $message = shift;
	221	my($file,$line,$id) = id(1);
	222	$message .= " at $file line $line.\n" unless $message=~/\n$/;
	223	my $stamp = stamp;
	224	$message=~s/^/$stamp/gm;
	225	realwarn $message;
	226	}
	227
424ec8fa	228	# The mod_perl package Apache::Registry loads CGI programs by calling
	229	# eval. These evals don't count when looking at the stack backtrace.
	230	sub _longmess {
	231	my $message = Carp::longmess();
	232	my $mod_perl = ($ENV{'GATEWAY_INTERFACE'}
	233	&& $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl\//);
	234	$message =~ s,eval[^\n]+Apache/Registry\.pm.*,,s if $mod_perl;
	235	return( $message );
	236	}
	237
54310121	238	sub die {
	239	my $message = shift;
	240	my $time = scalar(localtime);
	241	my($file,$line,$id) = id(1);
54310121	242	$message .= " at $file line $line.\n" unless $message=~/\n$/;
424ec8fa	243	&fatalsToBrowser($message) if $WRAP && _longmess() !~ /eval [{\']/m;
54310121	244	my $stamp = stamp;
	245	$message=~s/^/$stamp/gm;
	246	realdie $message;
	247	}
	248
424ec8fa	249	sub set_message {
	250	$CGI::Carp::CUSTOM_MSG = shift;
	251	return $CGI::Carp::CUSTOM_MSG;
	252	}
	253
54310121	254	# Avoid generating "subroutine redefined" warnings with the following
	255	# hack:
	256	{
	257	local $^W=0;
	258	eval <<EOF;
	259	sub confess { CGI::Carp::die Carp::longmess \@_; }
	260	sub croak { CGI::Carp::die Carp::shortmess \@_; }
	261	sub carp { CGI::Carp::warn Carp::shortmess \@_; }
	262	EOF
	263	;
	264	}
	265
	266	# We have to be ready to accept a filehandle as a reference
	267	# or a string.
	268	sub carpout {
	269	my($in) = @_;
424ec8fa	270	my($no) = fileno(to_filehandle($in));
424ec8fa	271	die "Invalid filehandle $in\n" unless defined $no;
54310121	272
	273	open(SAVEERR, ">&STDERR");
	274	open(STDERR, ">&$no") or
	275	( print SAVEERR "Unable to redirect STDERR: $!\n" and exit(1) );
	276	}
	277
	278	# headers
	279	sub fatalsToBrowser {
	280	my($msg) = @_;
	281	$msg=~s/>/>/g;
	282	$msg=~s/</</g;
424ec8fa	283	$msg=~s/&/&/g;
	284	$msg=~s/\"/"/g;
	285	my($wm) = $ENV{SERVER_ADMIN} ?
	286	qq[the webmaster (<a href="mailto:$ENV{SERVER_ADMIN}">$ENV{SERVER_ADMIN}</a>)] :
	287	"this site's webmaster";
	288	my ($outer_message) = <<END;
	289	For help, please send mail to $wm, giving this error message
	290	and the time and date of the error.
	291	END
	292	;
54310121	293	print STDOUT "Content-type: text/html\n\n";
424ec8fa	294
	295	if ($CUSTOM_MSG) {
	296	if (ref($CUSTOM_MSG) eq 'CODE') {
	297	&$CUSTOM_MSG($msg); # nicer to perl 5.003 users
	298	return;
	299	} else {
	300	$outer_message = $CUSTOM_MSG;
	301	}
	302	}
	303
54310121	304	print STDOUT <<END;
	305	<H1>Software error:</H1>
	306	<CODE>$msg</CODE>
	307	<P>
424ec8fa	308	$outer_message;
54310121	309	END
424ec8fa	310	;
	311	}
	312
	313	# Cut and paste from CGI.pm so that we don't have the overhead of
	314	# always loading the entire CGI module.
	315	sub to_filehandle {
	316	my $thingy = shift;
	317	return undef unless $thingy;
	318	return $thingy if UNIVERSAL::isa($thingy,'GLOB');
	319	return $thingy if UNIVERSAL::isa($thingy,'FileHandle');
	320	if (!ref($thingy)) {
	321	my $caller = 1;
	322	while (my $package = caller($caller++)) {
	323	my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy";
	324	return $tmp if defined(fileno($tmp));
	325	}
	326	}
	327	return undef;
54310121	328	}
	329
	330	1;