Commit | Line | Data |
---|---|---|
0b09a93a PF |
1 | package autodie::exception; |
2 | use 5.008; | |
3 | use strict; | |
4 | use warnings; | |
5 | use Carp qw(croak); | |
6 | ||
ea6c7d00 CBW |
7 | use Scalar::Util qw(blessed); |
8 | ||
e2070c24 | 9 | our $VERSION = '2.37'; # VERSION: Generated by DZP::OurPkg:Version |
273225d4 CBW |
10 | # ABSTRACT: Exceptions from autodying functions. |
11 | ||
0b09a93a PF |
12 | our $DEBUG = 0; |
13 | ||
14 | use overload | |
ebf27bc8 CBW |
15 | q{""} => "stringify", |
16 | # Overload smart-match only if we're using 5.10 or up | |
e2070c24 TR |
17 | (( $] >= 5.010 && $] < 5.041 ) ? ('~~' => "matches") : ()), |
18 | fallback => 1, | |
0b09a93a PF |
19 | ; |
20 | ||
0b09a93a PF |
21 | my $PACKAGE = __PACKAGE__; # Useful to have a scalar for hash keys. |
22 | ||
23 | =head1 NAME | |
24 | ||
25 | autodie::exception - Exceptions from autodying functions. | |
26 | ||
27 | =head1 SYNOPSIS | |
28 | ||
29 | eval { | |
30 | use autodie; | |
31 | ||
32 | open(my $fh, '<', 'some_file.txt'); | |
33 | ||
34 | ... | |
35 | }; | |
36 | ||
37 | if (my $E = $@) { | |
38 | say "Ooops! ",$E->caller," had problems: $@"; | |
39 | } | |
40 | ||
41 | ||
42 | =head1 DESCRIPTION | |
43 | ||
44 | When an L<autodie> enabled function fails, it generates an | |
45 | C<autodie::exception> object. This can be interrogated to | |
46 | determine further information about the error that occurred. | |
47 | ||
48 | This document is broken into two sections; those methods that | |
49 | are most useful to the end-developer, and those methods for | |
50 | anyone wishing to subclass or get very familiar with | |
51 | C<autodie::exception>. | |
52 | ||
53 | =head2 Common Methods | |
54 | ||
55 | These methods are intended to be used in the everyday dealing | |
56 | of exceptions. | |
57 | ||
58 | The following assume that the error has been copied into | |
59 | a separate scalar: | |
60 | ||
61 | if ($E = $@) { | |
62 | ... | |
63 | } | |
64 | ||
65 | This is not required, but is recommended in case any code | |
66 | is called which may reset or alter C<$@>. | |
67 | ||
68 | =cut | |
69 | ||
70 | =head3 args | |
71 | ||
72 | my $array_ref = $E->args; | |
73 | ||
74 | Provides a reference to the arguments passed to the subroutine | |
75 | that died. | |
76 | ||
77 | =cut | |
78 | ||
79 | sub args { return $_[0]->{$PACKAGE}{args}; } | |
80 | ||
81 | =head3 function | |
82 | ||
83 | my $sub = $E->function; | |
84 | ||
85 | The subroutine (including package) that threw the exception. | |
86 | ||
87 | =cut | |
88 | ||
89 | sub function { return $_[0]->{$PACKAGE}{function}; } | |
90 | ||
91 | =head3 file | |
92 | ||
93 | my $file = $E->file; | |
94 | ||
95 | The file in which the error occurred (eg, C<myscript.pl> or | |
96 | C<MyTest.pm>). | |
97 | ||
98 | =cut | |
99 | ||
100 | sub file { return $_[0]->{$PACKAGE}{file}; } | |
101 | ||
102 | =head3 package | |
103 | ||
104 | my $package = $E->package; | |
105 | ||
106 | The package from which the exceptional subroutine was called. | |
107 | ||
108 | =cut | |
109 | ||
110 | sub package { return $_[0]->{$PACKAGE}{package}; } | |
111 | ||
112 | =head3 caller | |
113 | ||
114 | my $caller = $E->caller; | |
115 | ||
116 | The subroutine that I<called> the exceptional code. | |
117 | ||
118 | =cut | |
119 | ||
120 | sub caller { return $_[0]->{$PACKAGE}{caller}; } | |
121 | ||
122 | =head3 line | |
123 | ||
124 | my $line = $E->line; | |
125 | ||
126 | The line in C<< $E->file >> where the exceptional code was called. | |
127 | ||
128 | =cut | |
129 | ||
130 | sub line { return $_[0]->{$PACKAGE}{line}; } | |
131 | ||
eb8d423f PF |
132 | =head3 context |
133 | ||
134 | my $context = $E->context; | |
135 | ||
273225d4 CBW |
136 | The context in which the subroutine was called by autodie; usually |
137 | the same as the context in which you called the autodying subroutine. | |
138 | This can be 'list', 'scalar', or undefined (unknown). It will never | |
139 | be 'void', as C<autodie> always captures the return value in one way | |
140 | or another. | |
141 | ||
142 | For some core functions that always return a scalar value regardless | |
143 | of their context (eg, C<chown>), this may be 'scalar', even if you | |
144 | used a list context. | |
eb8d423f PF |
145 | |
146 | =cut | |
147 | ||
273225d4 CBW |
148 | # TODO: The comments above say this can be undefined. Is that actually |
149 | # the case? (With 'system', perhaps?) | |
150 | ||
eb8d423f PF |
151 | sub context { return $_[0]->{$PACKAGE}{context} } |
152 | ||
153 | =head3 return | |
154 | ||
155 | my $return_value = $E->return; | |
156 | ||
157 | The value(s) returned by the failed subroutine. When the subroutine | |
158 | was called in a list context, this will always be a reference to an | |
159 | array containing the results. When the subroutine was called in | |
160 | a scalar context, this will be the actual scalar returned. | |
161 | ||
162 | =cut | |
163 | ||
164 | sub return { return $_[0]->{$PACKAGE}{return} } | |
165 | ||
0b09a93a PF |
166 | =head3 errno |
167 | ||
168 | my $errno = $E->errno; | |
169 | ||
170 | The value of C<$!> at the time when the exception occurred. | |
171 | ||
172 | B<NOTE>: This method will leave the main C<autodie::exception> class | |
173 | and become part of a role in the future. You should only call | |
174 | C<errno> for exceptions where C<$!> would reasonably have been | |
175 | set on failure. | |
176 | ||
177 | =cut | |
178 | ||
179 | # TODO: Make errno part of a role. It doesn't make sense for | |
180 | # everything. | |
181 | ||
182 | sub errno { return $_[0]->{$PACKAGE}{errno}; } | |
183 | ||
7840a289 DM |
184 | =head3 eval_error |
185 | ||
186 | my $old_eval_error = $E->eval_error; | |
187 | ||
188 | The contents of C<$@> immediately after autodie triggered an | |
189 | exception. This may be useful when dealing with modules such | |
190 | as L<Text::Balanced> that set (but do not throw) C<$@> on error. | |
191 | ||
192 | =cut | |
193 | ||
194 | sub eval_error { return $_[0]->{$PACKAGE}{eval_error}; } | |
195 | ||
0b09a93a PF |
196 | =head3 matches |
197 | ||
198 | if ( $e->matches('open') ) { ... } | |
199 | ||
5f3202fa | 200 | if ( 'open' ~~ $e ) { ... } |
0b09a93a PF |
201 | |
202 | C<matches> is used to determine whether a | |
5f3202fa | 203 | given exception matches a particular role. |
0b09a93a PF |
204 | |
205 | An exception is considered to match a string if: | |
206 | ||
207 | =over 4 | |
208 | ||
209 | =item * | |
210 | ||
211 | For a string not starting with a colon, the string exactly matches the | |
212 | package and subroutine that threw the exception. For example, | |
213 | C<MyModule::log>. If the string does not contain a package name, | |
214 | C<CORE::> is assumed. | |
215 | ||
216 | =item * | |
217 | ||
218 | For a string that does start with a colon, if the subroutine | |
219 | throwing the exception I<does> that behaviour. For example, the | |
220 | C<CORE::open> subroutine does C<:file>, C<:io> and C<:all>. | |
221 | ||
273225d4 | 222 | See L<autodie/CATEGORIES> for further information. |
0b09a93a | 223 | |
5f3202fa Z |
224 | On Perl 5.10 and above, using smart-match (C<~~>) with an |
225 | C<autodie::exception> object will use C<matches> underneath. This module | |
226 | used to recommend using smart-match with the exception object on the left | |
569476d5 Z |
227 | hand side, but in future Perls that is likely to stop working. |
228 | The smart-match facility of this class should only be used with the | |
229 | exception object on the right hand side. Having the exception object on | |
230 | the right is both future-proof and portable to older Perls, back to 5.10. | |
231 | Beware that this facility can only | |
5f3202fa Z |
232 | be relied upon when it is certain that the exception object actually is |
233 | an C<autodie::exception> object; it is no more capable than an explicit | |
234 | call to the C<matches> method. | |
235 | ||
0b09a93a PF |
236 | =back |
237 | ||
238 | =cut | |
239 | ||
240 | { | |
241 | my (%cache); | |
242 | ||
243 | sub matches { | |
244 | my ($this, $that) = @_; | |
245 | ||
9b657a62 | 246 | # TODO - Handle references |
0b09a93a PF |
247 | croak "UNIMPLEMENTED" if ref $that; |
248 | ||
249 | my $sub = $this->function; | |
250 | ||
251 | if ($DEBUG) { | |
252 | my $sub2 = $this->function; | |
253 | warn "Smart-matching $that against $sub / $sub2\n"; | |
254 | } | |
255 | ||
256 | # Direct subname match. | |
257 | return 1 if $that eq $sub; | |
258 | return 1 if $that !~ /:/ and "CORE::$that" eq $sub; | |
259 | return 0 if $that !~ /^:/; | |
260 | ||
261 | # Cached match / check tags. | |
262 | require Fatal; | |
263 | ||
264 | if (exists $cache{$sub}{$that}) { | |
265 | return $cache{$sub}{$that}; | |
266 | } | |
267 | ||
268 | # This rather awful looking line checks to see if our sub is in the | |
269 | # list of expanded tags, caches it, and returns the result. | |
270 | ||
271 | return $cache{$sub}{$that} = grep { $_ eq $sub } @{ $this->_expand_tag($that) }; | |
272 | } | |
273 | } | |
274 | ||
275 | # This exists primarily so that child classes can override or | |
276 | # augment it if they wish. | |
277 | ||
278 | sub _expand_tag { | |
279 | my ($this, @args) = @_; | |
280 | ||
281 | return Fatal->_expand_tag(@args); | |
282 | } | |
283 | ||
284 | =head2 Advanced methods | |
285 | ||
286 | The following methods, while usable from anywhere, are primarily | |
287 | intended for developers wishing to subclass C<autodie::exception>, | |
288 | write code that registers custom error messages, or otherwise | |
289 | work closely with the C<autodie::exception> model. | |
290 | ||
291 | =cut | |
292 | ||
293 | # The table below records customer formatters. | |
294 | # TODO - Should this be a package var instead? | |
295 | # TODO - Should these be in a completely different file, or | |
296 | # perhaps loaded on demand? Most formatters will never | |
297 | # get used in most programs. | |
298 | ||
299 | my %formatter_of = ( | |
ebf27bc8 CBW |
300 | 'CORE::close' => \&_format_close, |
301 | 'CORE::open' => \&_format_open, | |
302 | 'CORE::dbmopen' => \&_format_dbmopen, | |
303 | 'CORE::flock' => \&_format_flock, | |
304 | 'CORE::read' => \&_format_readwrite, | |
305 | 'CORE::sysread' => \&_format_readwrite, | |
306 | 'CORE::syswrite' => \&_format_readwrite, | |
35c0561a CBW |
307 | 'CORE::chmod' => \&_format_chmod, |
308 | 'CORE::mkdir' => \&_format_mkdir, | |
0b09a93a PF |
309 | ); |
310 | ||
35c0561a CBW |
311 | sub _beautify_arguments { |
312 | shift @_; | |
313 | ||
314 | # Walk through all our arguments, and... | |
315 | # | |
316 | # * Replace undef with the word 'undef' | |
317 | # * Replace globs with the string '$fh' | |
318 | # * Quote all other args. | |
319 | foreach my $arg (@_) { | |
320 | if (not defined($arg)) { $arg = 'undef' } | |
321 | elsif (ref($arg) eq "GLOB") { $arg = '$fh' } | |
322 | else { $arg = qq{'$arg'} } | |
323 | } | |
324 | ||
325 | return @_; | |
326 | } | |
327 | ||
328 | sub _trim_package_name { | |
329 | # Info: The following is done since 05/2008 (which is before v1.10) | |
330 | ||
331 | # TODO: This is probably a good idea for CORE, is it | |
332 | # a good idea for other subs? | |
333 | ||
334 | # Trim package name off dying sub for error messages | |
335 | (my $name = $_[1]) =~ s/.*:://; | |
336 | return $name; | |
337 | } | |
338 | ||
339 | # Returns the parameter formatted as octal number | |
340 | sub _octalize_number { | |
341 | my $number = $_[1]; | |
342 | ||
343 | # Only reformat if it looks like a whole number | |
344 | if ($number =~ /^\d+$/) { | |
345 | $number = sprintf("%#04lo", $number); | |
346 | } | |
347 | ||
348 | return $number; | |
349 | } | |
350 | ||
0b09a93a PF |
351 | # TODO: Our tests only check LOCK_EX | LOCK_NB is properly |
352 | # formatted. Try other combinations and ensure they work | |
353 | # correctly. | |
354 | ||
355 | sub _format_flock { | |
356 | my ($this) = @_; | |
357 | ||
358 | require Fcntl; | |
359 | ||
360 | my $filehandle = $this->args->[0]; | |
361 | my $raw_mode = $this->args->[1]; | |
362 | ||
363 | my $mode_type; | |
364 | my $lock_unlock; | |
365 | ||
366 | if ($raw_mode & Fcntl::LOCK_EX() ) { | |
367 | $lock_unlock = "lock"; | |
368 | $mode_type = "for exclusive access"; | |
369 | } | |
370 | elsif ($raw_mode & Fcntl::LOCK_SH() ) { | |
371 | $lock_unlock = "lock"; | |
372 | $mode_type = "for shared access"; | |
373 | } | |
374 | elsif ($raw_mode & Fcntl::LOCK_UN() ) { | |
375 | $lock_unlock = "unlock"; | |
376 | $mode_type = ""; | |
377 | } | |
378 | else { | |
379 | # I've got no idea what they're trying to do. | |
380 | $lock_unlock = "lock"; | |
381 | $mode_type = "with mode $raw_mode"; | |
382 | } | |
383 | ||
384 | my $cooked_filehandle; | |
385 | ||
386 | if ($filehandle and not ref $filehandle) { | |
387 | ||
388 | # A package filehandle with a name! | |
389 | ||
390 | $cooked_filehandle = " $filehandle"; | |
391 | } | |
392 | else { | |
393 | # Otherwise we have a scalar filehandle. | |
394 | ||
395 | $cooked_filehandle = ''; | |
396 | ||
397 | } | |
398 | ||
399 | local $! = $this->errno; | |
400 | ||
401 | return "Can't $lock_unlock filehandle$cooked_filehandle $mode_type: $!"; | |
402 | ||
403 | } | |
404 | ||
35c0561a CBW |
405 | # Default formatter for CORE::chmod |
406 | sub _format_chmod { | |
407 | my ($this) = @_; | |
408 | my @args = @{$this->args}; | |
409 | ||
410 | my $mode = shift @args; | |
411 | local $! = $this->errno; | |
412 | ||
413 | $mode = $this->_octalize_number($mode); | |
414 | ||
415 | @args = $this->_beautify_arguments(@args); | |
416 | ||
417 | return "Can't chmod($mode, ". join(q{, }, @args) ."): $!"; | |
418 | } | |
419 | ||
420 | # Default formatter for CORE::mkdir | |
421 | sub _format_mkdir { | |
422 | my ($this) = @_; | |
423 | my @args = @{$this->args}; | |
424 | ||
425 | # If no mask is specified use default formatter | |
426 | if (@args < 2) { | |
427 | return $this->format_default; | |
428 | } | |
429 | ||
430 | my $file = $args[0]; | |
431 | my $mask = $args[1]; | |
432 | local $! = $this->errno; | |
433 | ||
434 | $mask = $this->_octalize_number($mask); | |
435 | ||
436 | return "Can't mkdir('$file', $mask): '$!'"; | |
437 | } | |
438 | ||
0b09a93a PF |
439 | # Default formatter for CORE::dbmopen |
440 | sub _format_dbmopen { | |
441 | my ($this) = @_; | |
442 | my @args = @{$this->args}; | |
443 | ||
444 | # TODO: Presently, $args flattens out the (usually empty) hash | |
445 | # which is passed as the first argument to dbmopen. This is | |
446 | # a bug in our args handling code (taking a reference to it would | |
447 | # be better), but for the moment we'll just examine the end of | |
448 | # our arguments list for message formatting. | |
449 | ||
450 | my $mode = $args[-1]; | |
451 | my $file = $args[-2]; | |
452 | ||
35c0561a | 453 | $mode = $this->_octalize_number($mode); |
0b09a93a PF |
454 | |
455 | local $! = $this->errno; | |
456 | ||
457 | return "Can't dbmopen(%hash, '$file', $mode): '$!'"; | |
458 | } | |
459 | ||
460 | # Default formatter for CORE::close | |
461 | ||
462 | sub _format_close { | |
463 | my ($this) = @_; | |
464 | my $close_arg = $this->args->[0]; | |
465 | ||
466 | local $! = $this->errno; | |
467 | ||
468 | # If we've got an old-style filehandle, mention it. | |
469 | if ($close_arg and not ref $close_arg) { | |
470 | return "Can't close filehandle '$close_arg': '$!'"; | |
471 | } | |
472 | ||
473 | # TODO - This will probably produce an ugly error. Test and fix. | |
474 | return "Can't close($close_arg) filehandle: '$!'"; | |
475 | ||
476 | } | |
477 | ||
ebf27bc8 CBW |
478 | # Default formatter for CORE::read, CORE::sysread and CORE::syswrite |
479 | # | |
480 | # Similar to default formatter with the buffer filtered out as it | |
481 | # may contain binary data. | |
482 | sub _format_readwrite { | |
483 | my ($this) = @_; | |
35c0561a | 484 | my $call = $this->_trim_package_name($this->function); |
ebf27bc8 CBW |
485 | local $! = $this->errno; |
486 | ||
ebf27bc8 CBW |
487 | # These subs receive the following arguments (in order): |
488 | # | |
489 | # * FILEHANDLE | |
490 | # * SCALAR (buffer, we do not want to write this) | |
491 | # * LENGTH (optional for syswrite) | |
492 | # * OFFSET (optional for all) | |
493 | my (@args) = @{$this->args}; | |
494 | my $arg_name = $args[1]; | |
495 | if (defined($arg_name)) { | |
496 | if (ref($arg_name)) { | |
497 | my $name = blessed($arg_name) || ref($arg_name); | |
498 | $arg_name = "<${name}>"; | |
499 | } else { | |
500 | $arg_name = '<BUFFER>'; | |
501 | } | |
502 | } else { | |
503 | $arg_name = '<UNDEF>'; | |
504 | } | |
505 | $args[1] = $arg_name; | |
506 | ||
507 | return "Can't $call(" . join(q{, }, @args) . "): $!"; | |
508 | } | |
509 | ||
0b09a93a PF |
510 | # Default formatter for CORE::open |
511 | ||
512 | use constant _FORMAT_OPEN => "Can't open '%s' for %s: '%s'"; | |
513 | ||
514 | sub _format_open_with_mode { | |
515 | my ($this, $mode, $file, $error) = @_; | |
516 | ||
517 | my $wordy_mode; | |
518 | ||
519 | if ($mode eq '<') { $wordy_mode = 'reading'; } | |
520 | elsif ($mode eq '>') { $wordy_mode = 'writing'; } | |
521 | elsif ($mode eq '>>') { $wordy_mode = 'appending'; } | |
522 | ||
c7e47358 CBW |
523 | $file = '<undef>' if not defined $file; |
524 | ||
0b09a93a PF |
525 | return sprintf _FORMAT_OPEN, $file, $wordy_mode, $error if $wordy_mode; |
526 | ||
527 | Carp::confess("Internal autodie::exception error: Don't know how to format mode '$mode'."); | |
528 | ||
529 | } | |
530 | ||
531 | sub _format_open { | |
532 | my ($this) = @_; | |
533 | ||
534 | my @open_args = @{$this->args}; | |
535 | ||
536 | # Use the default formatter for single-arg and many-arg open | |
537 | if (@open_args <= 1 or @open_args >= 4) { | |
538 | return $this->format_default; | |
539 | } | |
540 | ||
541 | # For two arg open, we have to extract the mode | |
542 | if (@open_args == 2) { | |
543 | my ($fh, $file) = @open_args; | |
544 | ||
545 | if (ref($fh) eq "GLOB") { | |
546 | $fh = '$fh'; | |
547 | } | |
548 | ||
549 | my ($mode) = $file =~ m{ | |
550 | ^\s* # Spaces before mode | |
551 | ( | |
552 | (?> # Non-backtracking subexp. | |
553 | < # Reading | |
554 | |>>? # Writing/appending | |
555 | ) | |
556 | ) | |
557 | [^&] # Not an ampersand (which means a dup) | |
558 | }x; | |
559 | ||
02b13d1d PF |
560 | if (not $mode) { |
561 | # Maybe it's a 2-arg open without any mode at all? | |
562 | # Detect the most simple case for this, where our | |
563 | # file consists only of word characters. | |
564 | ||
565 | if ( $file =~ m{^\s*\w+\s*$} ) { | |
566 | $mode = '<' | |
567 | } | |
568 | else { | |
569 | # Otherwise, we've got no idea what's going on. | |
570 | # Use the default. | |
571 | return $this->format_default; | |
572 | } | |
573 | } | |
0b09a93a | 574 | |
273225d4 | 575 | # Localising $! means perl makes it a pretty error for us. |
0b09a93a PF |
576 | local $! = $this->errno; |
577 | ||
578 | return $this->_format_open_with_mode($mode, $file, $!); | |
579 | } | |
580 | ||
581 | # Here we must be using three arg open. | |
582 | ||
583 | my $file = $open_args[2]; | |
584 | ||
585 | local $! = $this->errno; | |
586 | ||
587 | my $mode = $open_args[1]; | |
588 | ||
589 | local $@; | |
590 | ||
591 | my $msg = eval { $this->_format_open_with_mode($mode, $file, $!); }; | |
592 | ||
593 | return $msg if $msg; | |
594 | ||
595 | # Default message (for pipes and odd things) | |
596 | ||
597 | return "Can't open '$file' with mode '$open_args[1]': '$!'"; | |
598 | } | |
599 | ||
600 | =head3 register | |
601 | ||
602 | autodie::exception->register( 'CORE::open' => \&mysub ); | |
603 | ||
604 | The C<register> method allows for the registration of a message | |
605 | handler for a given subroutine. The full subroutine name including | |
606 | the package should be used. | |
607 | ||
608 | Registered message handlers will receive the C<autodie::exception> | |
609 | object as the first parameter. | |
610 | ||
611 | =cut | |
612 | ||
613 | sub register { | |
614 | my ($class, $symbol, $handler) = @_; | |
615 | ||
616 | croak "Incorrect call to autodie::register" if @_ != 3; | |
617 | ||
618 | $formatter_of{$symbol} = $handler; | |
619 | ||
620 | } | |
621 | ||
622 | =head3 add_file_and_line | |
623 | ||
624 | say "Problem occurred",$@->add_file_and_line; | |
625 | ||
626 | Returns the string C< at %s line %d>, where C<%s> is replaced with | |
627 | the filename, and C<%d> is replaced with the line number. | |
628 | ||
629 | Primarily intended for use by format handlers. | |
630 | ||
631 | =cut | |
632 | ||
633 | # Simply produces the file and line number; intended to be added | |
634 | # to the end of error messages. | |
635 | ||
636 | sub add_file_and_line { | |
637 | my ($this) = @_; | |
638 | ||
639 | return sprintf(" at %s line %d\n", $this->file, $this->line); | |
640 | } | |
641 | ||
642 | =head3 stringify | |
643 | ||
644 | say "The error was: ",$@->stringify; | |
645 | ||
646 | Formats the error as a human readable string. Usually there's no | |
647 | reason to call this directly, as it is used automatically if an | |
648 | C<autodie::exception> object is ever used as a string. | |
649 | ||
650 | Child classes can override this method to change how they're | |
651 | stringified. | |
652 | ||
653 | =cut | |
654 | ||
655 | sub stringify { | |
656 | my ($this) = @_; | |
657 | ||
658 | my $call = $this->function; | |
f91d7e0d | 659 | my $msg; |
0b09a93a PF |
660 | |
661 | if ($DEBUG) { | |
662 | my $dying_pkg = $this->package; | |
663 | my $sub = $this->function; | |
664 | my $caller = $this->caller; | |
665 | warn "Stringifing exception for $dying_pkg :: $sub / $caller / $call\n"; | |
666 | } | |
667 | ||
668 | # TODO - This isn't using inheritance. Should it? | |
669 | if ( my $sub = $formatter_of{$call} ) { | |
f91d7e0d CBW |
670 | $msg = $sub->($this) . $this->add_file_and_line; |
671 | } else { | |
672 | $msg = $this->format_default . $this->add_file_and_line; | |
0b09a93a | 673 | } |
f91d7e0d CBW |
674 | $msg .= $this->{$PACKAGE}{_stack_trace} |
675 | if $Carp::Verbose; | |
0b09a93a | 676 | |
f91d7e0d | 677 | return $msg; |
0b09a93a PF |
678 | } |
679 | ||
680 | =head3 format_default | |
681 | ||
682 | my $error_string = $E->format_default; | |
683 | ||
684 | This produces the default error string for the given exception, | |
685 | I<without using any registered message handlers>. It is primarily | |
686 | intended to be called from a message handler when they have | |
687 | been passed an exception they don't want to format. | |
688 | ||
689 | Child classes can override this method to change how default | |
690 | messages are formatted. | |
691 | ||
692 | =cut | |
693 | ||
694 | # TODO: This produces ugly errors. Is there any way we can | |
695 | # dig around to find the actual variable names? I know perl 5.10 | |
696 | # does some dark and terrible magicks to find them for undef warnings. | |
697 | ||
698 | sub format_default { | |
699 | my ($this) = @_; | |
700 | ||
35c0561a | 701 | my $call = $this->_trim_package_name($this->function); |
0b09a93a PF |
702 | |
703 | local $! = $this->errno; | |
704 | ||
0b09a93a | 705 | my @args = @{ $this->args() }; |
35c0561a | 706 | @args = $this->_beautify_arguments(@args); |
0b09a93a PF |
707 | |
708 | # Format our beautiful error. | |
709 | ||
02b13d1d | 710 | return "Can't $call(". join(q{, }, @args) . "): $!" ; |
0b09a93a PF |
711 | |
712 | # TODO - Handle user-defined errors from hash. | |
713 | ||
714 | # TODO - Handle default error messages. | |
715 | ||
716 | } | |
717 | ||
718 | =head3 new | |
719 | ||
720 | my $error = autodie::exception->new( | |
721 | args => \@_, | |
722 | function => "CORE::open", | |
723 | errno => $!, | |
eb8d423f PF |
724 | context => 'scalar', |
725 | return => undef, | |
0b09a93a PF |
726 | ); |
727 | ||
728 | ||
729 | Creates a new C<autodie::exception> object. Normally called | |
730 | directly from an autodying function. The C<function> argument | |
731 | is required, its the function we were trying to call that | |
732 | generated the exception. The C<args> parameter is optional. | |
733 | ||
734 | The C<errno> value is optional. In versions of C<autodie::exception> | |
735 | 1.99 and earlier the code would try to automatically use the | |
736 | current value of C<$!>, but this was unreliable and is no longer | |
737 | supported. | |
738 | ||
739 | Atrributes such as package, file, and caller are determined | |
740 | automatically, and cannot be specified. | |
741 | ||
742 | =cut | |
743 | ||
744 | sub new { | |
745 | my ($class, @args) = @_; | |
746 | ||
747 | my $this = {}; | |
748 | ||
749 | bless($this,$class); | |
750 | ||
751 | # I'd love to use EVERY here, but it causes our code to die | |
752 | # because it wants to stringify our objects before they're | |
753 | # initialised, causing everything to explode. | |
754 | ||
755 | $this->_init(@args); | |
756 | ||
757 | return $this; | |
758 | } | |
759 | ||
760 | sub _init { | |
761 | ||
762 | my ($this, %args) = @_; | |
763 | ||
764 | # Capturing errno here is not necessarily reliable. | |
765 | my $original_errno = $!; | |
766 | ||
767 | our $init_called = 1; | |
768 | ||
769 | my $class = ref $this; | |
770 | ||
771 | # We're going to walk up our call stack, looking for the | |
772 | # first thing that doesn't look like our exception | |
773 | # code, autodie/Fatal, or some whacky eval. | |
774 | ||
775 | my ($package, $file, $line, $sub); | |
776 | ||
777 | my $depth = 0; | |
778 | ||
779 | while (1) { | |
780 | $depth++; | |
781 | ||
782 | ($package, $file, $line, $sub) = CORE::caller($depth); | |
783 | ||
784 | # Skip up the call stack until we find something outside | |
785 | # of the Fatal/autodie/eval space. | |
786 | ||
787 | next if $package->isa('Fatal'); | |
788 | next if $package->isa($class); | |
789 | next if $package->isa(__PACKAGE__); | |
273225d4 CBW |
790 | |
791 | # Anything with the 'autodie::skip' role wants us to skip it. | |
792 | # https://github.com/pjf/autodie/issues/15 | |
793 | ||
794 | next if ($package->can('DOES') and $package->DOES('autodie::skip')); | |
795 | ||
0b09a93a PF |
796 | next if $file =~ /^\(eval\s\d+\)$/; |
797 | ||
798 | last; | |
799 | ||
800 | } | |
801 | ||
db4e6d09 PF |
802 | # We now have everything correct, *except* for our subroutine |
803 | # name. If it's __ANON__ or (eval), then we need to keep on | |
804 | # digging deeper into our stack to find the real name. However we | |
805 | # don't update our other information, since that will be correct | |
806 | # for our current exception. | |
807 | ||
808 | my $first_guess_subroutine = $sub; | |
809 | ||
810 | while (defined $sub and $sub =~ /^\(eval\)$|::__ANON__$/) { | |
811 | $depth++; | |
812 | ||
813 | $sub = (CORE::caller($depth))[3]; | |
814 | } | |
815 | ||
816 | # If we end up falling out the bottom of our stack, then our | |
817 | # __ANON__ guess is the best we can get. This includes situations | |
9b657a62 | 818 | # where we were called from the top level of a program. |
db4e6d09 PF |
819 | |
820 | if (not defined $sub) { | |
821 | $sub = $first_guess_subroutine; | |
822 | } | |
823 | ||
0b09a93a PF |
824 | $this->{$PACKAGE}{package} = $package; |
825 | $this->{$PACKAGE}{file} = $file; | |
826 | $this->{$PACKAGE}{line} = $line; | |
827 | $this->{$PACKAGE}{caller} = $sub; | |
f91d7e0d CBW |
828 | |
829 | # Tranks to %Carp::CarpInternal all Fatal, autodie and | |
830 | # autodie::exception stack frames are filtered already, but our | |
831 | # nameless wrapper is still present, so strip that. | |
832 | ||
833 | my $trace = Carp::longmess(); | |
834 | $trace =~ s/^\s*at \(eval[^\n]+\n//; | |
835 | ||
836 | # And if we see an __ANON__, then we'll replace that with the actual | |
837 | # name of our autodying function. | |
838 | ||
839 | my $short_func = $args{function}; | |
840 | $short_func =~ s/^CORE:://; | |
841 | $trace =~ s/(\s*[\w:]+)__ANON__/$1$short_func/; | |
842 | ||
843 | # And now we just fill in all our attributes. | |
844 | ||
845 | $this->{$PACKAGE}{_stack_trace} = $trace; | |
0b09a93a PF |
846 | |
847 | $this->{$PACKAGE}{errno} = $args{errno} || 0; | |
848 | ||
eb8d423f PF |
849 | $this->{$PACKAGE}{context} = $args{context}; |
850 | $this->{$PACKAGE}{return} = $args{return}; | |
7840a289 | 851 | $this->{$PACKAGE}{eval_error} = $args{eval_error}; |
eb8d423f | 852 | |
0b09a93a PF |
853 | $this->{$PACKAGE}{args} = $args{args} || []; |
854 | $this->{$PACKAGE}{function}= $args{function} or | |
855 | croak("$class->new() called without function arg"); | |
856 | ||
857 | return $this; | |
858 | ||
859 | } | |
860 | ||
861 | 1; | |
862 | ||
863 | __END__ | |
864 | ||
865 | =head1 SEE ALSO | |
866 | ||
867 | L<autodie>, L<autodie::exception::system> | |
868 | ||
869 | =head1 LICENSE | |
870 | ||
871 | Copyright (C)2008 Paul Fenwick | |
872 | ||
873 | This is free software. You may modify and/or redistribute this | |
874 | code under the same terms as Perl 5.10 itself, or, at your option, | |
875 | any later version of Perl 5. | |
876 | ||
877 | =head1 AUTHOR | |
878 | ||
879 | Paul Fenwick E<lt>pjf@perltraining.com.auE<gt> |