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.04';
  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         # Have a funny mode?  Use the default format.
 421         return $this->format_default if not defined $mode;
 422
 423         # Localising $! means perl make make it a pretty error for us.
 424         local $! = $this->errno;
 425
 426         return $this->_format_open_with_mode($mode, $file, $!);
 427     }
 428
 429     # Here we must be using three arg open.
 430
 431     my $file = $open_args[2];
 432
 433     local $! = $this->errno;
 434
 435     my $mode = $open_args[1];
 436
 437     local $@;
 438
 439     my $msg = eval { $this->_format_open_with_mode($mode, $file, $!); };
 440
 441     return $msg if $msg;
 442
 443     # Default message (for pipes and odd things)
 444
 445     return "Can't open '$file' with mode '$open_args[1]': '$!'";
 446 }
 447
 448 =head3 register
 449
 450     autodie::exception->register( 'CORE::open' => \&mysub );
 451
 452 The C<register> method allows for the registration of a message
 453 handler for a given subroutine.  The full subroutine name including
 454 the package should be used.
 455
 456 Registered message handlers will receive the C<autodie::exception>
 457 object as the first parameter.
 458
 459 =cut
 460
 461 sub register {
 462     my ($class, $symbol, $handler) = @_;
 463
 464     croak "Incorrect call to autodie::register" if @_ != 3;
 465
 466     $formatter_of{$symbol} = $handler;
 467
 468 }
 469
 470 =head3 add_file_and_line
 471
 472     say "Problem occurred",$@->add_file_and_line;
 473
 474 Returns the string C< at %s line %d>, where C<%s> is replaced with
 475 the filename, and C<%d> is replaced with the line number.
 476
 477 Primarily intended for use by format handlers.
 478
 479 =cut
 480
 481 # Simply produces the file and line number; intended to be added
 482 # to the end of error messages.
 483
 484 sub add_file_and_line {
 485     my ($this) = @_;
 486
 487     return sprintf(" at %s line %d\n", $this->file, $this->line);
 488 }
 489
 490 =head3 stringify
 491
 492     say "The error was: ",$@->stringify;
 493
 494 Formats the error as a human readable string.  Usually there's no
 495 reason to call this directly, as it is used automatically if an
 496 C<autodie::exception> object is ever used as a string.
 497
 498 Child classes can override this method to change how they're
 499 stringified.
 500
 501 =cut
 502
 503 sub stringify {
 504     my ($this) = @_;
 505
 506     my $call        =  $this->function;
 507
 508     if ($DEBUG) {
 509         my $dying_pkg   = $this->package;
 510         my $sub   = $this->function;
 511         my $caller = $this->caller;
 512         warn "Stringifing exception for $dying_pkg :: $sub / $caller / $call\n";
 513     }
 514
 515     # TODO - This isn't using inheritance.  Should it?
 516     if ( my $sub = $formatter_of{$call} ) {
 517         return $sub->($this) . $this->add_file_and_line;
 518     }
 519
 520     return $this->format_default;
 521
 522 }
 523
 524 =head3 format_default
 525
 526     my $error_string = $E->format_default;
 527
 528 This produces the default error string for the given exception,
 529 I<without using any registered message handlers>.  It is primarily
 530 intended to be called from a message handler when they have
 531 been passed an exception they don't want to format.
 532
 533 Child classes can override this method to change how default
 534 messages are formatted.
 535
 536 =cut
 537
 538 # TODO: This produces ugly errors.  Is there any way we can
 539 # dig around to find the actual variable names?  I know perl 5.10
 540 # does some dark and terrible magicks to find them for undef warnings.
 541
 542 sub format_default {
 543     my ($this) = @_;
 544
 545     my $call        =  $this->function;
 546
 547     local $! = $this->errno;
 548
 549     # TODO: This is probably a good idea for CORE, is it
 550     # a good idea for other subs?
 551
 552     # Trim package name off dying sub for error messages.
 553     $call =~ s/.*:://;
 554
 555     # Walk through all our arguments, and...
 556     #
 557     #   * Replace undef with the word 'undef'
 558     #   * Replace globs with the string '$fh'
 559     #   * Quote all other args.
 560
 561     my @args = @{ $this->args() };
 562
 563     foreach my $arg (@args) {
 564        if    (not defined($arg))   { $arg = 'undef' }
 565        elsif (ref($arg) eq "GLOB") { $arg = '$fh'   }
 566        else                        { $arg = qq{'$arg'} }
 567     }
 568
 569     # Format our beautiful error.
 570
 571     return "Can't $call(".  join(q{, }, @args) . "): $!" .
 572         $this->add_file_and_line;
 573
 574     # TODO - Handle user-defined errors from hash.
 575
 576     # TODO - Handle default error messages.
 577
 578 }
 579
 580 =head3 new
 581
 582     my $error = autodie::exception->new(
 583         args => \@_,
 584         function => "CORE::open",
 585         errno => $!,
 586         context => 'scalar',
 587         return => undef,
 588     );
 589
 590
 591 Creates a new C<autodie::exception> object.  Normally called
 592 directly from an autodying function.  The C<function> argument
 593 is required, its the function we were trying to call that
 594 generated the exception.  The C<args> parameter is optional.
 595
 596 The C<errno> value is optional.  In versions of C<autodie::exception>
 597 1.99 and earlier the code would try to automatically use the
 598 current value of C<$!>, but this was unreliable and is no longer
 599 supported.
 600
 601 Atrributes such as package, file, and caller are determined
 602 automatically, and cannot be specified.
 603
 604 =cut
 605
 606 sub new {
 607     my ($class, @args) = @_;
 608
 609     my $this = {};
 610
 611     bless($this,$class);
 612
 613     # I'd love to use EVERY here, but it causes our code to die
 614     # because it wants to stringify our objects before they're
 615     # initialised, causing everything to explode.
 616
 617     $this->_init(@args);
 618
 619     return $this;
 620 }
 621
 622 sub _init {
 623
 624     my ($this, %args) = @_;
 625
 626     # Capturing errno here is not necessarily reliable.
 627     my $original_errno = $!;
 628
 629     our $init_called = 1;
 630
 631     my $class = ref $this;
 632
 633     # We're going to walk up our call stack, looking for the
 634     # first thing that doesn't look like our exception
 635     # code, autodie/Fatal, or some whacky eval.
 636
 637     my ($package, $file, $line, $sub);
 638
 639     my $depth = 0;
 640
 641     while (1) {
 642         $depth++;
 643
 644         ($package, $file, $line, $sub) = CORE::caller($depth);
 645
 646         # Skip up the call stack until we find something outside
 647         # of the Fatal/autodie/eval space.
 648
 649         next if $package->isa('Fatal');
 650         next if $package->isa($class);
 651         next if $package->isa(__PACKAGE__);
 652         next if $file =~ /^\(eval\s\d+\)$/;
 653
 654         last;
 655
 656     }
 657
 658     # We now have everything correct, *except* for our subroutine
 659     # name.  If it's __ANON__ or (eval), then we need to keep on
 660     # digging deeper into our stack to find the real name.  However we
 661     # don't update our other information, since that will be correct
 662     # for our current exception.
 663
 664     my $first_guess_subroutine = $sub;
 665
 666     while (defined $sub and $sub =~ /^\(eval\)$|::__ANON__$/) {
 667         $depth++;
 668
 669         $sub = (CORE::caller($depth))[3];
 670     }
 671
 672     # If we end up falling out the bottom of our stack, then our
 673     # __ANON__ guess is the best we can get.  This includes situations
 674     # where we were called from the top level of a program.
 675
 676     if (not defined $sub) {
 677         $sub = $first_guess_subroutine;
 678     }
 679
 680     $this->{$PACKAGE}{package} = $package;
 681     $this->{$PACKAGE}{file}    = $file;
 682     $this->{$PACKAGE}{line}    = $line;
 683     $this->{$PACKAGE}{caller}  = $sub;
 684     $this->{$PACKAGE}{package} = $package;
 685
 686     $this->{$PACKAGE}{errno}   = $args{errno} || 0;
 687
 688     $this->{$PACKAGE}{context} = $args{context};
 689     $this->{$PACKAGE}{return}  = $args{return};
 690
 691     $this->{$PACKAGE}{args}    = $args{args} || [];
 692     $this->{$PACKAGE}{function}= $args{function} or
 693               croak("$class->new() called without function arg");
 694
 695     return $this;
 696
 697 }
 698
 699 1;
 700
 701 __END__
 702
 703 =head1 SEE ALSO
 704
 705 L<autodie>, L<autodie::exception::system>
 706
 707 =head1 LICENSE
 708
 709 Copyright (C)2008 Paul Fenwick
 710
 711 This is free software.  You may modify and/or redistribute this
 712 code under the same terms as Perl 5.10 itself, or, at your option,
 713 any later version of Perl 5.
 714
 715 =head1 AUTHOR
 716
 717 Paul Fenwick E<lt>pjf@perltraining.com.auE<gt>