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 | |
ba056755 |
74 | The real STDERR is not closed -- it is moved to CGI::Carp::SAVEERR. Some |
54310121 |
75 | servers, when dealing with CGI scripts, close their connection to the |
ba056755 |
76 | browser when the script closes STDOUT and STDERR. CGI::Carp::SAVEERR is there to |
54310121 |
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 | |
55b5d700 |
105 | If you want to send fatal (die, confess) errors to the browser, ask to |
54310121 |
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 | |
55b5d700 |
117 | Note that fatalsToBrowser does B<not> work with mod_perl version 2.0 |
118 | and higher. |
119 | |
424ec8fa |
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>"; |
b2d0d414 |
140 | print "<p>Got an error: $msg</p>"; |
424ec8fa |
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 | |
8869a4b7 |
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 | |
6b4ac661 |
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 |
b2d0d414 |
203 | print "<script type=\"text/javascript\"><!--\n"; |
6b4ac661 |
204 | print_some_javascript_code(); |
b2d0d414 |
205 | print "//--></script>\n"; |
6b4ac661 |
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 | |
188ba755 |
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 | |
54310121 |
244 | =head1 CHANGE LOG |
245 | |
c29edf6c |
246 | 1.29 Patch from Peter Whaite to fix the unfixable problem of CGI::Carp |
247 | not behaving correctly in an eval() context. |
248 | |
54310121 |
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 | |
424ec8fa |
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 | |
71f3e297 |
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. |
6b4ac661 |
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. |
71f3e297 |
276 | |
b2d0d414 |
277 | 1.23 ineval() now checks both $^S and inspects the message for the "eval" pattern |
3c4b39be |
278 | (hack alert!) in order to accommodate various combinations of Perl and |
b2d0d414 |
279 | mod_perl. |
280 | |
188ba755 |
281 | 1.24 Patch from Scott Gifford (sgifford@suspectclass.com): Add support |
282 | for overriding program name. |
283 | |
1c87da1d |
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 | |
2ed511ec |
288 | 1.27 Replaced tell STDOUT with bytes=tell STDOUT. |
289 | |
54310121 |
290 | =head1 AUTHORS |
291 | |
b2d0d414 |
292 | Copyright 1995-2002, Lincoln D. Stein. All rights reserved. |
71f3e297 |
293 | |
294 | This library is free software; you can redistribute it and/or modify |
295 | it under the same terms as Perl itself. |
54310121 |
296 | |
71f3e297 |
297 | Address bug reports and comments to: lstein@cshl.org |
54310121 |
298 | |
299 | =head1 SEE ALSO |
300 | |
301 | Carp, CGI::Base, CGI::BasePlus, CGI::Request, CGI::MiniSvr, CGI::Form, |
302 | CGI::Response |
188ba755 |
303 | if (defined($CGI::Carp::PROGNAME)) |
304 | { |
305 | $file = $CGI::Carp::PROGNAME; |
306 | } |
54310121 |
307 | |
308 | =cut |
309 | |
310 | require 5.000; |
311 | use Exporter; |
3acbd4f5 |
312 | #use Carp; |
1c87da1d |
313 | BEGIN { |
314 | require Carp; |
315 | *CORE::GLOBAL::die = \&CGI::Carp::die; |
316 | } |
317 | |
7f16a916 |
318 | use File::Spec; |
54310121 |
319 | |
320 | @ISA = qw(Exporter); |
321 | @EXPORT = qw(confess croak carp); |
8869a4b7 |
322 | @EXPORT_OK = qw(carpout fatalsToBrowser warningsToBrowser wrap set_message set_die_handler set_progname cluck ^name= die); |
3538e1d5 |
323 | |
54310121 |
324 | $main::SIG{__WARN__}=\&CGI::Carp::warn; |
1c87da1d |
325 | |
bb8b3399 |
326 | $CGI::Carp::VERSION = '1.30_01'; |
8869a4b7 |
327 | $CGI::Carp::CUSTOM_MSG = undef; |
328 | $CGI::Carp::DIE_HANDLER = undef; |
54310121 |
329 | |
1c87da1d |
330 | |
54310121 |
331 | # fancy import routine detects and handles 'errorWrap' specially. |
332 | sub import { |
333 | my $pkg = shift; |
334 | my(%routines); |
188ba755 |
335 | my(@name); |
188ba755 |
336 | if (@name=grep(/^name=/,@_)) |
337 | { |
338 | my($n) = (split(/=/,$name[0]))[1]; |
339 | set_progname($n); |
340 | @_=grep(!/^name=/,@_); |
341 | } |
342 | |
424ec8fa |
343 | grep($routines{$_}++,@_,@EXPORT); |
344 | $WRAP++ if $routines{'fatalsToBrowser'} || $routines{'wrap'}; |
6b4ac661 |
345 | $WARN++ if $routines{'warningsToBrowser'}; |
54310121 |
346 | my($oldlevel) = $Exporter::ExportLevel; |
347 | $Exporter::ExportLevel = 1; |
348 | Exporter::import($pkg,keys %routines); |
349 | $Exporter::ExportLevel = $oldlevel; |
1c87da1d |
350 | $main::SIG{__DIE__} =\&CGI::Carp::die if $routines{'fatalsToBrowser'}; |
351 | # $pkg->export('CORE::GLOBAL','die'); |
54310121 |
352 | } |
353 | |
354 | # These are the originals |
9014bb8e |
355 | sub realwarn { CORE::warn(@_); } |
356 | sub realdie { CORE::die(@_); } |
54310121 |
357 | |
358 | sub id { |
359 | my $level = shift; |
360 | my($pack,$file,$line,$sub) = caller($level); |
7f16a916 |
361 | my($dev,$dirs,$id) = File::Spec->splitpath($file); |
54310121 |
362 | return ($file,$line,$id); |
363 | } |
364 | |
365 | sub stamp { |
366 | my $time = scalar(localtime); |
367 | my $frame = 0; |
ac734d8b |
368 | my ($id,$pack,$file,$dev,$dirs); |
188ba755 |
369 | if (defined($CGI::Carp::PROGNAME)) { |
370 | $id = $CGI::Carp::PROGNAME; |
371 | } else { |
372 | do { |
373 | $id = $file; |
374 | ($pack,$file) = caller($frame++); |
375 | } until !$file; |
376 | } |
7f16a916 |
377 | ($dev,$dirs,$id) = File::Spec->splitpath($id); |
54310121 |
378 | return "[$time] $id: "; |
379 | } |
380 | |
188ba755 |
381 | sub set_progname { |
382 | $CGI::Carp::PROGNAME = shift; |
383 | return $CGI::Carp::PROGNAME; |
384 | } |
385 | |
386 | |
54310121 |
387 | sub warn { |
388 | my $message = shift; |
389 | my($file,$line,$id) = id(1); |
390 | $message .= " at $file line $line.\n" unless $message=~/\n$/; |
6b4ac661 |
391 | _warn($message) if $WARN; |
54310121 |
392 | my $stamp = stamp; |
393 | $message=~s/^/$stamp/gm; |
394 | realwarn $message; |
395 | } |
396 | |
6b4ac661 |
397 | sub _warn { |
398 | my $msg = shift; |
399 | 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 | $msg =~ tr/<>-/\253\273\255/; |
404 | chomp $msg; |
405 | print STDOUT "<!-- warning: $msg -->\n"; |
406 | } else { |
407 | push @WARNINGS, $msg; |
408 | } |
409 | } |
410 | |
6b4ac661 |
411 | |
424ec8fa |
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 | my $message = Carp::longmess(); |
29ddc2a4 |
416 | $message =~ s,eval[^\n]+(ModPerl|Apache)/(?:Registry|Dispatch)\w*\.pm.*,,s |
8f3ccfa2 |
417 | if exists $ENV{MOD_PERL}; |
418 | return $message; |
419 | } |
420 | |
421 | sub ineval { |
422 | (exists $ENV{MOD_PERL} ? 0 : $^S) || _longmess() =~ /eval [\{\']/m |
424ec8fa |
423 | } |
424 | |
54310121 |
425 | sub die { |
13548fdf |
426 | my ($arg,@rest) = @_; |
c29edf6c |
427 | |
8869a4b7 |
428 | if ($DIE_HANDLER) { |
429 | &$DIE_HANDLER($arg,@rest); |
430 | } |
431 | |
c29edf6c |
432 | if ( ineval() ) { |
433 | if (!ref($arg)) { |
434 | $arg = join("",($arg,@rest)) || "Died"; |
435 | my($file,$line,$id) = id(1); |
436 | $arg .= " at $file line $line.\n" unless $arg=~/\n$/; |
437 | realdie($arg); |
438 | } |
439 | else { |
440 | realdie($arg,@rest); |
441 | } |
442 | } |
13548fdf |
443 | |
8f3ccfa2 |
444 | if (!ref($arg)) { |
13548fdf |
445 | $arg = join("", ($arg,@rest)); |
8f3ccfa2 |
446 | my($file,$line,$id) = id(1); |
447 | $arg .= " at $file line $line." unless $arg=~/\n$/; |
448 | &fatalsToBrowser($arg) if $WRAP; |
449 | if (($arg =~ /\n$/) || !exists($ENV{MOD_PERL})) { |
450 | my $stamp = stamp; |
451 | $arg=~s/^/$stamp/gm; |
452 | } |
453 | if ($arg !~ /\n$/) { |
454 | $arg .= "\n"; |
455 | } |
456 | } |
457 | realdie $arg; |
54310121 |
458 | } |
459 | |
424ec8fa |
460 | sub set_message { |
461 | $CGI::Carp::CUSTOM_MSG = shift; |
462 | return $CGI::Carp::CUSTOM_MSG; |
463 | } |
464 | |
8869a4b7 |
465 | sub set_die_handler { |
466 | |
467 | my ($handler) = shift; |
468 | |
469 | #setting SIG{__DIE__} here is necessary to catch runtime |
470 | #errors which are not called by literally saying "die", |
471 | #such as the line "undef->explode();". however, doing this |
472 | #will interfere with fatalsToBrowser, which also sets |
473 | #SIG{__DIE__} in the import() function above (or the |
474 | #import() function above may interfere with this). for |
475 | #this reason, you should choose to either set the die |
476 | #handler here, or use fatalsToBrowser, not both. |
477 | $main::SIG{__DIE__} = $handler; |
478 | |
479 | $CGI::Carp::DIE_HANDLER = $handler; |
480 | |
481 | return $CGI::Carp::DIE_HANDLER; |
482 | } |
483 | |
2371fea9 |
484 | sub confess { CGI::Carp::die Carp::longmess @_; } |
485 | sub croak { CGI::Carp::die Carp::shortmess @_; } |
486 | sub carp { CGI::Carp::warn Carp::shortmess @_; } |
487 | sub cluck { CGI::Carp::warn Carp::longmess @_; } |
54310121 |
488 | |
489 | # We have to be ready to accept a filehandle as a reference |
490 | # or a string. |
491 | sub carpout { |
492 | my($in) = @_; |
424ec8fa |
493 | my($no) = fileno(to_filehandle($in)); |
71f3e297 |
494 | realdie("Invalid filehandle $in\n") unless defined $no; |
54310121 |
495 | |
496 | open(SAVEERR, ">&STDERR"); |
497 | open(STDERR, ">&$no") or |
498 | ( print SAVEERR "Unable to redirect STDERR: $!\n" and exit(1) ); |
499 | } |
500 | |
6b4ac661 |
501 | sub warningsToBrowser { |
502 | $EMIT_WARNINGS = @_ ? shift : 1; |
503 | _warn(shift @WARNINGS) while $EMIT_WARNINGS and @WARNINGS; |
504 | } |
505 | |
54310121 |
506 | # headers |
507 | sub fatalsToBrowser { |
8f3ccfa2 |
508 | my($msg) = @_; |
509 | $msg=~s/&/&/g; |
510 | $msg=~s/>/>/g; |
511 | $msg=~s/</</g; |
512 | $msg=~s/\"/"/g; |
513 | my($wm) = $ENV{SERVER_ADMIN} ? |
514 | qq[the webmaster (<a href="mailto:$ENV{SERVER_ADMIN}">$ENV{SERVER_ADMIN}</a>)] : |
515 | "this site's webmaster"; |
516 | my ($outer_message) = <<END; |
424ec8fa |
517 | For help, please send mail to $wm, giving this error message |
518 | and the time and date of the error. |
519 | END |
8f3ccfa2 |
520 | ; |
521 | my $mod_perl = exists $ENV{MOD_PERL}; |
8f3ccfa2 |
522 | |
8f3ccfa2 |
523 | if ($CUSTOM_MSG) { |
524 | if (ref($CUSTOM_MSG) eq 'CODE') { |
0c45d622 |
525 | print STDOUT "Content-type: text/html\n\n" |
526 | unless $mod_perl; |
8f3ccfa2 |
527 | &$CUSTOM_MSG($msg); # nicer to perl 5.003 users |
528 | return; |
529 | } else { |
530 | $outer_message = $CUSTOM_MSG; |
424ec8fa |
531 | } |
8f3ccfa2 |
532 | } |
1c87da1d |
533 | |
8f3ccfa2 |
534 | my $mess = <<END; |
b2d0d414 |
535 | <h1>Software error:</h1> |
536 | <pre>$msg</pre> |
537 | <p> |
71f3e297 |
538 | $outer_message |
b2d0d414 |
539 | </p> |
54310121 |
540 | END |
8f3ccfa2 |
541 | ; |
1c87da1d |
542 | |
8f3ccfa2 |
543 | if ($mod_perl) { |
741ff09d |
544 | my $r; |
0a9bdad4 |
545 | if ($ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) { |
8f3ccfa2 |
546 | $mod_perl = 2; |
741ff09d |
547 | require Apache2::RequestRec; |
548 | require Apache2::RequestIO; |
549 | require Apache2::RequestUtil; |
8f3ccfa2 |
550 | require APR::Pool; |
551 | require ModPerl::Util; |
741ff09d |
552 | require Apache2::Response; |
553 | $r = Apache2::RequestUtil->request; |
554 | } |
555 | else { |
556 | $r = Apache->request; |
8f3ccfa2 |
557 | } |
8f3ccfa2 |
558 | # If bytes have already been sent, then |
559 | # we print the message out directly. |
560 | # Otherwise we make a custom error |
561 | # handler to produce the doc for us. |
562 | if ($r->bytes_sent) { |
563 | $r->print($mess); |
564 | $mod_perl == 2 ? ModPerl::Util::exit(0) : $r->exit; |
71f3e297 |
565 | } else { |
1c87da1d |
566 | # MSIE won't display a custom 500 response unless it is >512 bytes! |
8f3ccfa2 |
567 | if ($ENV{HTTP_USER_AGENT} =~ /MSIE/) { |
1c87da1d |
568 | $mess = "<!-- " . (' ' x 513) . " -->\n$mess"; |
8f3ccfa2 |
569 | } |
1c87da1d |
570 | $r->custom_response(500,$mess); |
71f3e297 |
571 | } |
8f3ccfa2 |
572 | } else { |
2ed511ec |
573 | my $bytes_written = eval{tell STDOUT}; |
574 | if (defined $bytes_written && $bytes_written > 0) { |
0c45d622 |
575 | print STDOUT $mess; |
576 | } |
577 | else { |
bb8b3399 |
578 | print STDOUT "Status: 500\n"; |
0c45d622 |
579 | print STDOUT "Content-type: text/html\n\n"; |
580 | print STDOUT $mess; |
581 | } |
8f3ccfa2 |
582 | } |
13548fdf |
583 | |
584 | warningsToBrowser(1); # emit warnings before dying |
424ec8fa |
585 | } |
586 | |
587 | # Cut and paste from CGI.pm so that we don't have the overhead of |
588 | # always loading the entire CGI module. |
589 | sub to_filehandle { |
590 | my $thingy = shift; |
591 | return undef unless $thingy; |
592 | return $thingy if UNIVERSAL::isa($thingy,'GLOB'); |
593 | return $thingy if UNIVERSAL::isa($thingy,'FileHandle'); |
594 | if (!ref($thingy)) { |
595 | my $caller = 1; |
596 | while (my $package = caller($caller++)) { |
597 | my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy"; |
598 | return $tmp if defined(fileno($tmp)); |
599 | } |
600 | } |
601 | return undef; |
54310121 |
602 | } |
603 | |
604 | 1; |