| 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 | =head2 Changing the default message |
| 118 | |
| 119 | By default, the software error message is followed by a note to |
| 120 | contact the Webmaster by e-mail with the time and date of the error. |
| 121 | If this message is not to your liking, you can change it using the |
| 122 | set_message() routine. This is not imported by default; you should |
| 123 | import it on the use() line: |
| 124 | |
| 125 | use CGI::Carp qw(fatalsToBrowser set_message); |
| 126 | set_message("It's not a bug, it's a feature!"); |
| 127 | |
| 128 | You may also pass in a code reference in order to create a custom |
| 129 | error message. At run time, your code will be called with the text |
| 130 | of the error message that caused the script to die. Example: |
| 131 | |
| 132 | use CGI::Carp qw(fatalsToBrowser set_message); |
| 133 | BEGIN { |
| 134 | sub handle_errors { |
| 135 | my $msg = shift; |
| 136 | print "<h1>Oh gosh</h1>"; |
| 137 | print "Got an error: $msg"; |
| 138 | } |
| 139 | set_message(\&handle_errors); |
| 140 | } |
| 141 | |
| 142 | In order to correctly intercept compile-time errors, you should call |
| 143 | set_message() from within a BEGIN{} block. |
| 144 | |
| 145 | =head1 MAKING WARNINGS APPEAR AS HTML COMMENTS |
| 146 | |
| 147 | It is now also possible to make non-fatal errors appear as HTML |
| 148 | comments embedded in the output of your program. To enable this |
| 149 | feature, export the new "warningsToBrowser" subroutine. Since sending |
| 150 | warnings to the browser before the HTTP headers have been sent would |
| 151 | cause an error, any warnings are stored in an internal buffer until |
| 152 | you call the warningsToBrowser() subroutine with a true argument: |
| 153 | |
| 154 | use CGI::Carp qw(fatalsToBrowser warningsToBrowser); |
| 155 | use CGI qw(:standard); |
| 156 | print header(); |
| 157 | warningsToBrowser(1); |
| 158 | |
| 159 | You may also give a false argument to warningsToBrowser() to prevent |
| 160 | warnings from being sent to the browser while you are printing some |
| 161 | content where HTML comments are not allowed: |
| 162 | |
| 163 | warningsToBrowser(0); # disable warnings |
| 164 | print "<SCRIPT type=javascript><!--\n"; |
| 165 | print_some_javascript_code(); |
| 166 | print "//--></SCRIPT>\n"; |
| 167 | warningsToBrowser(1); # re-enable warnings |
| 168 | |
| 169 | Note: In this respect warningsToBrowser() differs fundamentally from |
| 170 | fatalsToBrowser(), which you should never call yourself! |
| 171 | |
| 172 | =head1 CHANGE LOG |
| 173 | |
| 174 | 1.05 carpout() added and minor corrections by Marc Hedlund |
| 175 | <hedlund@best.com> on 11/26/95. |
| 176 | |
| 177 | 1.06 fatalsToBrowser() no longer aborts for fatal errors within |
| 178 | eval() statements. |
| 179 | |
| 180 | 1.08 set_message() added and carpout() expanded to allow for FileHandle |
| 181 | objects. |
| 182 | |
| 183 | 1.09 set_message() now allows users to pass a code REFERENCE for |
| 184 | really custom error messages. croak and carp are now |
| 185 | exported by default. Thanks to Gunther Birznieks for the |
| 186 | patches. |
| 187 | |
| 188 | 1.10 Patch from Chris Dean (ctdean@cogit.com) to allow |
| 189 | module to run correctly under mod_perl. |
| 190 | |
| 191 | 1.11 Changed order of > and < escapes. |
| 192 | |
| 193 | 1.12 Changed die() on line 217 to CORE::die to avoid B<-w> warning. |
| 194 | |
| 195 | 1.13 Added cluck() to make the module orthogonal with Carp. |
| 196 | More mod_perl related fixes. |
| 197 | |
| 198 | 1.20 Patch from Ilmari Karonen (perl@itz.pp.sci.fi): Added |
| 199 | warningsToBrowser(). Replaced <CODE> tags with <PRE> in |
| 200 | fatalsToBrowser() output. |
| 201 | |
| 202 | =head1 AUTHORS |
| 203 | |
| 204 | Copyright 1995-1998, Lincoln D. Stein. All rights reserved. |
| 205 | |
| 206 | This library is free software; you can redistribute it and/or modify |
| 207 | it under the same terms as Perl itself. |
| 208 | |
| 209 | Address bug reports and comments to: lstein@cshl.org |
| 210 | |
| 211 | =head1 SEE ALSO |
| 212 | |
| 213 | Carp, CGI::Base, CGI::BasePlus, CGI::Request, CGI::MiniSvr, CGI::Form, |
| 214 | CGI::Response |
| 215 | |
| 216 | =cut |
| 217 | |
| 218 | require 5.000; |
| 219 | use Exporter; |
| 220 | #use Carp; |
| 221 | BEGIN { require Carp; } |
| 222 | use File::Spec; |
| 223 | |
| 224 | @ISA = qw(Exporter); |
| 225 | @EXPORT = qw(confess croak carp); |
| 226 | @EXPORT_OK = qw(carpout fatalsToBrowser warningsToBrowser wrap set_message cluck); |
| 227 | |
| 228 | $main::SIG{__WARN__}=\&CGI::Carp::warn; |
| 229 | $main::SIG{__DIE__}=\&CGI::Carp::die; |
| 230 | $CGI::Carp::VERSION = '1.22'; |
| 231 | $CGI::Carp::CUSTOM_MSG = undef; |
| 232 | |
| 233 | # fancy import routine detects and handles 'errorWrap' specially. |
| 234 | sub import { |
| 235 | my $pkg = shift; |
| 236 | my(%routines); |
| 237 | grep($routines{$_}++,@_,@EXPORT); |
| 238 | $WRAP++ if $routines{'fatalsToBrowser'} || $routines{'wrap'}; |
| 239 | $WARN++ if $routines{'warningsToBrowser'}; |
| 240 | my($oldlevel) = $Exporter::ExportLevel; |
| 241 | $Exporter::ExportLevel = 1; |
| 242 | Exporter::import($pkg,keys %routines); |
| 243 | $Exporter::ExportLevel = $oldlevel; |
| 244 | } |
| 245 | |
| 246 | # These are the originals |
| 247 | sub realwarn { CORE::warn(@_); } |
| 248 | sub realdie { CORE::die(@_); } |
| 249 | |
| 250 | sub id { |
| 251 | my $level = shift; |
| 252 | my($pack,$file,$line,$sub) = caller($level); |
| 253 | my($dev,$dirs,$id) = File::Spec->splitpath($file); |
| 254 | return ($file,$line,$id); |
| 255 | } |
| 256 | |
| 257 | sub stamp { |
| 258 | my $time = scalar(localtime); |
| 259 | my $frame = 0; |
| 260 | my ($id,$pack,$file,$dev,$dirs); |
| 261 | do { |
| 262 | $id = $file; |
| 263 | ($pack,$file) = caller($frame++); |
| 264 | } until !$file; |
| 265 | ($dev,$dirs,$id) = File::Spec->splitpath($id); |
| 266 | return "[$time] $id: "; |
| 267 | } |
| 268 | |
| 269 | sub warn { |
| 270 | my $message = shift; |
| 271 | my($file,$line,$id) = id(1); |
| 272 | $message .= " at $file line $line.\n" unless $message=~/\n$/; |
| 273 | _warn($message) if $WARN; |
| 274 | my $stamp = stamp; |
| 275 | $message=~s/^/$stamp/gm; |
| 276 | realwarn $message; |
| 277 | } |
| 278 | |
| 279 | sub _warn { |
| 280 | my $msg = shift; |
| 281 | if ($EMIT_WARNINGS) { |
| 282 | # We need to mangle the message a bit to make it a valid HTML |
| 283 | # comment. This is done by substituting similar-looking ISO |
| 284 | # 8859-1 characters for <, > and -. This is a hack. |
| 285 | $msg =~ tr/<>-/\253\273\255/; |
| 286 | chomp $msg; |
| 287 | print STDOUT "<!-- warning: $msg -->\n"; |
| 288 | } else { |
| 289 | push @WARNINGS, $msg; |
| 290 | } |
| 291 | } |
| 292 | |
| 293 | sub ineval { $^S } |
| 294 | |
| 295 | # The mod_perl package Apache::Registry loads CGI programs by calling |
| 296 | # eval. These evals don't count when looking at the stack backtrace. |
| 297 | sub _longmess { |
| 298 | my $message = Carp::longmess(); |
| 299 | my $mod_perl = exists $ENV{MOD_PERL}; |
| 300 | $message =~ s,eval[^\n]+Apache/Registry\.pm.*,,s if $mod_perl; |
| 301 | return $message; |
| 302 | } |
| 303 | |
| 304 | sub die { |
| 305 | realdie @_ if ineval; |
| 306 | my ($message) = @_; |
| 307 | my $time = scalar(localtime); |
| 308 | my($file,$line,$id) = id(1); |
| 309 | $message .= " at $file line $line." unless $message=~/\n$/; |
| 310 | &fatalsToBrowser($message) if $WRAP; |
| 311 | my $stamp = stamp; |
| 312 | $message=~s/^/$stamp/gm; |
| 313 | realdie $message; |
| 314 | } |
| 315 | |
| 316 | sub set_message { |
| 317 | $CGI::Carp::CUSTOM_MSG = shift; |
| 318 | return $CGI::Carp::CUSTOM_MSG; |
| 319 | } |
| 320 | |
| 321 | sub confess { CGI::Carp::die Carp::longmess @_; } |
| 322 | sub croak { CGI::Carp::die Carp::shortmess @_; } |
| 323 | sub carp { CGI::Carp::warn Carp::shortmess @_; } |
| 324 | sub cluck { CGI::Carp::warn Carp::longmess @_; } |
| 325 | |
| 326 | # We have to be ready to accept a filehandle as a reference |
| 327 | # or a string. |
| 328 | sub carpout { |
| 329 | my($in) = @_; |
| 330 | my($no) = fileno(to_filehandle($in)); |
| 331 | realdie("Invalid filehandle $in\n") unless defined $no; |
| 332 | |
| 333 | open(SAVEERR, ">&STDERR"); |
| 334 | open(STDERR, ">&$no") or |
| 335 | ( print SAVEERR "Unable to redirect STDERR: $!\n" and exit(1) ); |
| 336 | } |
| 337 | |
| 338 | sub warningsToBrowser { |
| 339 | $EMIT_WARNINGS = @_ ? shift : 1; |
| 340 | _warn(shift @WARNINGS) while $EMIT_WARNINGS and @WARNINGS; |
| 341 | } |
| 342 | |
| 343 | # headers |
| 344 | sub fatalsToBrowser { |
| 345 | my($msg) = @_; |
| 346 | $msg=~s/&/&/g; |
| 347 | $msg=~s/>/>/g; |
| 348 | $msg=~s/</</g; |
| 349 | $msg=~s/\"/"/g; |
| 350 | my($wm) = $ENV{SERVER_ADMIN} ? |
| 351 | qq[the webmaster (<a href="mailto:$ENV{SERVER_ADMIN}">$ENV{SERVER_ADMIN}</a>)] : |
| 352 | "this site's webmaster"; |
| 353 | my ($outer_message) = <<END; |
| 354 | For help, please send mail to $wm, giving this error message |
| 355 | and the time and date of the error. |
| 356 | END |
| 357 | ; |
| 358 | my $mod_perl = exists $ENV{MOD_PERL}; |
| 359 | print STDOUT "Content-type: text/html\n\n" |
| 360 | unless $mod_perl; |
| 361 | |
| 362 | warningsToBrowser(1); # emit warnings before dying |
| 363 | |
| 364 | if ($CUSTOM_MSG) { |
| 365 | if (ref($CUSTOM_MSG) eq 'CODE') { |
| 366 | &$CUSTOM_MSG($msg); # nicer to perl 5.003 users |
| 367 | return; |
| 368 | } else { |
| 369 | $outer_message = $CUSTOM_MSG; |
| 370 | } |
| 371 | } |
| 372 | |
| 373 | my $mess = <<END; |
| 374 | <H1>Software error:</H1> |
| 375 | <PRE>$msg</PRE> |
| 376 | <P> |
| 377 | $outer_message |
| 378 | END |
| 379 | ; |
| 380 | |
| 381 | if ($mod_perl && (my $r = Apache->request)) { |
| 382 | # If bytes have already been sent, then |
| 383 | # we print the message out directly. |
| 384 | # Otherwise we make a custom error |
| 385 | # handler to produce the doc for us. |
| 386 | if ($r->bytes_sent) { |
| 387 | $r->print($mess); |
| 388 | $r->exit; |
| 389 | } else { |
| 390 | $r->status(500); |
| 391 | $r->custom_response(500,$mess); |
| 392 | } |
| 393 | } else { |
| 394 | print STDOUT $mess; |
| 395 | } |
| 396 | } |
| 397 | |
| 398 | # Cut and paste from CGI.pm so that we don't have the overhead of |
| 399 | # always loading the entire CGI module. |
| 400 | sub to_filehandle { |
| 401 | my $thingy = shift; |
| 402 | return undef unless $thingy; |
| 403 | return $thingy if UNIVERSAL::isa($thingy,'GLOB'); |
| 404 | return $thingy if UNIVERSAL::isa($thingy,'FileHandle'); |
| 405 | if (!ref($thingy)) { |
| 406 | my $caller = 1; |
| 407 | while (my $package = caller($caller++)) { |
| 408 | my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy"; |
| 409 | return $tmp if defined(fileno($tmp)); |
| 410 | } |
| 411 | } |
| 412 | return undef; |
| 413 | } |
| 414 | |
| 415 | 1; |