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