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