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 | |
71f3e297 |
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 | |
54310121 |
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 SAVEERR. Some |
75 | servers, when dealing with CGI scripts, close their connection to the |
76 | browser when the script closes STDOUT and STDERR. SAVEERR is used 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 | |
424ec8fa |
96 | FileHandle and other objects work as well. |
97 | |
54310121 |
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 | |
424ec8fa |
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 | |
54310121 |
145 | =head1 CHANGE LOG |
146 | |
147 | 1.05 carpout() added and minor corrections by Marc Hedlund |
148 | <hedlund@best.com> on 11/26/95. |
149 | |
150 | 1.06 fatalsToBrowser() no longer aborts for fatal errors within |
151 | eval() statements. |
152 | |
424ec8fa |
153 | 1.08 set_message() added and carpout() expanded to allow for FileHandle |
154 | objects. |
155 | |
156 | 1.09 set_message() now allows users to pass a code REFERENCE for |
157 | really custom error messages. croak and carp are now |
158 | exported by default. Thanks to Gunther Birznieks for the |
159 | patches. |
160 | |
161 | 1.10 Patch from Chris Dean (ctdean@cogit.com) to allow |
162 | module to run correctly under mod_perl. |
163 | |
71f3e297 |
164 | 1.11 Changed order of > and < escapes. |
165 | |
166 | 1.12 Changed die() on line 217 to CORE::die to avoid B<-w> warning. |
167 | |
168 | 1.13 Added cluck() to make the module orthogonal with Carp. |
169 | More mod_perl related fixes. |
170 | |
54310121 |
171 | =head1 AUTHORS |
172 | |
71f3e297 |
173 | Copyright 1995-1998, Lincoln D. Stein. All rights reserved. |
174 | |
175 | This library is free software; you can redistribute it and/or modify |
176 | it under the same terms as Perl itself. |
54310121 |
177 | |
71f3e297 |
178 | Address bug reports and comments to: lstein@cshl.org |
54310121 |
179 | |
180 | =head1 SEE ALSO |
181 | |
182 | Carp, CGI::Base, CGI::BasePlus, CGI::Request, CGI::MiniSvr, CGI::Form, |
183 | CGI::Response |
184 | |
185 | =cut |
186 | |
187 | require 5.000; |
188 | use Exporter; |
189 | use Carp; |
190 | |
191 | @ISA = qw(Exporter); |
192 | @EXPORT = qw(confess croak carp); |
71f3e297 |
193 | @EXPORT_OK = qw(carpout fatalsToBrowser wrap set_message cluck); |
54310121 |
194 | |
3538e1d5 |
195 | BEGIN { |
196 | $] >= 5.005 |
3d1a2ec4 |
197 | ? eval q#sub ineval { defined $^S ? $^S : _longmess() =~ /eval [\{\']/m }# |
198 | : eval q#sub ineval { _longmess() =~ /eval [\{\']/m }#; |
3538e1d5 |
199 | $@ and die; |
200 | } |
201 | |
54310121 |
202 | $main::SIG{__WARN__}=\&CGI::Carp::warn; |
203 | $main::SIG{__DIE__}=\&CGI::Carp::die; |
3d1a2ec4 |
204 | $CGI::Carp::VERSION = '1.16'; |
424ec8fa |
205 | $CGI::Carp::CUSTOM_MSG = undef; |
54310121 |
206 | |
207 | # fancy import routine detects and handles 'errorWrap' specially. |
208 | sub import { |
209 | my $pkg = shift; |
210 | my(%routines); |
424ec8fa |
211 | grep($routines{$_}++,@_,@EXPORT); |
212 | $WRAP++ if $routines{'fatalsToBrowser'} || $routines{'wrap'}; |
54310121 |
213 | my($oldlevel) = $Exporter::ExportLevel; |
214 | $Exporter::ExportLevel = 1; |
215 | Exporter::import($pkg,keys %routines); |
216 | $Exporter::ExportLevel = $oldlevel; |
217 | } |
218 | |
219 | # These are the originals |
9014bb8e |
220 | sub realwarn { CORE::warn(@_); } |
221 | sub realdie { CORE::die(@_); } |
54310121 |
222 | |
223 | sub id { |
224 | my $level = shift; |
225 | my($pack,$file,$line,$sub) = caller($level); |
14a089c5 |
226 | my($id) = $file=~m|([^/]+)\z|; |
54310121 |
227 | return ($file,$line,$id); |
228 | } |
229 | |
230 | sub stamp { |
231 | my $time = scalar(localtime); |
232 | my $frame = 0; |
233 | my ($id,$pack,$file); |
234 | do { |
235 | $id = $file; |
236 | ($pack,$file) = caller($frame++); |
237 | } until !$file; |
14a089c5 |
238 | ($id) = $id=~m|([^/]+)\z|; |
54310121 |
239 | return "[$time] $id: "; |
240 | } |
241 | |
242 | sub warn { |
243 | my $message = shift; |
244 | my($file,$line,$id) = id(1); |
245 | $message .= " at $file line $line.\n" unless $message=~/\n$/; |
246 | my $stamp = stamp; |
247 | $message=~s/^/$stamp/gm; |
248 | realwarn $message; |
249 | } |
250 | |
424ec8fa |
251 | # The mod_perl package Apache::Registry loads CGI programs by calling |
252 | # eval. These evals don't count when looking at the stack backtrace. |
253 | sub _longmess { |
254 | my $message = Carp::longmess(); |
71f3e297 |
255 | my $mod_perl = exists $ENV{MOD_PERL}; |
424ec8fa |
256 | $message =~ s,eval[^\n]+Apache/Registry\.pm.*,,s if $mod_perl; |
257 | return( $message ); |
258 | } |
259 | |
54310121 |
260 | sub die { |
3538e1d5 |
261 | realdie @_ if ineval; |
262 | my $message = shift; |
263 | my $time = scalar(localtime); |
264 | my($file,$line,$id) = id(1); |
265 | $message .= " at $file line $line." unless $message=~/\n$/; |
266 | &fatalsToBrowser($message) if $WRAP; |
267 | my $stamp = stamp; |
268 | $message=~s/^/$stamp/gm; |
269 | realdie $message; |
54310121 |
270 | } |
271 | |
424ec8fa |
272 | sub set_message { |
273 | $CGI::Carp::CUSTOM_MSG = shift; |
274 | return $CGI::Carp::CUSTOM_MSG; |
275 | } |
276 | |
54310121 |
277 | # Avoid generating "subroutine redefined" warnings with the following |
278 | # hack: |
279 | { |
280 | local $^W=0; |
281 | eval <<EOF; |
282 | sub confess { CGI::Carp::die Carp::longmess \@_; } |
71f3e297 |
283 | sub croak { CGI::Carp::die Carp::shortmess \@_; } |
284 | sub carp { CGI::Carp::warn Carp::shortmess \@_; } |
285 | sub cluck { CGI::Carp::warn Carp::longmess \@_; } |
54310121 |
286 | EOF |
287 | ; |
288 | } |
289 | |
290 | # We have to be ready to accept a filehandle as a reference |
291 | # or a string. |
292 | sub carpout { |
293 | my($in) = @_; |
424ec8fa |
294 | my($no) = fileno(to_filehandle($in)); |
71f3e297 |
295 | realdie("Invalid filehandle $in\n") unless defined $no; |
54310121 |
296 | |
297 | open(SAVEERR, ">&STDERR"); |
298 | open(STDERR, ">&$no") or |
299 | ( print SAVEERR "Unable to redirect STDERR: $!\n" and exit(1) ); |
300 | } |
301 | |
302 | # headers |
303 | sub fatalsToBrowser { |
304 | my($msg) = @_; |
71f3e297 |
305 | $msg=~s/&/&/g; |
54310121 |
306 | $msg=~s/>/>/g; |
307 | $msg=~s/</</g; |
424ec8fa |
308 | $msg=~s/\"/"/g; |
309 | my($wm) = $ENV{SERVER_ADMIN} ? |
310 | qq[the webmaster (<a href="mailto:$ENV{SERVER_ADMIN}">$ENV{SERVER_ADMIN}</a>)] : |
311 | "this site's webmaster"; |
312 | my ($outer_message) = <<END; |
313 | For help, please send mail to $wm, giving this error message |
314 | and the time and date of the error. |
315 | END |
316 | ; |
71f3e297 |
317 | my $mod_perl = exists $ENV{MOD_PERL}; |
318 | print STDOUT "Content-type: text/html\n\n" |
319 | unless $mod_perl; |
424ec8fa |
320 | |
321 | if ($CUSTOM_MSG) { |
322 | if (ref($CUSTOM_MSG) eq 'CODE') { |
323 | &$CUSTOM_MSG($msg); # nicer to perl 5.003 users |
324 | return; |
325 | } else { |
326 | $outer_message = $CUSTOM_MSG; |
327 | } |
328 | } |
329 | |
71f3e297 |
330 | my $mess = <<END; |
54310121 |
331 | <H1>Software error:</H1> |
332 | <CODE>$msg</CODE> |
333 | <P> |
71f3e297 |
334 | $outer_message |
54310121 |
335 | END |
424ec8fa |
336 | ; |
71f3e297 |
337 | |
3d1a2ec4 |
338 | if ($mod_perl && (my $r = Apache->request)) { |
71f3e297 |
339 | # If bytes have already been sent, then |
340 | # we print the message out directly. |
341 | # Otherwise we make a custom error |
342 | # handler to produce the doc for us. |
343 | if ($r->bytes_sent) { |
344 | $r->print($mess); |
345 | $r->exit; |
346 | } else { |
347 | $r->status(500); |
348 | $r->custom_response(500,$mess); |
349 | } |
350 | } else { |
351 | print STDOUT $mess; |
352 | } |
424ec8fa |
353 | } |
354 | |
355 | # Cut and paste from CGI.pm so that we don't have the overhead of |
356 | # always loading the entire CGI module. |
357 | sub to_filehandle { |
358 | my $thingy = shift; |
359 | return undef unless $thingy; |
360 | return $thingy if UNIVERSAL::isa($thingy,'GLOB'); |
361 | return $thingy if UNIVERSAL::isa($thingy,'FileHandle'); |
362 | if (!ref($thingy)) { |
363 | my $caller = 1; |
364 | while (my $package = caller($caller++)) { |
365 | my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy"; |
366 | return $tmp if defined(fileno($tmp)); |
367 | } |
368 | } |
369 | return undef; |
54310121 |
370 | } |
371 | |
372 | 1; |