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