File Coverage

blib/lib/CGI/Carp.pm

Criterion	Covered	Total	%
statement	107	144	74.3
branch	43	78	55.1
condition	7	20	35.0
subroutine	16	22	72.7
pod	0	16	0.0
total	173	280	61.8

line	stmt	bran	cond	sub	pod	time	code
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							use CGI::Carp qw(cluck);
18							cluck "I wouldn't do that if I were you";
19
20							use CGI::Carp qw(fatalsToBrowser);
21							die "Fatal error messages are now sent to browser";
22
23							=head1 DESCRIPTION
24
25							CGI scripts have a nasty habit of leaving warning messages in the error
26							logs that are neither time stamped nor fully identified. Tracking down
27							the script that caused the error is a pain. This fixes that. Replace
28							the usual
29
30							use Carp;
31
32							with
33
34							use CGI::Carp
35
36							And the standard warn(), die (), croak(), confess() and carp() calls
37							will automagically be replaced with functions that write out nicely
38							time-stamped messages to the HTTP server error log.
39
40							For example:
41
42							[Fri Nov 17 21:40:43 1995] test.pl: I'm confused at test.pl line 3.
43							[Fri Nov 17 21:40:43 1995] test.pl: Got an error message: Permission denied.
44							[Fri Nov 17 21:40:43 1995] test.pl: I'm dying.
45
46							=head1 REDIRECTING ERROR MESSAGES
47
48							By default, error messages are sent to STDERR. Most HTTPD servers
49							direct STDERR to the server's error log. Some applications may wish
50							to keep private error logs, distinct from the server's error log, or
51							they may wish to direct error messages to STDOUT so that the browser
52							will receive them.
53
54							The C<carpout()> function is provided for this purpose. Since
55							carpout() is not exported by default, you must import it explicitly by
56							saying
57
58							use CGI::Carp qw(carpout);
59
60							The carpout() function requires one argument, which should be a
61							reference to an open filehandle for writing errors. It should be
62							called in a C<BEGIN> block at the top of the CGI application so that
63							compiler errors will be caught. Example:
64
65							BEGIN {
66							use CGI::Carp qw(carpout);
67							open(LOG, ">>/usr/local/cgi-logs/mycgi-log") or
68							die("Unable to open mycgi-log: $!\n");
69							carpout(LOG);
70							}
71
72							carpout() does not handle file locking on the log for you at this point.
73
74							The real STDERR is not closed -- it is moved to CGI::Carp::SAVEERR. Some
75							servers, when dealing with CGI scripts, close their connection to the
76							browser when the script closes STDOUT and STDERR. CGI::Carp::SAVEERR is there to
77							prevent this from happening prematurely.
78
79							You can pass filehandles to carpout() in a variety of ways. The "correct"
80							way according to Tom Christiansen is to pass a reference to a filehandle
81							GLOB:
82
83							carpout(\*LOG);
84
85							This looks weird to mere mortals however, so the following syntaxes are
86							accepted as well:
87
88							carpout(LOG);
89							carpout(main::LOG);
90							carpout(main'LOG);
91							carpout(\LOG);
92							carpout(\'main::LOG');
93
94							... and so on
95
96							FileHandle and other objects work as well.
97
98							Use of carpout() is not great for performance, so it is recommended
99							for debugging purposes or for moderate-use applications. A future
100							version of this module may delay redirecting STDERR until one of the
101							CGI::Carp methods is called to prevent the performance hit.
102
103							=head1 MAKING PERL ERRORS APPEAR IN THE BROWSER WINDOW
104
105							If you want to send fatal (die, confess) errors to the browser, ask to
106							import the special "fatalsToBrowser" subroutine:
107
108							use CGI::Carp qw(fatalsToBrowser);
109							die "Bad error here";
110
111							Fatal errors will now be echoed to the browser as well as to the log. CGI::Carp
112							arranges to send a minimal HTTP header to the browser so that even errors that
113							occur in the early compile phase will be seen.
114							Nonfatal errors will still be directed to the log file only (unless redirected
115							with carpout).
116
117							Note that fatalsToBrowser does B<not> work with mod_perl version 2.0
118							and higher.
119
120							=head2 Changing the default message
121
122							By default, the software error message is followed by a note to
123							contact the Webmaster by e-mail with the time and date of the error.
124							If this message is not to your liking, you can change it using the
125							set_message() routine. This is not imported by default; you should
126							import it on the use() line:
127
128							use CGI::Carp qw(fatalsToBrowser set_message);
129							set_message("It's not a bug, it's a feature!");
130
131							You may also pass in a code reference in order to create a custom
132							error message. At run time, your code will be called with the text
133							of the error message that caused the script to die. Example:
134
135							use CGI::Carp qw(fatalsToBrowser set_message);
136							BEGIN {
137							sub handle_errors {
138							my $msg = shift;
139							print "<h1>Oh gosh</h1>";
140							print "<p>Got an error: $msg</p>";
141							}
142							set_message(\&handle_errors);
143							}
144
145							In order to correctly intercept compile-time errors, you should call
146							set_message() from within a BEGIN{} block.
147
148							=head1 DOING MORE THAN PRINTING A MESSAGE IN THE EVENT OF PERL ERRORS
149
150							If fatalsToBrowser in conjunction with set_message does not provide
151							you with all of the functionality you need, you can go one step
152							further by specifying a function to be executed any time a script
153							calls "die", has a syntax error, or dies unexpectedly at runtime
154							with a line like "undef->explode();".
155
156							use CGI::Carp qw(set_die_handler);
157							BEGIN {
158							sub handle_errors {
159							my $msg = shift;
160							print "content-type: text/html\n\n";
161							print "<h1>Oh gosh</h1>";
162							print "<p>Got an error: $msg</p>";
163
164							#proceed to send an email to a system administrator,
165							#write a detailed message to the browser and/or a log,
166							#etc....
167							}
168							set_die_handler(\&handle_errors);
169							}
170
171							Notice that if you use set_die_handler(), you must handle sending
172							HTML headers to the browser yourself if you are printing a message.
173
174							If you use set_die_handler(), you will most likely interfere with
175							the behavior of fatalsToBrowser, so you must use this or that, not
176							both.
177
178							Using set_die_handler() sets SIG{__DIE__} (as does fatalsToBrowser),
179							and there is only one SIG{__DIE__}. This means that if you are
180							attempting to set SIG{__DIE__} yourself, you may interfere with
181							this module's functionality, or this module may interfere with
182							your module's functionality.
183
184							=head1 MAKING WARNINGS APPEAR AS HTML COMMENTS
185
186							It is now also possible to make non-fatal errors appear as HTML
187							comments embedded in the output of your program. To enable this
188							feature, export the new "warningsToBrowser" subroutine. Since sending
189							warnings to the browser before the HTTP headers have been sent would
190							cause an error, any warnings are stored in an internal buffer until
191							you call the warningsToBrowser() subroutine with a true argument:
192
193							use CGI::Carp qw(fatalsToBrowser warningsToBrowser);
194							use CGI qw(:standard);
195							print header();
196							warningsToBrowser(1);
197
198							You may also give a false argument to warningsToBrowser() to prevent
199							warnings from being sent to the browser while you are printing some
200							content where HTML comments are not allowed:
201
202							warningsToBrowser(0); # disable warnings
203							print "<script type=\"text/javascript\"><!--\n";
204							print_some_javascript_code();
205							print "//--></script>\n";
206							warningsToBrowser(1); # re-enable warnings
207
208							Note: In this respect warningsToBrowser() differs fundamentally from
209							fatalsToBrowser(), which you should never call yourself!
210
211							=head1 OVERRIDING THE NAME OF THE PROGRAM
212
213							CGI::Carp includes the name of the program that generated the error or
214							warning in the messages written to the log and the browser window.
215							Sometimes, Perl can get confused about what the actual name of the
216							executed program was. In these cases, you can override the program
217							name that CGI::Carp will use for all messages.
218
219							The quick way to do that is to tell CGI::Carp the name of the program
220							in its use statement. You can do that by adding
221							"name=cgi_carp_log_name" to your "use" statement. For example:
222
223							use CGI::Carp qw(name=cgi_carp_log_name);
224
225							. If you want to change the program name partway through the program,
226							you can use the C<set_progname()> function instead. It is not
227							exported by default, you must import it explicitly by saying
228
229							use CGI::Carp qw(set_progname);
230
231							Once you've done that, you can change the logged name of the program
232							at any time by calling
233
234							set_progname(new_program_name);
235
236							You can set the program back to the default by calling
237
238							set_progname(undef);
239
240							Note that this override doesn't happen until after the program has
241							compiled, so any compile-time errors will still show up with the
242							non-overridden program name
243
244							=head1 CHANGE LOG
245
246							1.29 Patch from Peter Whaite to fix the unfixable problem of CGI::Carp
247							not behaving correctly in an eval() context.
248
249							1.05 carpout() added and minor corrections by Marc Hedlund
250							<hedlund@best.com> on 11/26/95.
251
252							1.06 fatalsToBrowser() no longer aborts for fatal errors within
253							eval() statements.
254
255							1.08 set_message() added and carpout() expanded to allow for FileHandle
256							objects.
257
258							1.09 set_message() now allows users to pass a code REFERENCE for
259							really custom error messages. croak and carp are now
260							exported by default. Thanks to Gunther Birznieks for the
261							patches.
262
263							1.10 Patch from Chris Dean (ctdean@cogit.com) to allow
264							module to run correctly under mod_perl.
265
266							1.11 Changed order of > and < escapes.
267
268							1.12 Changed die() on line 217 to CORE::die to avoid B<-w> warning.
269
270							1.13 Added cluck() to make the module orthogonal with Carp.
271							More mod_perl related fixes.
272
273							1.20 Patch from Ilmari Karonen (perl@itz.pp.sci.fi): Added
274							warningsToBrowser(). Replaced <CODE> tags with <PRE> in
275							fatalsToBrowser() output.
276
277							1.23 ineval() now checks both $^S and inspects the message for the "eval" pattern
278							(hack alert!) in order to accomodate various combinations of Perl and
279							mod_perl.
280
281							1.24 Patch from Scott Gifford (sgifford@suspectclass.com): Add support
282							for overriding program name.
283
284							1.26 Replaced CORE::GLOBAL::die with the evil $SIG{__DIE__} because the
285							former isn't working in some people's hands. There is no such thing
286							as reliable exception handling in Perl.
287
288							1.27 Replaced tell STDOUT with bytes=tell STDOUT.
289
290							=head1 AUTHORS
291
292							Copyright 1995-2002, Lincoln D. Stein. All rights reserved.
293
294							This library is free software; you can redistribute it and/or modify
295							it under the same terms as Perl itself.
296
297							Address bug reports and comments to: lstein@cshl.org
298
299							=head1 SEE ALSO
300
301							Carp, CGI::Base, CGI::BasePlus, CGI::Request, CGI::MiniSvr, CGI::Form,
302							CGI::Response
303							if (defined($CGI::Carp::PROGNAME))
304							{
305							$file = $CGI::Carp::PROGNAME;
306							}
307
308							=cut
309
310							require 5.000;
311	1			1		12	use Exporter;
	1					10
	1					15
312							#use Carp;
313							BEGIN {
314	1			1		20	require Carp;
315	1					21	*CORE::GLOBAL::die = \&CGI::Carp::die;
316							}
317
318	1			1		15	use File::Spec;
	1					10
	1					24
319
320							@ISA = qw(Exporter);
321							@EXPORT = qw(confess croak carp);
322							@EXPORT_OK = qw(carpout fatalsToBrowser warningsToBrowser wrap set_message set_die_handler set_progname cluck ^name= die);
323
324							$main::SIG{__WARN__}=\&CGI::Carp::warn;
325
326							$CGI::Carp::VERSION = '1.29';
327							$CGI::Carp::CUSTOM_MSG = undef;
328							$CGI::Carp::DIE_HANDLER = undef;
329
330
331							# fancy import routine detects and handles 'errorWrap' specially.
332							sub import {
333	2			2		22	my $pkg = shift;
334	2					18	my(%routines);
335	2					16	my(@name);
336	2	100				29	if (@name=grep(/^name=/,@_))
337							{
338	1					14	my($n) = (split(/=/,$name[0]))[1];
339	1					13	set_progname($n);
340	1					11	@_=grep(!/^name=/,@_);
341							}
342
343	2					30	grep($routines{$_}++,@_,@EXPORT);
344	2	50	33			42	$WRAP++ if $routines{'fatalsToBrowser'} \|\| $routines{'wrap'};
345	2	50				24	$WARN++ if $routines{'warningsToBrowser'};
346	2					18	my($oldlevel) = $Exporter::ExportLevel;
347	2					17	$Exporter::ExportLevel = 1;
348	2					33	Exporter::import($pkg,keys %routines);
349	2					139	$Exporter::ExportLevel = $oldlevel;
350	2	50				42	$main::SIG{__DIE__} =\&CGI::Carp::die if $routines{'fatalsToBrowser'};
351							# $pkg->export('CORE::GLOBAL','die');
352							}
353
354							# These are the originals
355							sub realwarn { CORE::warn(@_); }
356							sub realdie { CORE::die(@_); }
357
358							sub id {
359	19			19	0	213	my $level = shift;
360	19					395	my($pack,$file,$line,$sub) = caller($level);
361	19					292	my($dev,$dirs,$id) = File::Spec->splitpath($file);
362	19					846	return ($file,$line,$id);
363							}
364
365							sub stamp {
366	17			17	0	841	my $time = scalar(localtime);
367	17					156	my $frame = 0;
368	17					429	my ($id,$pack,$file,$dev,$dirs);
369	17	50				275	if (defined($CGI::Carp::PROGNAME)) {
370	0					0	$id = $CGI::Carp::PROGNAME;
371							} else {
372	17					153	do {
373	62					494	$id = $file;
374	62					1146	($pack,$file) = caller($frame++);
375							} until !$file;
376							}
377	17					201	($dev,$dirs,$id) = File::Spec->splitpath($id);
378	17					757	return "[$time] $id: ";
379							}
380
381							sub set_progname {
382	3			3	0	62	$CGI::Carp::PROGNAME = shift;
383	3					34	return $CGI::Carp::PROGNAME;
384							}
385
386
387							sub warn {
388	14			14	0	129	my $message = shift;
389	14					128	my($file,$line,$id) = id(1);
390	14	100				188	$message .= " at $file line $line.\n" unless $message=~/\n$/;
391	14	100				142	_warn($message) if $WARN;
392	14					257	my $stamp = stamp;
393	14					278	$message=~s/^/$stamp/gm;
394	14					145	realwarn $message;
395							}
396
397							sub _warn {
398	12			12		104	my $msg = shift;
399	12	100				113	if ($EMIT_WARNINGS) {
400							# We need to mangle the message a bit to make it a valid HTML
401							# comment. This is done by substituting similar-looking ISO
402							# 8859-1 characters for <, > and -. This is a hack.
403	11					141	$msg =~ tr/<>-/\253\273\255/;
404	11					97	chomp $msg;
405	11					119	print STDOUT "<!-- warning: $msg -->\n";
406							} else {
407	1					12	push @WARNINGS, $msg;
408							}
409							}
410
411
412							# The mod_perl package Apache::Registry loads CGI programs by calling
413							# eval. These evals don't count when looking at the stack backtrace.
414							sub _longmess {
415	2			2		24	my $message = Carp::longmess();
416	2	50				23	$message =~ s,eval[^\n]+(ModPerl\|Apache)/(?:Registry\|Dispatch)\w\.pm.,,s
417							if exists $ENV{MOD_PERL};
418	2					37	return $message;
419							}
420
421							sub ineval {
422	4	50		4	0	69	(exists $ENV{MOD_PERL} ? 0 : $^S) \|\| _longmess() =~ /eval [\{\']/m
		100
423