File Coverage

blib/lib/CGI/Carp.pm
Criterion Covered Total %
statement 144 148 97.3
branch 69 90 76.6
condition 15 30 50.0
subroutine 25 25 100.0
pod 0 15 0.0
total 253 308 82.1


line stmt bran cond sub pod time code
1             package CGI::Carp;
2 2     2   190006 use if $] >= 5.019, 'deprecate';
  2         55  
  2         17  
3              
4             my $appease_cpants_kwalitee = q/
5             use strict;
6             use warnings;
7             #/;
8              
9             =head1 NAME
10              
11             B - CGI routines for writing to the HTTPD (or other) error log
12              
13             =head1 SYNOPSIS
14              
15             use CGI::Carp;
16              
17             croak "We're outta here!";
18             confess "It was my fault: $!";
19             carp "It was your fault!";
20             warn "I'm confused";
21             die "I'm dying.\n";
22              
23             use CGI::Carp qw(cluck);
24             cluck "I wouldn't do that if I were you";
25              
26             use CGI::Carp qw(fatalsToBrowser);
27             die "Fatal error messages are now sent to browser";
28              
29             =head1 DESCRIPTION
30              
31             CGI scripts have a nasty habit of leaving warning messages in the error
32             logs that are neither time stamped nor fully identified. Tracking down
33             the script that caused the error is a pain. This fixes that. Replace
34             the usual
35              
36             use Carp;
37              
38             with
39              
40             use CGI::Carp
41              
42             The standard warn(), die (), croak(), confess() and carp() calls will
43             be replaced with functions that write time-stamped messages to the
44             HTTP server error log.
45              
46             For example:
47              
48             [Fri Nov 17 21:40:43 1995] test.pl: I'm confused at test.pl line 3.
49             [Fri Nov 17 21:40:43 1995] test.pl: Got an error message: Permission denied.
50             [Fri Nov 17 21:40:43 1995] test.pl: I'm dying.
51              
52             =head1 REDIRECTING ERROR MESSAGES
53              
54             By default, error messages are sent to STDERR. Most HTTPD servers
55             direct STDERR to the server's error log. Some applications may wish
56             to keep private error logs, distinct from the server's error log, or
57             they may wish to direct error messages to STDOUT so that the browser
58             will receive them.
59              
60             The C function is provided for this purpose. Since
61             carpout() is not exported by default, you must import it explicitly by
62             saying
63              
64             use CGI::Carp qw(carpout);
65              
66             The carpout() function requires one argument, a reference to an open
67             filehandle for writing errors. It should be called in a C
68             block at the top of the CGI application so that compiler errors will
69             be caught. Example:
70              
71             BEGIN {
72             use CGI::Carp qw(carpout);
73             open(LOG, ">>/usr/local/cgi-logs/mycgi-log") or
74             die("Unable to open mycgi-log: $!\n");
75             carpout(LOG);
76             }
77              
78             carpout() does not handle file locking on the log for you at this
79             point. Also, note that carpout() does not work with in-memory file
80             handles, although a patch would be welcome to address that.
81              
82             The real STDERR is not closed -- it is moved to CGI::Carp::SAVEERR.
83             Some servers, when dealing with CGI scripts, close their connection to
84             the browser when the script closes STDOUT and STDERR.
85             CGI::Carp::SAVEERR is there to prevent this from happening
86             prematurely.
87              
88             You can pass filehandles to carpout() in a variety of ways. The "correct"
89             way according to Tom Christiansen is to pass a reference to a filehandle
90             GLOB:
91              
92             carpout(\*LOG);
93              
94             This looks weird to mere mortals however, so the following syntaxes are
95             accepted as well:
96              
97             carpout(LOG);
98             carpout(main::LOG);
99             carpout(main'LOG);
100             carpout(\LOG);
101             carpout(\'main::LOG');
102              
103             ... and so on
104              
105             FileHandle and other objects work as well.
106              
107             Use of carpout() is not great for performance, so it is recommended
108             for debugging purposes or for moderate-use applications. A future
109             version of this module may delay redirecting STDERR until one of the
110             CGI::Carp methods is called to prevent the performance hit.
111              
112             =head1 MAKING PERL ERRORS APPEAR IN THE BROWSER WINDOW
113              
114             If you want to send fatal (die, confess) errors to the browser, import
115             the special "fatalsToBrowser" subroutine:
116              
117             use CGI::Carp qw(fatalsToBrowser);
118             die "Bad error here";
119              
120             Fatal errors will now be echoed to the browser as well as to the log.
121             CGI::Carp arranges to send a minimal HTTP header to the browser so
122             that even errors that occur in the early compile phase will be seen.
123             Nonfatal errors will still be directed to the log file only (unless
124             redirected with carpout).
125              
126             Note that fatalsToBrowser may B work well with mod_perl version 2.0
127             and higher.
128              
129             =head2 Changing the default message
130              
131             By default, the software error message is followed by a note to
132             contact the Webmaster by e-mail with the time and date of the error.
133             If this message is not to your liking, you can change it using the
134             set_message() routine. This is not imported by default; you should
135             import it on the use() line:
136              
137             use CGI::Carp qw(fatalsToBrowser set_message);
138             set_message("It's not a bug, it's a feature!");
139              
140             You may also pass in a code reference in order to create a custom
141             error message. At run time, your code will be called with the text
142             of the error message that caused the script to die. Example:
143              
144             use CGI::Carp qw(fatalsToBrowser set_message);
145             BEGIN {
146             sub handle_errors {
147             my $msg = shift;
148             print "

Oh gosh

";
149             print "

Got an error: $msg

";
150             }
151             set_message(\&handle_errors);
152             }
153              
154             In order to correctly intercept compile-time errors, you should call
155             set_message() from within a BEGIN{} block.
156              
157             =head1 DOING MORE THAN PRINTING A MESSAGE IN THE EVENT OF PERL ERRORS
158              
159             If fatalsToBrowser in conjunction with set_message does not provide
160             you with all of the functionality you need, you can go one step
161             further by specifying a function to be executed any time a script
162             calls "die", has a syntax error, or dies unexpectedly at runtime
163             with a line like "undef->explode();".
164              
165             use CGI::Carp qw(set_die_handler);
166             BEGIN {
167             sub handle_errors {
168             my $msg = shift;
169             print "content-type: text/html\n\n";
170             print "

Oh gosh

";
171             print "

Got an error: $msg

";
172              
173             #proceed to send an email to a system administrator,
174             #write a detailed message to the browser and/or a log,
175             #etc....
176             }
177             set_die_handler(\&handle_errors);
178             }
179              
180             Notice that if you use set_die_handler(), you must handle sending
181             HTML headers to the browser yourself if you are printing a message.
182              
183             If you use set_die_handler(), you will most likely interfere with
184             the behavior of fatalsToBrowser, so you must use this or that, not
185             both.
186              
187             Using set_die_handler() sets SIG{__DIE__} (as does fatalsToBrowser),
188             and there is only one SIG{__DIE__}. This means that if you are
189             attempting to set SIG{__DIE__} yourself, you may interfere with
190             this module's functionality, or this module may interfere with
191             your module's functionality.
192              
193             =head1 SUPPRESSING PERL ERRORS APPEARING IN THE BROWSER WINDOW
194              
195             A problem sometimes encountered when using fatalsToBrowser is
196             when a C is done inside an C body or expression.
197             Even though the
198             fatalsToBrower support takes precautions to avoid this,
199             you still may get the error message printed to STDOUT.
200             This may have some undesirable effects when the purpose of doing the
201             eval is to determine which of several algorithms is to be used.
202              
203             By setting C<$CGI::Carp::TO_BROWSER> to 0 you can suppress printing
204             the C messages but without all of the complexity of using
205             C. You can localize this effect to inside C
206             bodies if this is desirable: For example:
207              
208             eval {
209             local $CGI::Carp::TO_BROWSER = 0;
210             die "Fatal error messages not sent browser"
211             }
212             # $@ will contain error message
213              
214              
215             =head1 MAKING WARNINGS APPEAR AS HTML COMMENTS
216              
217             It is also possible to make non-fatal errors appear as HTML comments
218             embedded in the output of your program. To enable this feature,
219             export the new "warningsToBrowser" subroutine. Since sending warnings
220             to the browser before the HTTP headers have been sent would cause an
221             error, any warnings are stored in an internal buffer until you call
222             the warningsToBrowser() subroutine with a true argument:
223              
224             use CGI::Carp qw(fatalsToBrowser warningsToBrowser);
225             use CGI qw(:standard);
226             print header();
227             warningsToBrowser(1);
228              
229             You may also give a false argument to warningsToBrowser() to prevent
230             warnings from being sent to the browser while you are printing some
231             content where HTML comments are not allowed:
232              
233             warningsToBrowser(0); # disable warnings
234             print "\n";
237             warningsToBrowser(1); # re-enable warnings
238              
239             Note: In this respect warningsToBrowser() differs fundamentally from
240             fatalsToBrowser(), which you should never call yourself!
241              
242             =head1 OVERRIDING THE NAME OF THE PROGRAM
243              
244             CGI::Carp includes the name of the program that generated the error or
245             warning in the messages written to the log and the browser window.
246             Sometimes, Perl can get confused about what the actual name of the
247             executed program was. In these cases, you can override the program
248             name that CGI::Carp will use for all messages.
249              
250             The quick way to do that is to tell CGI::Carp the name of the program
251             in its use statement. You can do that by adding
252             "name=cgi_carp_log_name" to your "use" statement. For example:
253              
254             use CGI::Carp qw(name=cgi_carp_log_name);
255              
256             . If you want to change the program name partway through the program,
257             you can use the C function instead. It is not
258             exported by default, you must import it explicitly by saying
259              
260             use CGI::Carp qw(set_progname);
261              
262             Once you've done that, you can change the logged name of the program
263             at any time by calling
264              
265             set_progname(new_program_name);
266              
267             You can set the program back to the default by calling
268              
269             set_progname(undef);
270              
271             Note that this override doesn't happen until after the program has
272             compiled, so any compile-time errors will still show up with the
273             non-overridden program name
274              
275             =head1 TURNING OFF TIMESTAMPS IN MESSAGES
276              
277             If your web server automatically adds a timestamp to each log line,
278             you may not need CGI::Carp to add its own. You can disable timestamping
279             by importing "noTimestamp":
280              
281             use CGI::Carp qw(noTimestamp);
282              
283             Alternatively you can set C<$CGI::Carp::NO_TIMESTAMP> to 1.
284              
285             Note that the name of the program is still automatically included in
286             the message.
287              
288             =head1 GETTING THE FULL PATH OF THE SCRIPT IN MESSAGES
289              
290             Set C<$CGI::Carp::FULL_PATH> to 1.
291              
292             =head1 AUTHOR INFORMATION
293              
294             The CGI.pm distribution is copyright 1995-2007, Lincoln D. Stein. It is
295             distributed under GPL and the Artistic License 2.0. It is currently
296             maintained by Lee Johnson with help from many contributors.
297              
298             Address bug reports and comments to: https://github.com/leejo/CGI.pm/issues
299              
300             The original bug tracker can be found at: https://rt.cpan.org/Public/Dist/Display.html?Queue=CGI.pm
301              
302             When sending bug reports, please provide the version of CGI.pm, the version of
303             Perl, the name and version of your Web server, and the name and version of the
304             operating system you are using. If the problem is even remotely browser
305             dependent, please provide information about the affected browsers as well.
306              
307             =head1 SEE ALSO
308              
309             L, L, L, L,
310             L, L, L.
311              
312             =cut
313              
314             require 5.000;
315 2     2   2779 use Exporter;
  2         6  
  2         161  
316             #use Carp;
317             BEGIN {
318 2     2   145 require Carp;
319 2         65 *CORE::GLOBAL::die = \&CGI::Carp::die;
320             }
321              
322 2     2   15 use File::Spec;
  2         6  
  2         7727  
323              
324             @ISA = qw(Exporter);
325             @EXPORT = qw(confess croak carp);
326             @EXPORT_OK = qw(carpout fatalsToBrowser warningsToBrowser wrap noTimestamp set_message set_die_handler set_progname cluck ^name= die);
327              
328             $main::SIG{__WARN__}=\&CGI::Carp::warn;
329              
330             $CGI::Carp::VERSION = '4.37';
331             $CGI::Carp::CUSTOM_MSG = undef;
332             $CGI::Carp::DIE_HANDLER = undef;
333             $CGI::Carp::TO_BROWSER = 1;
334             $CGI::Carp::NO_TIMESTAMP= 0;
335             $CGI::Carp::FULL_PATH = 0;
336              
337             # fancy import routine detects and handles 'errorWrap' specially.
338             sub import {
339 4     4   1061 my $pkg = shift;
340 4         13 my(%routines);
341             my(@name);
342 4 100       38 if (@name=grep(/^name=/,@_))
343             {
344 1         9 my($n) = (split(/=/,$name[0]))[1];
345 1         8 set_progname($n);
346 1         8 @_=grep(!/^name=/,@_);
347             }
348              
349 4         37 grep($routines{$_}++,@_,@EXPORT);
350 4 50 33     47 $WRAP++ if $routines{'fatalsToBrowser'} || $routines{'wrap'};
351 4 50       19 $WARN++ if $routines{'warningsToBrowser'};
352 4         13 my($oldlevel) = $Exporter::ExportLevel;
353 4         11 $Exporter::ExportLevel = 1;
354 4         346 Exporter::import($pkg,keys %routines);
355 4         17 $Exporter::ExportLevel = $oldlevel;
356 4 50       19 $main::SIG{__DIE__} =\&CGI::Carp::die if $routines{'fatalsToBrowser'};
357 4 100       2103 $CGI::Carp::NO_TIMESTAMP = 1 if $routines{'noTimestamp'};
358             }
359              
360             # These are the originals
361 2     2 0 1039 sub realwarn { CORE::warn(@_); }
362 12     12   81 sub realdie { CORE::die(@_); }
363              
364             sub id {
365 30     30 0 5916 my $level = shift;
366 30         220 my($pack,$file,$line,$sub) = caller($level);
367 30         481 my($dev,$dirs,$id) = File::Spec->splitpath($file);
368 30         134 return ($file,$line,$id);
369             }
370              
371             sub stamp {
372 18     18 0 2402 my $frame = 0;
373 18         39 my ($id,$pack,$file,$dev,$dirs);
374 18 50       44 if (defined($CGI::Carp::PROGNAME)) {
375 0         0 $id = $CGI::Carp::PROGNAME;
376             } else {
377 18         31 do {
378 56         106 $id = $file;
379 56         284 ($pack,$file) = caller($frame++);
380             } until !$file;
381             }
382 18 100       48 if (! $CGI::Carp::FULL_PATH) {
383 17         195 ($dev,$dirs,$id) = File::Spec->splitpath($id);
384             }
385 18 100       65 return "$id: " if $CGI::Carp::NO_TIMESTAMP;
386 16         389 my $time = scalar(localtime);
387 16         111 return "[$time] $id: ";
388             }
389              
390             sub set_progname {
391 3     3 0 12 $CGI::Carp::PROGNAME = shift;
392 3         14 return $CGI::Carp::PROGNAME;
393             }
394              
395              
396             sub warn {
397 6     6   2753 my $message = shift;
398 6         21 my($file,$line,$id) = id(1);
399 6 100       48 $message .= " at $file line $line.\n" unless $message=~/\n$/;
400 6 100       26 _warn($message) if $WARN;
401 6         18 my $stamp = stamp;
402 6         50 $message=~s/^/$stamp/gm;
403 6         131 realwarn $message;
404             }
405              
406             sub _warn {
407 6     6   25 my $msg = shift;
408 6 100       19 if ($EMIT_WARNINGS) {
409             # We need to mangle the message a bit to make it a valid HTML
410             # comment. This is done by substituting similar-looking ISO
411             # 8859-1 characters for <, > and -. This is a hack.
412 3         5 $msg =~ tr/<>-/\253\273\255/;
413 3         5 chomp $msg;
414 3         13 print STDOUT "\n";
415             } else {
416 3         11 push @WARNINGS, $msg;
417             }
418             }
419              
420              
421             # The mod_perl package Apache::Registry loads CGI programs by calling
422             # eval. These evals don't count when looking at the stack backtrace.
423             sub _longmess {
424 10     10   1203 my $message = Carp::longmess();
425             $message =~ s,eval[^\n]+(ModPerl|Apache)/(?:Registry|Dispatch)\w*\.pm.*,,s
426 10 50       145 if exists $ENV{MOD_PERL};
427 10         61 return $message;
428             }
429              
430             sub ineval {
431 23 50   23 0 1005 (exists $ENV{MOD_PERL} ? 0 : $^S) || _longmess() =~ /eval [\{\']/m
    100          
432             }
433              
434             sub die {
435             # if no argument is passed, propagate $@ like
436             # the real die
437 21 100   21   14487 my ($arg,@rest) = @_ ? @_
    100          
438             : $@ ? "$@\t...propagated"
439             : "Died"
440             ;
441              
442 21 50       84 &$DIE_HANDLER($arg,@rest) if $DIE_HANDLER;
443              
444             # the "$arg" is done on purpose!
445             # if called as die( $object, 'string' ),
446             # all is stringified, just like with
447             # the real 'die'
448 21 100       97 $arg = join '' => "$arg", @rest if @rest;
449              
450 21         62 my($file,$line,$id) = id(1);
451              
452 21 100 66     129 $arg .= " at $file line $line.\n" unless ref $arg or $arg=~/\n$/;
453              
454 21 100       54 realdie $arg if ineval();
455 9 50 66     44 &fatalsToBrowser($arg) if ($WRAP and $CGI::Carp::TO_BROWSER);
456              
457 9 50 66     67 $arg=~s/^/ stamp() /gme if $arg =~ /\n$/ or not exists $ENV{MOD_PERL};
  9         29  
458              
459 9 100       34 $arg .= "\n" unless $arg =~ /\n$/;
460              
461 9         23 realdie $arg;
462             }
463              
464             sub set_message {
465 5     5 0 927 $CGI::Carp::CUSTOM_MSG = shift;
466 5         25 return $CGI::Carp::CUSTOM_MSG;
467             }
468              
469             sub set_die_handler {
470              
471 1     1 0 805 my ($handler) = shift;
472            
473             #setting SIG{__DIE__} here is necessary to catch runtime
474             #errors which are not called by literally saying "die",
475             #such as the line "undef->explode();". however, doing this
476             #will interfere with fatalsToBrowser, which also sets
477             #SIG{__DIE__} in the import() function above (or the
478             #import() function above may interfere with this). for
479             #this reason, you should choose to either set the die
480             #handler here, or use fatalsToBrowser, not both.
481 1         7 $main::SIG{__DIE__} = $handler;
482            
483 1         3 $CGI::Carp::DIE_HANDLER = $handler;
484            
485 1         4 return $CGI::Carp::DIE_HANDLER;
486             }
487              
488 1     1 0 108 sub confess { CGI::Carp::die Carp::longmess @_; }
489 1     1 0 719 sub croak { CGI::Carp::die Carp::shortmess @_; }
490 1     1 0 679 sub carp { CGI::Carp::warn Carp::shortmess @_; }
491 1     1 0 414 sub cluck { CGI::Carp::warn Carp::longmess @_; }
492              
493             # We have to be ready to accept a filehandle as a reference
494             # or a string.
495             sub carpout {
496 1     1 0 1092 my($in) = @_;
497 1         4 my($no) = fileno(to_filehandle($in));
498 1 50       4 realdie("Invalid filehandle $in\n") unless defined $no;
499            
500 1         12 open(SAVEERR, ">&STDERR");
501 1 50 0     20 open(STDERR, ">&$no") or
502             ( print SAVEERR "Unable to redirect >&$no: $!\n" and exit(1) );
503             }
504              
505             sub warningsToBrowser {
506 16 50   16 0 33 $EMIT_WARNINGS = @_ ? shift : 1;
507 16   100     74 _warn(shift @WARNINGS) while $EMIT_WARNINGS and @WARNINGS;
508             }
509              
510             # headers
511             sub fatalsToBrowser {
512 15     15 0 63 my $msg = shift;
513              
514 15 100       39 $msg = "$msg" if ref $msg;
515              
516 15         30 $msg=~s/&/&/g;
517 15         21 $msg=~s/>/>/g;
518 15         20 $msg=~s/
519 15         21 $msg=~s/"/"/g;
520              
521             my($wm) = $ENV{SERVER_ADMIN} ?
522 15 100       43 qq[the webmaster ($ENV{SERVER_ADMIN})] :
523             "this site's webmaster";
524 15         33 my ($outer_message) = <
525             For help, please send mail to $wm, giving this error message
526             and the time and date of the error.
527             END
528             ;
529 15         28 my $mod_perl = exists $ENV{MOD_PERL};
530              
531 15 100       29 if ($CUSTOM_MSG) {
532 2 100       5 if (ref($CUSTOM_MSG) eq 'CODE') {
533 1 50       3 print STDOUT "Content-type: text/html\n\n"
534             unless $mod_perl;
535 1         5 eval {
536 1         3 &$CUSTOM_MSG($msg); # nicer to perl 5.003 users
537             };
538 1 50       13 if ($@) { print STDERR qq(error while executing the error handler: $@); }
  0         0  
539              
540 1         3 return;
541             } else {
542 1         2 $outer_message = $CUSTOM_MSG;
543             }
544             }
545              
546 14         33 my $mess = <
547            

Software error:

548            
$msg
549            

550             $outer_message
551            

552             END
553             ;
554              
555 14 100       21 if ($mod_perl) {
556 2         6 my $r;
557 2 100 66     16 if ($ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) {
558 1         3 $mod_perl = 2;
559 1         280 require Apache2::RequestRec;
560 1         175 require Apache2::RequestIO;
561 1         229 require Apache2::RequestUtil;
562 1         168 require APR::Pool;
563 1         178 require ModPerl::Util;
564 1         164 require Apache2::Response;
565 1         13 $r = Apache2::RequestUtil->request;
566             }
567             else {
568 1         5 $r = Apache->request;
569             }
570             # If bytes have already been sent, then
571             # we print the message out directly.
572             # Otherwise we make a custom error
573             # handler to produce the doc for us.
574 2 100       10 if ($r->bytes_sent) {
575 1         6 $r->print($mess);
576 1 50       11 $mod_perl == 2 ? ModPerl::Util::exit(0) : $r->exit;
577             } else {
578             # MSIE won't display a custom 500 response unless it is >512 bytes!
579 1 50 33     10 if (defined($ENV{HTTP_USER_AGENT}) && $ENV{HTTP_USER_AGENT} =~ /MSIE/) {
580 1         4 $mess = "\n$mess";
581             }
582 1         3 $r->custom_response(500,$mess);
583             }
584             } else {
585 12         17 my $bytes_written = eval{tell STDOUT};
  12         91  
586 12 50 33     37 if (defined $bytes_written && $bytes_written > 0) {
587 0         0 print STDOUT $mess;
588             }
589             else {
590 12         30 print STDOUT "Status: 500\n";
591 12         58 print STDOUT "Content-type: text/html\n\n";
592             # MSIE won't display a custom 500 response unless it is >512 bytes!
593 12 50 33     54 if (defined($ENV{HTTP_USER_AGENT}) && $ENV{HTTP_USER_AGENT} =~ /MSIE/) {
594 0         0 $mess = "\n$mess";
595             }
596 12         22 print STDOUT $mess;
597             }
598             }
599              
600 14         72 warningsToBrowser(1); # emit warnings before dying
601             }
602              
603             # Cut and paste from CGI.pm so that we don't have the overhead of
604             # always loading the entire CGI module.
605             sub to_filehandle {
606 6     6 0 5947 my $thingy = shift;
607 6 50       30 return undef unless $thingy;
608 6 100       54 return $thingy if UNIVERSAL::isa($thingy,'GLOB');
609 3 50       16 return $thingy if UNIVERSAL::isa($thingy,'FileHandle');
610 3 50       10 if (!ref($thingy)) {
611 3         7 my $caller = 1;
612 3         15 while (my $package = caller($caller++)) {
613 3 100       26 my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy";
614 3 100       36 return $tmp if defined(fileno($tmp));
615             }
616             }
617 1         8 return undef;
618             }
619              
620             1;