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 | ||
17 | =head1 DESCRIPTION | |
18 | ||
19 | CGI scripts have a nasty habit of leaving warning messages in the error | |
20 | logs that are neither time stamped nor fully identified. Tracking down | |
21 | the script that caused the error is a pain. This fixes that. Replace | |
22 | the usual | |
23 | ||
24 | use Carp; | |
25 | ||
26 | with | |
27 | ||
28 | use CGI::Carp | |
29 | ||
30 | And the standard warn(), die (), croak(), confess() and carp() calls | |
31 | will automagically be replaced with functions that write out nicely | |
32 | time-stamped messages to the HTTP server error log. | |
33 | ||
34 | For example: | |
35 | ||
36 | [Fri Nov 17 21:40:43 1995] test.pl: I'm confused at test.pl line 3. | |
37 | [Fri Nov 17 21:40:43 1995] test.pl: Got an error message: Permission denied. | |
38 | [Fri Nov 17 21:40:43 1995] test.pl: I'm dying. | |
39 | ||
40 | =head1 REDIRECTING ERROR MESSAGES | |
41 | ||
42 | By default, error messages are sent to STDERR. Most HTTPD servers | |
43 | direct STDERR to the server's error log. Some applications may wish | |
44 | to keep private error logs, distinct from the server's error log, or | |
45 | they may wish to direct error messages to STDOUT so that the browser | |
46 | will receive them. | |
47 | ||
48 | The C<carpout()> function is provided for this purpose. Since | |
49 | carpout() is not exported by default, you must import it explicitly by | |
50 | saying | |
51 | ||
52 | use CGI::Carp qw(carpout); | |
53 | ||
54 | The carpout() function requires one argument, which should be a | |
55 | reference to an open filehandle for writing errors. It should be | |
56 | called in a C<BEGIN> block at the top of the CGI application so that | |
57 | compiler errors will be caught. Example: | |
58 | ||
59 | BEGIN { | |
60 | use CGI::Carp qw(carpout); | |
61 | open(LOG, ">>/usr/local/cgi-logs/mycgi-log") or | |
62 | die("Unable to open mycgi-log: $!\n"); | |
63 | carpout(LOG); | |
64 | } | |
65 | ||
66 | carpout() does not handle file locking on the log for you at this point. | |
67 | ||
68 | The real STDERR is not closed -- it is moved to SAVEERR. Some | |
69 | servers, when dealing with CGI scripts, close their connection to the | |
70 | browser when the script closes STDOUT and STDERR. SAVEERR is used to | |
71 | prevent this from happening prematurely. | |
72 | ||
73 | You can pass filehandles to carpout() in a variety of ways. The "correct" | |
74 | way according to Tom Christiansen is to pass a reference to a filehandle | |
75 | GLOB: | |
76 | ||
77 | carpout(\*LOG); | |
78 | ||
79 | This looks weird to mere mortals however, so the following syntaxes are | |
80 | accepted as well: | |
81 | ||
82 | carpout(LOG); | |
83 | carpout(main::LOG); | |
84 | carpout(main'LOG); | |
85 | carpout(\LOG); | |
86 | carpout(\'main::LOG'); | |
87 | ||
88 | ... and so on | |
89 | ||
424ec8fa GS |
90 | FileHandle and other objects work as well. |
91 | ||
54310121 | 92 | Use of carpout() is not great for performance, so it is recommended |
93 | for debugging purposes or for moderate-use applications. A future | |
94 | version of this module may delay redirecting STDERR until one of the | |
95 | CGI::Carp methods is called to prevent the performance hit. | |
96 | ||
97 | =head1 MAKING PERL ERRORS APPEAR IN THE BROWSER WINDOW | |
98 | ||
99 | If you want to send fatal (die, confess) errors to the browser, ask to | |
100 | import the special "fatalsToBrowser" subroutine: | |
101 | ||
102 | use CGI::Carp qw(fatalsToBrowser); | |
103 | die "Bad error here"; | |
104 | ||
105 | Fatal errors will now be echoed to the browser as well as to the log. CGI::Carp | |
106 | arranges to send a minimal HTTP header to the browser so that even errors that | |
107 | occur in the early compile phase will be seen. | |
108 | Nonfatal errors will still be directed to the log file only (unless redirected | |
109 | with carpout). | |
110 | ||
424ec8fa GS |
111 | =head2 Changing the default message |
112 | ||
113 | By default, the software error message is followed by a note to | |
114 | contact the Webmaster by e-mail with the time and date of the error. | |
115 | If this message is not to your liking, you can change it using the | |
116 | set_message() routine. This is not imported by default; you should | |
117 | import it on the use() line: | |
118 | ||
119 | use CGI::Carp qw(fatalsToBrowser set_message); | |
120 | set_message("It's not a bug, it's a feature!"); | |
121 | ||
122 | You may also pass in a code reference in order to create a custom | |
123 | error message. At run time, your code will be called with the text | |
124 | of the error message that caused the script to die. Example: | |
125 | ||
126 | use CGI::Carp qw(fatalsToBrowser set_message); | |
127 | BEGIN { | |
128 | sub handle_errors { | |
129 | my $msg = shift; | |
130 | print "<h1>Oh gosh</h1>"; | |
131 | print "Got an error: $msg"; | |
132 | } | |
133 | set_message(\&handle_errors); | |
134 | } | |
135 | ||
136 | In order to correctly intercept compile-time errors, you should call | |
137 | set_message() from within a BEGIN{} block. | |
138 | ||
54310121 | 139 | =head1 CHANGE LOG |
140 | ||
141 | 1.05 carpout() added and minor corrections by Marc Hedlund | |
142 | <hedlund@best.com> on 11/26/95. | |
143 | ||
144 | 1.06 fatalsToBrowser() no longer aborts for fatal errors within | |
145 | eval() statements. | |
146 | ||
424ec8fa GS |
147 | 1.08 set_message() added and carpout() expanded to allow for FileHandle |
148 | objects. | |
149 | ||
150 | 1.09 set_message() now allows users to pass a code REFERENCE for | |
151 | really custom error messages. croak and carp are now | |
152 | exported by default. Thanks to Gunther Birznieks for the | |
153 | patches. | |
154 | ||
155 | 1.10 Patch from Chris Dean (ctdean@cogit.com) to allow | |
156 | module to run correctly under mod_perl. | |
157 | ||
54310121 | 158 | =head1 AUTHORS |
159 | ||
160 | Lincoln D. Stein <lstein@genome.wi.mit.edu>. Feel free to redistribute | |
161 | this under the Perl Artistic License. | |
162 | ||
163 | ||
164 | =head1 SEE ALSO | |
165 | ||
166 | Carp, CGI::Base, CGI::BasePlus, CGI::Request, CGI::MiniSvr, CGI::Form, | |
167 | CGI::Response | |
168 | ||
169 | =cut | |
170 | ||
171 | require 5.000; | |
172 | use Exporter; | |
173 | use Carp; | |
174 | ||
175 | @ISA = qw(Exporter); | |
176 | @EXPORT = qw(confess croak carp); | |
424ec8fa | 177 | @EXPORT_OK = qw(carpout fatalsToBrowser wrap set_message); |
54310121 | 178 | |
179 | $main::SIG{__WARN__}=\&CGI::Carp::warn; | |
180 | $main::SIG{__DIE__}=\&CGI::Carp::die; | |
9014bb8e | 181 | $CGI::Carp::VERSION = '1.101'; |
424ec8fa | 182 | $CGI::Carp::CUSTOM_MSG = undef; |
54310121 | 183 | |
184 | # fancy import routine detects and handles 'errorWrap' specially. | |
185 | sub import { | |
186 | my $pkg = shift; | |
187 | my(%routines); | |
424ec8fa GS |
188 | grep($routines{$_}++,@_,@EXPORT); |
189 | $WRAP++ if $routines{'fatalsToBrowser'} || $routines{'wrap'}; | |
54310121 | 190 | my($oldlevel) = $Exporter::ExportLevel; |
191 | $Exporter::ExportLevel = 1; | |
192 | Exporter::import($pkg,keys %routines); | |
193 | $Exporter::ExportLevel = $oldlevel; | |
194 | } | |
195 | ||
196 | # These are the originals | |
9014bb8e GS |
197 | # XXX Why not just use CORE::die etc., instead of these two? GSAR |
198 | sub realwarn { CORE::warn(@_); } | |
199 | sub realdie { CORE::die(@_); } | |
54310121 | 200 | |
201 | sub id { | |
202 | my $level = shift; | |
203 | my($pack,$file,$line,$sub) = caller($level); | |
204 | my($id) = $file=~m|([^/]+)$|; | |
205 | return ($file,$line,$id); | |
206 | } | |
207 | ||
208 | sub stamp { | |
209 | my $time = scalar(localtime); | |
210 | my $frame = 0; | |
211 | my ($id,$pack,$file); | |
212 | do { | |
213 | $id = $file; | |
214 | ($pack,$file) = caller($frame++); | |
215 | } until !$file; | |
216 | ($id) = $id=~m|([^/]+)$|; | |
217 | return "[$time] $id: "; | |
218 | } | |
219 | ||
220 | sub warn { | |
221 | my $message = shift; | |
222 | my($file,$line,$id) = id(1); | |
223 | $message .= " at $file line $line.\n" unless $message=~/\n$/; | |
224 | my $stamp = stamp; | |
225 | $message=~s/^/$stamp/gm; | |
226 | realwarn $message; | |
227 | } | |
228 | ||
424ec8fa GS |
229 | # The mod_perl package Apache::Registry loads CGI programs by calling |
230 | # eval. These evals don't count when looking at the stack backtrace. | |
231 | sub _longmess { | |
232 | my $message = Carp::longmess(); | |
233 | my $mod_perl = ($ENV{'GATEWAY_INTERFACE'} | |
234 | && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl\//); | |
235 | $message =~ s,eval[^\n]+Apache/Registry\.pm.*,,s if $mod_perl; | |
236 | return( $message ); | |
237 | } | |
238 | ||
54310121 | 239 | sub die { |
240 | my $message = shift; | |
241 | my $time = scalar(localtime); | |
242 | my($file,$line,$id) = id(1); | |
54310121 | 243 | $message .= " at $file line $line.\n" unless $message=~/\n$/; |
424ec8fa | 244 | &fatalsToBrowser($message) if $WRAP && _longmess() !~ /eval [{\']/m; |
54310121 | 245 | my $stamp = stamp; |
246 | $message=~s/^/$stamp/gm; | |
247 | realdie $message; | |
248 | } | |
249 | ||
424ec8fa GS |
250 | sub set_message { |
251 | $CGI::Carp::CUSTOM_MSG = shift; | |
252 | return $CGI::Carp::CUSTOM_MSG; | |
253 | } | |
254 | ||
54310121 | 255 | # Avoid generating "subroutine redefined" warnings with the following |
256 | # hack: | |
257 | { | |
258 | local $^W=0; | |
259 | eval <<EOF; | |
260 | sub confess { CGI::Carp::die Carp::longmess \@_; } | |
261 | sub croak { CGI::Carp::die Carp::shortmess \@_; } | |
262 | sub carp { CGI::Carp::warn Carp::shortmess \@_; } | |
263 | EOF | |
264 | ; | |
265 | } | |
266 | ||
267 | # We have to be ready to accept a filehandle as a reference | |
268 | # or a string. | |
269 | sub carpout { | |
270 | my($in) = @_; | |
424ec8fa | 271 | my($no) = fileno(to_filehandle($in)); |
9014bb8e | 272 | realdie "Invalid filehandle $in\n" unless defined $no; |
54310121 | 273 | |
274 | open(SAVEERR, ">&STDERR"); | |
275 | open(STDERR, ">&$no") or | |
276 | ( print SAVEERR "Unable to redirect STDERR: $!\n" and exit(1) ); | |
277 | } | |
278 | ||
279 | # headers | |
280 | sub fatalsToBrowser { | |
281 | my($msg) = @_; | |
282 | $msg=~s/>/>/g; | |
283 | $msg=~s/</</g; | |
424ec8fa GS |
284 | $msg=~s/&/&/g; |
285 | $msg=~s/\"/"/g; | |
286 | my($wm) = $ENV{SERVER_ADMIN} ? | |
287 | qq[the webmaster (<a href="mailto:$ENV{SERVER_ADMIN}">$ENV{SERVER_ADMIN}</a>)] : | |
288 | "this site's webmaster"; | |
289 | my ($outer_message) = <<END; | |
290 | For help, please send mail to $wm, giving this error message | |
291 | and the time and date of the error. | |
292 | END | |
293 | ; | |
54310121 | 294 | print STDOUT "Content-type: text/html\n\n"; |
424ec8fa GS |
295 | |
296 | if ($CUSTOM_MSG) { | |
297 | if (ref($CUSTOM_MSG) eq 'CODE') { | |
298 | &$CUSTOM_MSG($msg); # nicer to perl 5.003 users | |
299 | return; | |
300 | } else { | |
301 | $outer_message = $CUSTOM_MSG; | |
302 | } | |
303 | } | |
304 | ||
54310121 | 305 | print STDOUT <<END; |
306 | <H1>Software error:</H1> | |
307 | <CODE>$msg</CODE> | |
308 | <P> | |
424ec8fa | 309 | $outer_message; |
54310121 | 310 | END |
424ec8fa GS |
311 | ; |
312 | } | |
313 | ||
314 | # Cut and paste from CGI.pm so that we don't have the overhead of | |
315 | # always loading the entire CGI module. | |
316 | sub to_filehandle { | |
317 | my $thingy = shift; | |
318 | return undef unless $thingy; | |
319 | return $thingy if UNIVERSAL::isa($thingy,'GLOB'); | |
320 | return $thingy if UNIVERSAL::isa($thingy,'FileHandle'); | |
321 | if (!ref($thingy)) { | |
322 | my $caller = 1; | |
323 | while (my $package = caller($caller++)) { | |
324 | my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy"; | |
325 | return $tmp if defined(fileno($tmp)); | |
326 | } | |
327 | } | |
328 | return undef; | |
54310121 | 329 | } |
330 | ||
331 | 1; |