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>