Filename | /usr/share/perl5/vendor_perl/CGI/Carp.pm |
Statements | Executed 134 statements in 5.13ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 4.92ms | 5.37ms | BEGIN@334 | CGI::Carp::
1 | 1 | 1 | 3.59ms | 5.23ms | BEGIN@339 | CGI::Carp::
1 | 1 | 1 | 1.35ms | 1.40ms | BEGIN@332 | CGI::Carp::
2 | 1 | 1 | 231µs | 245µs | stamp | CGI::Carp::
2 | 1 | 1 | 49µs | 49µs | realwarn | CGI::Carp::
2 | 2 | 2 | 46µs | 405µs | warn | CGI::Carp::
2 | 1 | 1 | 41µs | 65µs | id | CGI::Carp::
1 | 1 | 1 | 39µs | 107µs | import | CGI::Carp::
0 | 0 | 0 | 0s | 0s | _longmess | CGI::Carp::
0 | 0 | 0 | 0s | 0s | _warn | CGI::Carp::
0 | 0 | 0 | 0s | 0s | carp | CGI::Carp::
0 | 0 | 0 | 0s | 0s | carpout | CGI::Carp::
0 | 0 | 0 | 0s | 0s | cluck | CGI::Carp::
0 | 0 | 0 | 0s | 0s | confess | CGI::Carp::
0 | 0 | 0 | 0s | 0s | croak | CGI::Carp::
0 | 0 | 0 | 0s | 0s | die | CGI::Carp::
0 | 0 | 0 | 0s | 0s | fatalsToBrowser | CGI::Carp::
0 | 0 | 0 | 0s | 0s | ineval | CGI::Carp::
0 | 0 | 0 | 0s | 0s | realdie | CGI::Carp::
0 | 0 | 0 | 0s | 0s | set_die_handler | CGI::Carp::
0 | 0 | 0 | 0s | 0s | set_message | CGI::Carp::
0 | 0 | 0 | 0s | 0s | set_progname | CGI::Carp::
0 | 0 | 0 | 0s | 0s | to_filehandle | CGI::Carp::
0 | 0 | 0 | 0s | 0s | warningsToBrowser | CGI::Carp::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
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 | The standard warn(), die (), croak(), confess() and carp() calls will | ||||
37 | be replaced with functions that write time-stamped messages to the | ||||
38 | 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, a reference to an open | ||||
61 | filehandle for writing errors. It should be called in a C<BEGIN> | ||||
62 | block at the top of the CGI application so that compiler errors will | ||||
63 | 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 | ||||
73 | point. Also, note that carpout() does not work with in-memory file | ||||
74 | handles, although a patch would be welcome to address that. | ||||
75 | |||||
76 | The real STDERR is not closed -- it is moved to CGI::Carp::SAVEERR. | ||||
77 | Some servers, when dealing with CGI scripts, close their connection to | ||||
78 | the browser when the script closes STDOUT and STDERR. | ||||
79 | CGI::Carp::SAVEERR is there to prevent this from happening | ||||
80 | prematurely. | ||||
81 | |||||
82 | You can pass filehandles to carpout() in a variety of ways. The "correct" | ||||
83 | way according to Tom Christiansen is to pass a reference to a filehandle | ||||
84 | GLOB: | ||||
85 | |||||
86 | carpout(\*LOG); | ||||
87 | |||||
88 | This looks weird to mere mortals however, so the following syntaxes are | ||||
89 | accepted as well: | ||||
90 | |||||
91 | carpout(LOG); | ||||
92 | carpout(main::LOG); | ||||
93 | carpout(main'LOG); | ||||
94 | carpout(\LOG); | ||||
95 | carpout(\'main::LOG'); | ||||
96 | |||||
97 | ... and so on | ||||
98 | |||||
99 | FileHandle and other objects work as well. | ||||
100 | |||||
101 | Use of carpout() is not great for performance, so it is recommended | ||||
102 | for debugging purposes or for moderate-use applications. A future | ||||
103 | version of this module may delay redirecting STDERR until one of the | ||||
104 | CGI::Carp methods is called to prevent the performance hit. | ||||
105 | |||||
106 | =head1 MAKING PERL ERRORS APPEAR IN THE BROWSER WINDOW | ||||
107 | |||||
108 | If you want to send fatal (die, confess) errors to the browser, import | ||||
109 | the special "fatalsToBrowser" subroutine: | ||||
110 | |||||
111 | use CGI::Carp qw(fatalsToBrowser); | ||||
112 | die "Bad error here"; | ||||
113 | |||||
114 | Fatal errors will now be echoed to the browser as well as to the log. | ||||
115 | CGI::Carp arranges to send a minimal HTTP header to the browser so | ||||
116 | that even errors that occur in the early compile phase will be seen. | ||||
117 | Nonfatal errors will still be directed to the log file only (unless | ||||
118 | redirected with carpout). | ||||
119 | |||||
120 | Note that fatalsToBrowser may B<not> work well with mod_perl version 2.0 | ||||
121 | and higher. | ||||
122 | |||||
123 | =head2 Changing the default message | ||||
124 | |||||
125 | By default, the software error message is followed by a note to | ||||
126 | contact the Webmaster by e-mail with the time and date of the error. | ||||
127 | If this message is not to your liking, you can change it using the | ||||
128 | set_message() routine. This is not imported by default; you should | ||||
129 | import it on the use() line: | ||||
130 | |||||
131 | use CGI::Carp qw(fatalsToBrowser set_message); | ||||
132 | set_message("It's not a bug, it's a feature!"); | ||||
133 | |||||
134 | You may also pass in a code reference in order to create a custom | ||||
135 | error message. At run time, your code will be called with the text | ||||
136 | of the error message that caused the script to die. Example: | ||||
137 | |||||
138 | use CGI::Carp qw(fatalsToBrowser set_message); | ||||
139 | BEGIN { | ||||
140 | sub handle_errors { | ||||
141 | my $msg = shift; | ||||
142 | print "<h1>Oh gosh</h1>"; | ||||
143 | print "<p>Got an error: $msg</p>"; | ||||
144 | } | ||||
145 | set_message(\&handle_errors); | ||||
146 | } | ||||
147 | |||||
148 | In order to correctly intercept compile-time errors, you should call | ||||
149 | set_message() from within a BEGIN{} block. | ||||
150 | |||||
151 | =head1 DOING MORE THAN PRINTING A MESSAGE IN THE EVENT OF PERL ERRORS | ||||
152 | |||||
153 | If fatalsToBrowser in conjunction with set_message does not provide | ||||
154 | you with all of the functionality you need, you can go one step | ||||
155 | further by specifying a function to be executed any time a script | ||||
156 | calls "die", has a syntax error, or dies unexpectedly at runtime | ||||
157 | with a line like "undef->explode();". | ||||
158 | |||||
159 | use CGI::Carp qw(set_die_handler); | ||||
160 | BEGIN { | ||||
161 | sub handle_errors { | ||||
162 | my $msg = shift; | ||||
163 | print "content-type: text/html\n\n"; | ||||
164 | print "<h1>Oh gosh</h1>"; | ||||
165 | print "<p>Got an error: $msg</p>"; | ||||
166 | |||||
167 | #proceed to send an email to a system administrator, | ||||
168 | #write a detailed message to the browser and/or a log, | ||||
169 | #etc.... | ||||
170 | } | ||||
171 | set_die_handler(\&handle_errors); | ||||
172 | } | ||||
173 | |||||
174 | Notice that if you use set_die_handler(), you must handle sending | ||||
175 | HTML headers to the browser yourself if you are printing a message. | ||||
176 | |||||
177 | If you use set_die_handler(), you will most likely interfere with | ||||
178 | the behavior of fatalsToBrowser, so you must use this or that, not | ||||
179 | both. | ||||
180 | |||||
181 | Using set_die_handler() sets SIG{__DIE__} (as does fatalsToBrowser), | ||||
182 | and there is only one SIG{__DIE__}. This means that if you are | ||||
183 | attempting to set SIG{__DIE__} yourself, you may interfere with | ||||
184 | this module's functionality, or this module may interfere with | ||||
185 | your module's functionality. | ||||
186 | |||||
187 | =head2 SUPPRESSING PERL ERRORS APPEARING IN THE BROWSER WINDOW | ||||
188 | |||||
189 | A problem sometimes encountered when using fatalsToBrowser is | ||||
190 | when a C<die()> is done inside an C<eval> body or expression. | ||||
191 | Even though the | ||||
192 | fatalsToBrower support takes precautions to avoid this, | ||||
193 | you still may get the error message printed to STDOUT. | ||||
194 | This may have some undesireable effects when the purpose of doing the | ||||
195 | eval is to determine which of several algorithms is to be used. | ||||
196 | |||||
197 | By setting C<$CGI::Carp::TO_BROWSER> to 0 you can suppress printing | ||||
198 | the C<die> messages but without all of the complexity of using | ||||
199 | C<set_die_handler>. You can localize this effect to inside C<eval> | ||||
200 | bodies if this is desireable: For example: | ||||
201 | |||||
202 | eval { | ||||
203 | local $CGI::Carp::TO_BROWSER = 0; | ||||
204 | die "Fatal error messages not sent browser" | ||||
205 | } | ||||
206 | # $@ will contain error message | ||||
207 | |||||
208 | |||||
209 | =head1 MAKING WARNINGS APPEAR AS HTML COMMENTS | ||||
210 | |||||
211 | It is also possible to make non-fatal errors appear as HTML comments | ||||
212 | embedded in the output of your program. To enable this feature, | ||||
213 | export the new "warningsToBrowser" subroutine. Since sending warnings | ||||
214 | to the browser before the HTTP headers have been sent would cause an | ||||
215 | error, any warnings are stored in an internal buffer until you call | ||||
216 | the warningsToBrowser() subroutine with a true argument: | ||||
217 | |||||
218 | use CGI::Carp qw(fatalsToBrowser warningsToBrowser); | ||||
219 | use CGI qw(:standard); | ||||
220 | print header(); | ||||
221 | warningsToBrowser(1); | ||||
222 | |||||
223 | You may also give a false argument to warningsToBrowser() to prevent | ||||
224 | warnings from being sent to the browser while you are printing some | ||||
225 | content where HTML comments are not allowed: | ||||
226 | |||||
227 | warningsToBrowser(0); # disable warnings | ||||
228 | print "<script type=\"text/javascript\"><!--\n"; | ||||
229 | print_some_javascript_code(); | ||||
230 | print "//--></script>\n"; | ||||
231 | warningsToBrowser(1); # re-enable warnings | ||||
232 | |||||
233 | Note: In this respect warningsToBrowser() differs fundamentally from | ||||
234 | fatalsToBrowser(), which you should never call yourself! | ||||
235 | |||||
236 | =head1 OVERRIDING THE NAME OF THE PROGRAM | ||||
237 | |||||
238 | CGI::Carp includes the name of the program that generated the error or | ||||
239 | warning in the messages written to the log and the browser window. | ||||
240 | Sometimes, Perl can get confused about what the actual name of the | ||||
241 | executed program was. In these cases, you can override the program | ||||
242 | name that CGI::Carp will use for all messages. | ||||
243 | |||||
244 | The quick way to do that is to tell CGI::Carp the name of the program | ||||
245 | in its use statement. You can do that by adding | ||||
246 | "name=cgi_carp_log_name" to your "use" statement. For example: | ||||
247 | |||||
248 | use CGI::Carp qw(name=cgi_carp_log_name); | ||||
249 | |||||
250 | . If you want to change the program name partway through the program, | ||||
251 | you can use the C<set_progname()> function instead. It is not | ||||
252 | exported by default, you must import it explicitly by saying | ||||
253 | |||||
254 | use CGI::Carp qw(set_progname); | ||||
255 | |||||
256 | Once you've done that, you can change the logged name of the program | ||||
257 | at any time by calling | ||||
258 | |||||
259 | set_progname(new_program_name); | ||||
260 | |||||
261 | You can set the program back to the default by calling | ||||
262 | |||||
263 | set_progname(undef); | ||||
264 | |||||
265 | Note that this override doesn't happen until after the program has | ||||
266 | compiled, so any compile-time errors will still show up with the | ||||
267 | non-overridden program name | ||||
268 | |||||
269 | =head1 CHANGE LOG | ||||
270 | |||||
271 | 3.51 Added $CGI::Carp::TO_BROWSER | ||||
272 | |||||
273 | 1.29 Patch from Peter Whaite to fix the unfixable problem of CGI::Carp | ||||
274 | not behaving correctly in an eval() context. | ||||
275 | |||||
276 | 1.05 carpout() added and minor corrections by Marc Hedlund | ||||
277 | <hedlund@best.com> on 11/26/95. | ||||
278 | |||||
279 | 1.06 fatalsToBrowser() no longer aborts for fatal errors within | ||||
280 | eval() statements. | ||||
281 | |||||
282 | 1.08 set_message() added and carpout() expanded to allow for FileHandle | ||||
283 | objects. | ||||
284 | |||||
285 | 1.09 set_message() now allows users to pass a code REFERENCE for | ||||
286 | really custom error messages. croak and carp are now | ||||
287 | exported by default. Thanks to Gunther Birznieks for the | ||||
288 | patches. | ||||
289 | |||||
290 | 1.10 Patch from Chris Dean (ctdean@cogit.com) to allow | ||||
291 | module to run correctly under mod_perl. | ||||
292 | |||||
293 | 1.11 Changed order of > and < escapes. | ||||
294 | |||||
295 | 1.12 Changed die() on line 217 to CORE::die to avoid B<-w> warning. | ||||
296 | |||||
297 | 1.13 Added cluck() to make the module orthogonal with Carp. | ||||
298 | More mod_perl related fixes. | ||||
299 | |||||
300 | 1.20 Patch from Ilmari Karonen (perl@itz.pp.sci.fi): Added | ||||
301 | warningsToBrowser(). Replaced <CODE> tags with <PRE> in | ||||
302 | fatalsToBrowser() output. | ||||
303 | |||||
304 | 1.23 ineval() now checks both $^S and inspects the message for the "eval" pattern | ||||
305 | (hack alert!) in order to accommodate various combinations of Perl and | ||||
306 | mod_perl. | ||||
307 | |||||
308 | 1.24 Patch from Scott Gifford (sgifford@suspectclass.com): Add support | ||||
309 | for overriding program name. | ||||
310 | |||||
311 | 1.26 Replaced CORE::GLOBAL::die with the evil $SIG{__DIE__} because the | ||||
312 | former isn't working in some people's hands. There is no such thing | ||||
313 | as reliable exception handling in Perl. | ||||
314 | |||||
315 | 1.27 Replaced tell STDOUT with bytes=tell STDOUT. | ||||
316 | |||||
317 | =head1 AUTHORS | ||||
318 | |||||
319 | Copyright 1995-2002, Lincoln D. Stein. All rights reserved. | ||||
320 | |||||
321 | This library is free software; you can redistribute it and/or modify | ||||
322 | it under the same terms as Perl itself. | ||||
323 | |||||
324 | =head1 SEE ALSO | ||||
325 | |||||
326 | L<Carp>, L<CGI::Base>, L<CGI::BasePlus>, L<CGI::Request>, | ||||
327 | L<CGI::MiniSvr>, L<CGI::Form>, L<CGI::Response>. | ||||
328 | |||||
329 | =cut | ||||
330 | |||||
331 | 1 | 28µs | require 5.000; | ||
332 | 2 | 1.36ms | 2 | 1.46ms | # spent 1.40ms (1.35+56µs) within CGI::Carp::BEGIN@332 which was called:
# once (1.35ms+56µs) by main::BEGIN@9 at line 332 # spent 1.40ms making 1 call to CGI::Carp::BEGIN@332
# spent 56µs making 1 call to Exporter::import |
333 | #use Carp; | ||||
334 | # spent 5.37ms (4.92+446µs) within CGI::Carp::BEGIN@334 which was called:
# once (4.92ms+446µs) by main::BEGIN@9 at line 337 | ||||
335 | 1 | 130µs | require Carp; | ||
336 | 1 | 20µs | *CORE::GLOBAL::die = \&CGI::Carp::die; | ||
337 | 1 | 40µs | 1 | 5.37ms | } # spent 5.37ms making 1 call to CGI::Carp::BEGIN@334 |
338 | |||||
339 | 2 | 3.12ms | 1 | 5.23ms | # spent 5.23ms (3.59+1.63) within CGI::Carp::BEGIN@339 which was called:
# once (3.59ms+1.63ms) by main::BEGIN@9 at line 339 # spent 5.23ms making 1 call to CGI::Carp::BEGIN@339 |
340 | |||||
341 | 1 | 13µs | @ISA = qw(Exporter); | ||
342 | 1 | 2µs | @EXPORT = qw(confess croak carp); | ||
343 | 1 | 3µs | @EXPORT_OK = qw(carpout fatalsToBrowser warningsToBrowser wrap set_message set_die_handler set_progname cluck ^name= die); | ||
344 | |||||
345 | 1 | 3µs | $main::SIG{__WARN__}=\&CGI::Carp::warn; | ||
346 | |||||
347 | 1 | 600ns | $CGI::Carp::VERSION = '3.51'; | ||
348 | 1 | 400ns | $CGI::Carp::CUSTOM_MSG = undef; | ||
349 | 1 | 200ns | $CGI::Carp::DIE_HANDLER = undef; | ||
350 | 1 | 400ns | $CGI::Carp::TO_BROWSER = 1; | ||
351 | |||||
352 | |||||
353 | # fancy import routine detects and handles 'errorWrap' specially. | ||||
354 | # spent 107µs (39+67) within CGI::Carp::import which was called:
# once (39µs+67µs) by main::BEGIN@9 at line 9 of view | ||||
355 | 1 | 1µs | my $pkg = shift; | ||
356 | 1 | 300ns | my(%routines); | ||
357 | 1 | 400ns | my(@name); | ||
358 | 1 | 7µs | if (@name=grep(/^name=/,@_)) | ||
359 | { | ||||
360 | my($n) = (split(/=/,$name[0]))[1]; | ||||
361 | set_progname($n); | ||||
362 | @_=grep(!/^name=/,@_); | ||||
363 | } | ||||
364 | |||||
365 | 1 | 5µs | grep($routines{$_}++,@_,@EXPORT); | ||
366 | 1 | 1µs | $WRAP++ if $routines{'fatalsToBrowser'} || $routines{'wrap'}; | ||
367 | 1 | 500ns | $WARN++ if $routines{'warningsToBrowser'}; | ||
368 | 1 | 700ns | my($oldlevel) = $Exporter::ExportLevel; | ||
369 | 1 | 200ns | $Exporter::ExportLevel = 1; | ||
370 | 1 | 5µs | 1 | 68µs | Exporter::import($pkg,keys %routines); # spent 68µs making 1 call to Exporter::import |
371 | 1 | 300ns | $Exporter::ExportLevel = $oldlevel; | ||
372 | 1 | 13µs | $main::SIG{__DIE__} =\&CGI::Carp::die if $routines{'fatalsToBrowser'}; | ||
373 | # $pkg->export('CORE::GLOBAL','die'); | ||||
374 | } | ||||
375 | |||||
376 | # These are the originals | ||||
377 | 2 | 54µs | # spent 49µs within CGI::Carp::realwarn which was called 2 times, avg 25µs/call:
# 2 times (49µs+0s) by CGI::Carp::warn at line 416, avg 25µs/call | ||
378 | sub realdie { CORE::die(@_); } | ||||
379 | |||||
380 | # spent 65µs (41+24) within CGI::Carp::id which was called 2 times, avg 32µs/call:
# 2 times (41µs+24µs) by CGI::Carp::warn at line 411, avg 32µs/call | ||||
381 | 2 | 700ns | my $level = shift; | ||
382 | 2 | 15µs | my($pack,$file,$line,$sub) = caller($level); | ||
383 | 2 | 12µs | 2 | 24µs | my($dev,$dirs,$id) = File::Spec->splitpath($file); # spent 24µs making 2 calls to File::Spec::Unix::splitpath, avg 12µs/call |
384 | 2 | 9µs | return ($file,$line,$id); | ||
385 | } | ||||
386 | |||||
387 | # spent 245µs (231+14) within CGI::Carp::stamp which was called 2 times, avg 122µs/call:
# 2 times (231µs+14µs) by CGI::Carp::warn at line 414, avg 122µs/call | ||||
388 | 2 | 41µs | my $time = scalar(localtime); | ||
389 | 2 | 900ns | my $frame = 0; | ||
390 | 2 | 2µs | my ($id,$pack,$file,$dev,$dirs); | ||
391 | 2 | 1µs | if (defined($CGI::Carp::PROGNAME)) { | ||
392 | $id = $CGI::Carp::PROGNAME; | ||||
393 | } else { | ||||
394 | 2 | 26µs | do { | ||
395 | 34 | 5µs | $id = $file; | ||
396 | 34 | 135µs | ($pack,$file) = caller($frame++); | ||
397 | } until !$file; | ||||
398 | } | ||||
399 | 2 | 9µs | 2 | 14µs | ($dev,$dirs,$id) = File::Spec->splitpath($id); # spent 14µs making 2 calls to File::Spec::Unix::splitpath, avg 7µs/call |
400 | 2 | 9µs | return "[$time] $id: "; | ||
401 | } | ||||
402 | |||||
403 | sub set_progname { | ||||
404 | $CGI::Carp::PROGNAME = shift; | ||||
405 | return $CGI::Carp::PROGNAME; | ||||
406 | } | ||||
407 | |||||
408 | |||||
409 | # spent 405µs (46+359) within CGI::Carp::warn which was called 2 times, avg 203µs/call:
# once (29µs+207µs) by Foswiki::Plugin::BEGIN@2.6 at line 90 of /var/www/foswiki11/lib/Foswiki/Plugins/ChartPlugin.pm
# once (17µs+152µs) by Foswiki::Plugin::BEGIN@2.19 at line 248 of /var/www/foswiki11/lib/Foswiki/Plugins/JHotDrawPlugin.pm | ||||
410 | 2 | 1µs | my $message = shift; | ||
411 | 2 | 6µs | 2 | 65µs | my($file,$line,$id) = id(1); # spent 65µs making 2 calls to CGI::Carp::id, avg 32µs/call |
412 | 2 | 5µs | $message .= " at $file line $line.\n" unless $message=~/\n$/; | ||
413 | 2 | 800ns | _warn($message) if $WARN; | ||
414 | 2 | 4µs | 2 | 245µs | my $stamp = stamp; # spent 245µs making 2 calls to CGI::Carp::stamp, avg 122µs/call |
415 | 2 | 7µs | $message=~s/^/$stamp/gm; | ||
416 | 2 | 13µs | 2 | 49µs | realwarn $message; # spent 49µs making 2 calls to CGI::Carp::realwarn, avg 25µs/call |
417 | } | ||||
418 | |||||
419 | sub _warn { | ||||
420 | my $msg = shift; | ||||
421 | if ($EMIT_WARNINGS) { | ||||
422 | # We need to mangle the message a bit to make it a valid HTML | ||||
423 | # comment. This is done by substituting similar-looking ISO | ||||
424 | # 8859-1 characters for <, > and -. This is a hack. | ||||
425 | $msg =~ tr/<>-/\253\273\255/; | ||||
426 | chomp $msg; | ||||
427 | print STDOUT "<!-- warning: $msg -->\n"; | ||||
428 | } else { | ||||
429 | push @WARNINGS, $msg; | ||||
430 | } | ||||
431 | } | ||||
432 | |||||
433 | |||||
434 | # The mod_perl package Apache::Registry loads CGI programs by calling | ||||
435 | # eval. These evals don't count when looking at the stack backtrace. | ||||
436 | sub _longmess { | ||||
437 | my $message = Carp::longmess(); | ||||
438 | $message =~ s,eval[^\n]+(ModPerl|Apache)/(?:Registry|Dispatch)\w*\.pm.*,,s | ||||
439 | if exists $ENV{MOD_PERL}; | ||||
440 | return $message; | ||||
441 | } | ||||
442 | |||||
443 | sub ineval { | ||||
444 | (exists $ENV{MOD_PERL} ? 0 : $^S) || _longmess() =~ /eval [\{\']/m | ||||
445 | } | ||||
446 | |||||
447 | sub die { | ||||
448 | # if no argument is passed, propagate $@ like | ||||
449 | # the real die | ||||
450 | my ($arg,@rest) = @_ ? @_ | ||||
451 | : $@ ? "$@\t...propagated" | ||||
452 | : "Died" | ||||
453 | ; | ||||
454 | |||||
455 | &$DIE_HANDLER($arg,@rest) if $DIE_HANDLER; | ||||
456 | |||||
457 | # the "$arg" is done on purpose! | ||||
458 | # if called as die( $object, 'string' ), | ||||
459 | # all is stringified, just like with | ||||
460 | # the real 'die' | ||||
461 | $arg = join '' => "$arg", @rest if @rest; | ||||
462 | |||||
463 | my($file,$line,$id) = id(1); | ||||
464 | |||||
465 | $arg .= " at $file line $line.\n" unless ref $arg or $arg=~/\n$/; | ||||
466 | |||||
467 | realdie $arg if ineval(); | ||||
468 | &fatalsToBrowser($arg) if ($WRAP and $CGI::Carp::TO_BROWSER); | ||||
469 | |||||
470 | $arg=~s/^/ stamp() /gme if $arg =~ /\n$/ or not exists $ENV{MOD_PERL}; | ||||
471 | |||||
472 | $arg .= "\n" unless $arg =~ /\n$/; | ||||
473 | |||||
474 | realdie $arg; | ||||
475 | } | ||||
476 | |||||
477 | sub set_message { | ||||
478 | $CGI::Carp::CUSTOM_MSG = shift; | ||||
479 | return $CGI::Carp::CUSTOM_MSG; | ||||
480 | } | ||||
481 | |||||
482 | sub set_die_handler { | ||||
483 | |||||
484 | my ($handler) = shift; | ||||
485 | |||||
486 | #setting SIG{__DIE__} here is necessary to catch runtime | ||||
487 | #errors which are not called by literally saying "die", | ||||
488 | #such as the line "undef->explode();". however, doing this | ||||
489 | #will interfere with fatalsToBrowser, which also sets | ||||
490 | #SIG{__DIE__} in the import() function above (or the | ||||
491 | #import() function above may interfere with this). for | ||||
492 | #this reason, you should choose to either set the die | ||||
493 | #handler here, or use fatalsToBrowser, not both. | ||||
494 | $main::SIG{__DIE__} = $handler; | ||||
495 | |||||
496 | $CGI::Carp::DIE_HANDLER = $handler; | ||||
497 | |||||
498 | return $CGI::Carp::DIE_HANDLER; | ||||
499 | } | ||||
500 | |||||
501 | sub confess { CGI::Carp::die Carp::longmess @_; } | ||||
502 | sub croak { CGI::Carp::die Carp::shortmess @_; } | ||||
503 | sub carp { CGI::Carp::warn Carp::shortmess @_; } | ||||
504 | sub cluck { CGI::Carp::warn Carp::longmess @_; } | ||||
505 | |||||
506 | # We have to be ready to accept a filehandle as a reference | ||||
507 | # or a string. | ||||
508 | sub carpout { | ||||
509 | my($in) = @_; | ||||
510 | my($no) = fileno(to_filehandle($in)); | ||||
511 | realdie("Invalid filehandle $in\n") unless defined $no; | ||||
512 | |||||
513 | open(SAVEERR, ">&STDERR"); | ||||
514 | open(STDERR, ">&$no") or | ||||
515 | ( print SAVEERR "Unable to redirect STDERR: $!\n" and exit(1) ); | ||||
516 | } | ||||
517 | |||||
518 | sub warningsToBrowser { | ||||
519 | $EMIT_WARNINGS = @_ ? shift : 1; | ||||
520 | _warn(shift @WARNINGS) while $EMIT_WARNINGS and @WARNINGS; | ||||
521 | } | ||||
522 | |||||
523 | # headers | ||||
524 | sub fatalsToBrowser { | ||||
525 | my $msg = shift; | ||||
526 | |||||
527 | $msg = "$msg" if ref $msg; | ||||
528 | |||||
529 | $msg=~s/&/&/g; | ||||
530 | $msg=~s/>/>/g; | ||||
531 | $msg=~s/</</g; | ||||
532 | $msg=~s/"/"/g; | ||||
533 | |||||
534 | my($wm) = $ENV{SERVER_ADMIN} ? | ||||
535 | qq[the webmaster (<a href="mailto:$ENV{SERVER_ADMIN}">$ENV{SERVER_ADMIN}</a>)] : | ||||
536 | "this site's webmaster"; | ||||
537 | my ($outer_message) = <<END; | ||||
538 | For help, please send mail to $wm, giving this error message | ||||
539 | and the time and date of the error. | ||||
540 | END | ||||
541 | ; | ||||
542 | my $mod_perl = exists $ENV{MOD_PERL}; | ||||
543 | |||||
544 | if ($CUSTOM_MSG) { | ||||
545 | if (ref($CUSTOM_MSG) eq 'CODE') { | ||||
546 | print STDOUT "Content-type: text/html\n\n" | ||||
547 | unless $mod_perl; | ||||
548 | eval { | ||||
549 | &$CUSTOM_MSG($msg); # nicer to perl 5.003 users | ||||
550 | }; | ||||
551 | if ($@) { print STDERR q(error while executing the error handler: $@); } | ||||
552 | |||||
553 | return; | ||||
554 | } else { | ||||
555 | $outer_message = $CUSTOM_MSG; | ||||
556 | } | ||||
557 | } | ||||
558 | |||||
559 | my $mess = <<END; | ||||
560 | <h1>Software error:</h1> | ||||
561 | <pre>$msg</pre> | ||||
562 | <p> | ||||
563 | $outer_message | ||||
564 | </p> | ||||
565 | END | ||||
566 | ; | ||||
567 | |||||
568 | if ($mod_perl) { | ||||
569 | my $r; | ||||
570 | if ($ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) { | ||||
571 | $mod_perl = 2; | ||||
572 | require Apache2::RequestRec; | ||||
573 | require Apache2::RequestIO; | ||||
574 | require Apache2::RequestUtil; | ||||
575 | require APR::Pool; | ||||
576 | require ModPerl::Util; | ||||
577 | require Apache2::Response; | ||||
578 | $r = Apache2::RequestUtil->request; | ||||
579 | } | ||||
580 | else { | ||||
581 | $r = Apache->request; | ||||
582 | } | ||||
583 | # If bytes have already been sent, then | ||||
584 | # we print the message out directly. | ||||
585 | # Otherwise we make a custom error | ||||
586 | # handler to produce the doc for us. | ||||
587 | if ($r->bytes_sent) { | ||||
588 | $r->print($mess); | ||||
589 | $mod_perl == 2 ? ModPerl::Util::exit(0) : $r->exit; | ||||
590 | } else { | ||||
591 | # MSIE won't display a custom 500 response unless it is >512 bytes! | ||||
592 | if ($ENV{HTTP_USER_AGENT} =~ /MSIE/) { | ||||
593 | $mess = "<!-- " . (' ' x 513) . " -->\n$mess"; | ||||
594 | } | ||||
595 | $r->custom_response(500,$mess); | ||||
596 | } | ||||
597 | } else { | ||||
598 | my $bytes_written = eval{tell STDOUT}; | ||||
599 | if (defined $bytes_written && $bytes_written > 0) { | ||||
600 | print STDOUT $mess; | ||||
601 | } | ||||
602 | else { | ||||
603 | print STDOUT "Status: 500\n"; | ||||
604 | print STDOUT "Content-type: text/html\n\n"; | ||||
605 | print STDOUT $mess; | ||||
606 | } | ||||
607 | } | ||||
608 | |||||
609 | warningsToBrowser(1); # emit warnings before dying | ||||
610 | } | ||||
611 | |||||
612 | # Cut and paste from CGI.pm so that we don't have the overhead of | ||||
613 | # always loading the entire CGI module. | ||||
614 | sub to_filehandle { | ||||
615 | my $thingy = shift; | ||||
616 | return undef unless $thingy; | ||||
617 | return $thingy if UNIVERSAL::isa($thingy,'GLOB'); | ||||
618 | return $thingy if UNIVERSAL::isa($thingy,'FileHandle'); | ||||
619 | if (!ref($thingy)) { | ||||
620 | my $caller = 1; | ||||
621 | while (my $package = caller($caller++)) { | ||||
622 | my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy"; | ||||
623 | return $tmp if defined(fileno($tmp)); | ||||
624 | } | ||||
625 | } | ||||
626 | return undef; | ||||
627 | } | ||||
628 | |||||
629 | 1 | 15µs | 1; |