"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/lib/autodie/exception.pm" (10 Mar 2019, 22264 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    1 package autodie::exception;
    2 use 5.008;
    3 use strict;
    4 use warnings;
    5 use Carp qw(croak);
    6 
    7 our $VERSION = '2.29002';
    8 # ABSTRACT: Exceptions from autodying functions.
    9 
   10 our $DEBUG = 0;
   11 
   12 use overload
   13     q{""} => "stringify",
   14     # Overload smart-match only if we're using 5.10 or up
   15     ($] >= 5.010 ? ('~~'  => "matches") : ()),
   16     fallback => 1
   17 ;
   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 by autodie; usually
  135 the same as the context in which you called the autodying subroutine.
  136 This can be 'list', 'scalar', or undefined (unknown).  It will never
  137 be 'void', as C<autodie> always captures the return value in one way
  138 or another.
  139 
  140 For some core functions that always return a scalar value regardless
  141 of their context (eg, C<chown>), this may be 'scalar', even if you
  142 used a list context.
  143 
  144 =cut
  145 
  146 # TODO: The comments above say this can be undefined. Is that actually
  147 # the case? (With 'system', perhaps?)
  148 
  149 sub context     { return $_[0]->{$PACKAGE}{context} }
  150 
  151 =head3 return
  152 
  153     my $return_value = $E->return;
  154 
  155 The value(s) returned by the failed subroutine.  When the subroutine
  156 was called in a list context, this will always be a reference to an
  157 array containing the results.  When the subroutine was called in
  158 a scalar context, this will be the actual scalar returned.
  159 
  160 =cut
  161 
  162 sub return      { return $_[0]->{$PACKAGE}{return} }
  163 
  164 =head3 errno
  165 
  166     my $errno = $E->errno;
  167 
  168 The value of C<$!> at the time when the exception occurred.
  169 
  170 B<NOTE>: This method will leave the main C<autodie::exception> class
  171 and become part of a role in the future.  You should only call
  172 C<errno> for exceptions where C<$!> would reasonably have been
  173 set on failure.
  174 
  175 =cut
  176 
  177 # TODO: Make errno part of a role.  It doesn't make sense for
  178 # everything.
  179 
  180 sub errno       { return $_[0]->{$PACKAGE}{errno}; }
  181 
  182 =head3 eval_error
  183 
  184     my $old_eval_error = $E->eval_error;
  185 
  186 The contents of C<$@> immediately after autodie triggered an
  187 exception.  This may be useful when dealing with modules such
  188 as L<Text::Balanced> that set (but do not throw) C<$@> on error.
  189 
  190 =cut
  191 
  192 sub eval_error { return $_[0]->{$PACKAGE}{eval_error}; }
  193 
  194 =head3 matches
  195 
  196     if ( $e->matches('open') ) { ... }
  197 
  198     if ( 'open' ~~ $e ) { ... }
  199 
  200 C<matches> is used to determine whether a
  201 given exception matches a particular role.
  202 
  203 An exception is considered to match a string if:
  204 
  205 =over 4
  206 
  207 =item *
  208 
  209 For a string not starting with a colon, the string exactly matches the
  210 package and subroutine that threw the exception.  For example,
  211 C<MyModule::log>.  If the string does not contain a package name,
  212 C<CORE::> is assumed.
  213 
  214 =item *
  215 
  216 For a string that does start with a colon, if the subroutine
  217 throwing the exception I<does> that behaviour.  For example, the
  218 C<CORE::open> subroutine does C<:file>, C<:io> and C<:all>.
  219 
  220 See L<autodie/CATEGORIES> for further information.
  221 
  222 On Perl 5.10 and above, using smart-match (C<~~>) with an
  223 C<autodie::exception> object will use C<matches> underneath.  This module
  224 used to recommend using smart-match with the exception object on the left
  225 hand side, but in future Perls that is likely to stop working.
  226 The smart-match facility of this class should only be used with the
  227 exception object on the right hand side.  Having the exception object on
  228 the right is both future-proof and portable to older Perls, back to 5.10.
  229 Beware that this facility can only
  230 be relied upon when it is certain that the exception object actually is
  231 an C<autodie::exception> object; it is no more capable than an explicit
  232 call to the C<matches> method.
  233 
  234 =back
  235 
  236 =cut
  237 
  238 {
  239     my (%cache);
  240 
  241     sub matches {
  242         my ($this, $that) = @_;
  243 
  244         # TODO - Handle references
  245         croak "UNIMPLEMENTED" if ref $that;
  246 
  247         my $sub = $this->function;
  248 
  249         if ($DEBUG) {
  250             my $sub2 = $this->function;
  251             warn "Smart-matching $that against $sub / $sub2\n";
  252         }
  253 
  254         # Direct subname match.
  255         return 1 if $that eq $sub;
  256         return 1 if $that !~ /:/ and "CORE::$that" eq $sub;
  257         return 0 if $that !~ /^:/;
  258 
  259         # Cached match / check tags.
  260         require Fatal;
  261 
  262         if (exists $cache{$sub}{$that}) {
  263             return $cache{$sub}{$that};
  264         }
  265 
  266         # This rather awful looking line checks to see if our sub is in the
  267         # list of expanded tags, caches it, and returns the result.
  268 
  269         return $cache{$sub}{$that} = grep { $_ eq $sub } @{ $this->_expand_tag($that) };
  270     }
  271 }
  272 
  273 # This exists primarily so that child classes can override or
  274 # augment it if they wish.
  275 
  276 sub _expand_tag {
  277     my ($this, @args) = @_;
  278 
  279     return Fatal->_expand_tag(@args);
  280 }
  281 
  282 =head2 Advanced methods
  283 
  284 The following methods, while usable from anywhere, are primarily
  285 intended for developers wishing to subclass C<autodie::exception>,
  286 write code that registers custom error messages, or otherwise
  287 work closely with the C<autodie::exception> model.
  288 
  289 =cut
  290 
  291 # The table below records customer formatters.
  292 # TODO - Should this be a package var instead?
  293 # TODO - Should these be in a completely different file, or
  294 #        perhaps loaded on demand?  Most formatters will never
  295 #        get used in most programs.
  296 
  297 my %formatter_of = (
  298     'CORE::close'    => \&_format_close,
  299     'CORE::open'     => \&_format_open,
  300     'CORE::dbmopen'  => \&_format_dbmopen,
  301     'CORE::flock'    => \&_format_flock,
  302     'CORE::read'     => \&_format_readwrite,
  303     'CORE::sysread'  => \&_format_readwrite,
  304     'CORE::syswrite' => \&_format_readwrite,
  305     'CORE::chmod'    => \&_format_chmod,
  306     'CORE::mkdir'    => \&_format_mkdir,
  307 );
  308 
  309 sub _beautify_arguments {
  310     shift @_;
  311 
  312     # Walk through all our arguments, and...
  313     #
  314     #   * Replace undef with the word 'undef'
  315     #   * Replace globs with the string '$fh'
  316     #   * Quote all other args.
  317     foreach my $arg (@_) {
  318        if    (not defined($arg))   { $arg = 'undef' }
  319        elsif (ref($arg) eq "GLOB") { $arg = '$fh'   }
  320        else                        { $arg = qq{'$arg'} }
  321     }
  322 
  323     return @_;
  324 }
  325 
  326 sub _trim_package_name {
  327     # Info: The following is done since 05/2008 (which is before v1.10)
  328 
  329     # TODO: This is probably a good idea for CORE, is it
  330     # a good idea for other subs?
  331 
  332     # Trim package name off dying sub for error messages
  333     (my $name = $_[1]) =~ s/.*:://;
  334     return $name;
  335 }
  336 
  337 # Returns the parameter formatted as octal number
  338 sub _octalize_number {
  339     my $number = $_[1];
  340 
  341     # Only reformat if it looks like a whole number
  342     if ($number =~ /^\d+$/) {
  343         $number = sprintf("%#04lo", $number);
  344     }
  345 
  346     return $number;
  347 }
  348 
  349 # TODO: Our tests only check LOCK_EX | LOCK_NB is properly
  350 # formatted.  Try other combinations and ensure they work
  351 # correctly.
  352 
  353 sub _format_flock {
  354     my ($this) = @_;
  355 
  356     require Fcntl;
  357 
  358     my $filehandle = $this->args->[0];
  359     my $raw_mode   = $this->args->[1];
  360 
  361     my $mode_type;
  362     my $lock_unlock;
  363 
  364     if ($raw_mode & Fcntl::LOCK_EX() ) {
  365         $lock_unlock = "lock";
  366         $mode_type = "for exclusive access";
  367     }
  368     elsif ($raw_mode & Fcntl::LOCK_SH() ) {
  369         $lock_unlock = "lock";
  370         $mode_type = "for shared access";
  371     }
  372     elsif ($raw_mode & Fcntl::LOCK_UN() ) {
  373         $lock_unlock = "unlock";
  374         $mode_type = "";
  375     }
  376     else {
  377         # I've got no idea what they're trying to do.
  378         $lock_unlock = "lock";
  379         $mode_type = "with mode $raw_mode";
  380     }
  381 
  382     my $cooked_filehandle;
  383 
  384     if ($filehandle and not ref $filehandle) {
  385 
  386         # A package filehandle with a name!
  387 
  388         $cooked_filehandle = " $filehandle";
  389     }
  390     else {
  391         # Otherwise we have a scalar filehandle.
  392 
  393         $cooked_filehandle = '';
  394 
  395     }
  396 
  397     local $! = $this->errno;
  398 
  399     return "Can't $lock_unlock filehandle$cooked_filehandle $mode_type: $!";
  400 
  401 }
  402 
  403 # Default formatter for CORE::chmod
  404 sub _format_chmod {
  405     my ($this) = @_;
  406     my @args   = @{$this->args};
  407 
  408     my $mode   = shift @args;
  409     local $!   = $this->errno;
  410 
  411     $mode = $this->_octalize_number($mode);
  412 
  413     @args = $this->_beautify_arguments(@args);
  414 
  415     return "Can't chmod($mode, ". join(q{, }, @args) ."): $!";
  416 }
  417 
  418 # Default formatter for CORE::mkdir
  419 sub _format_mkdir {
  420     my ($this) = @_;
  421     my @args   = @{$this->args};
  422 
  423     # If no mask is specified use default formatter
  424     if (@args < 2) {
  425       return $this->format_default;
  426     }
  427 
  428     my $file = $args[0];
  429     my $mask = $args[1];
  430     local $! = $this->errno;
  431 
  432     $mask = $this->_octalize_number($mask);
  433 
  434     return "Can't mkdir('$file', $mask): '$!'";
  435 }
  436 
  437 # Default formatter for CORE::dbmopen
  438 sub _format_dbmopen {
  439     my ($this) = @_;
  440     my @args   = @{$this->args};
  441 
  442     # TODO: Presently, $args flattens out the (usually empty) hash
  443     # which is passed as the first argument to dbmopen.  This is
  444     # a bug in our args handling code (taking a reference to it would
  445     # be better), but for the moment we'll just examine the end of
  446     # our arguments list for message formatting.
  447 
  448     my $mode = $args[-1];
  449     my $file = $args[-2];
  450 
  451     $mode = $this->_octalize_number($mode);
  452 
  453     local $! = $this->errno;
  454 
  455     return "Can't dbmopen(%hash, '$file', $mode): '$!'";
  456 }
  457 
  458 # Default formatter for CORE::close
  459 
  460 sub _format_close {
  461     my ($this) = @_;
  462     my $close_arg = $this->args->[0];
  463 
  464     local $! = $this->errno;
  465 
  466     # If we've got an old-style filehandle, mention it.
  467     if ($close_arg and not ref $close_arg) {
  468         return "Can't close filehandle '$close_arg': '$!'";
  469     }
  470 
  471     # TODO - This will probably produce an ugly error.  Test and fix.
  472     return "Can't close($close_arg) filehandle: '$!'";
  473 
  474 }
  475 
  476 # Default formatter for CORE::read, CORE::sysread and CORE::syswrite
  477 #
  478 # Similar to default formatter with the buffer filtered out as it
  479 # may contain binary data.
  480 sub _format_readwrite {
  481     my ($this) = @_;
  482     my $call = $this->_trim_package_name($this->function);
  483     local $! = $this->errno;
  484 
  485     # These subs receive the following arguments (in order):
  486     #
  487     # * FILEHANDLE
  488     # * SCALAR (buffer, we do not want to write this)
  489     # * LENGTH (optional for syswrite)
  490     # * OFFSET (optional for all)
  491     my (@args) = @{$this->args};
  492     my $arg_name = $args[1];
  493     if (defined($arg_name)) {
  494         if (ref($arg_name)) {
  495             my $name = blessed($arg_name) || ref($arg_name);
  496             $arg_name = "<${name}>";
  497         } else {
  498             $arg_name = '<BUFFER>';
  499         }
  500     } else {
  501         $arg_name = '<UNDEF>';
  502     }
  503     $args[1] = $arg_name;
  504 
  505     return "Can't $call(" . join(q{, }, @args) . "): $!";
  506 }
  507 
  508 # Default formatter for CORE::open
  509 
  510 use constant _FORMAT_OPEN => "Can't open '%s' for %s: '%s'";
  511 
  512 sub _format_open_with_mode {
  513     my ($this, $mode, $file, $error) = @_;
  514 
  515     my $wordy_mode;
  516 
  517     if    ($mode eq '<')  { $wordy_mode = 'reading';   }
  518     elsif ($mode eq '>')  { $wordy_mode = 'writing';   }
  519     elsif ($mode eq '>>') { $wordy_mode = 'appending'; }
  520 
  521     $file = '<undef>' if not defined $file;
  522 
  523     return sprintf _FORMAT_OPEN, $file, $wordy_mode, $error if $wordy_mode;
  524 
  525     Carp::confess("Internal autodie::exception error: Don't know how to format mode '$mode'.");
  526 
  527 }
  528 
  529 sub _format_open {
  530     my ($this) = @_;
  531 
  532     my @open_args = @{$this->args};
  533 
  534     # Use the default formatter for single-arg and many-arg open
  535     if (@open_args <= 1 or @open_args >= 4) {
  536         return $this->format_default;
  537     }
  538 
  539     # For two arg open, we have to extract the mode
  540     if (@open_args == 2) {
  541         my ($fh, $file) = @open_args;
  542 
  543         if (ref($fh) eq "GLOB") {
  544             $fh = '$fh';
  545         }
  546 
  547         my ($mode) = $file =~ m{
  548             ^\s*                # Spaces before mode
  549             (
  550                 (?>             # Non-backtracking subexp.
  551                     <           # Reading
  552                     |>>?        # Writing/appending
  553                 )
  554             )
  555             [^&]                # Not an ampersand (which means a dup)
  556         }x;
  557 
  558         if (not $mode) {
  559             # Maybe it's a 2-arg open without any mode at all?
  560             # Detect the most simple case for this, where our
  561             # file consists only of word characters.
  562 
  563             if ( $file =~ m{^\s*\w+\s*$} ) {
  564                 $mode = '<'
  565             }
  566             else {
  567                 # Otherwise, we've got no idea what's going on.
  568                 # Use the default.
  569                 return $this->format_default;
  570             }
  571         }
  572 
  573         # Localising $! means perl makes it a pretty error for us.
  574         local $! = $this->errno;
  575 
  576         return $this->_format_open_with_mode($mode, $file, $!);
  577     }
  578 
  579     # Here we must be using three arg open.
  580 
  581     my $file = $open_args[2];
  582 
  583     local $! = $this->errno;
  584 
  585     my $mode = $open_args[1];
  586 
  587     local $@;
  588 
  589     my $msg = eval { $this->_format_open_with_mode($mode, $file, $!); };
  590 
  591     return $msg if $msg;
  592 
  593     # Default message (for pipes and odd things)
  594 
  595     return "Can't open '$file' with mode '$open_args[1]': '$!'";
  596 }
  597 
  598 =head3 register
  599 
  600     autodie::exception->register( 'CORE::open' => \&mysub );
  601 
  602 The C<register> method allows for the registration of a message
  603 handler for a given subroutine.  The full subroutine name including
  604 the package should be used.
  605 
  606 Registered message handlers will receive the C<autodie::exception>
  607 object as the first parameter.
  608 
  609 =cut
  610 
  611 sub register {
  612     my ($class, $symbol, $handler) = @_;
  613 
  614     croak "Incorrect call to autodie::register" if @_ != 3;
  615 
  616     $formatter_of{$symbol} = $handler;
  617 
  618 }
  619 
  620 =head3 add_file_and_line
  621 
  622     say "Problem occurred",$@->add_file_and_line;
  623 
  624 Returns the string C< at %s line %d>, where C<%s> is replaced with
  625 the filename, and C<%d> is replaced with the line number.
  626 
  627 Primarily intended for use by format handlers.
  628 
  629 =cut
  630 
  631 # Simply produces the file and line number; intended to be added
  632 # to the end of error messages.
  633 
  634 sub add_file_and_line {
  635     my ($this) = @_;
  636 
  637     return sprintf(" at %s line %d\n", $this->file, $this->line);
  638 }
  639 
  640 =head3 stringify
  641 
  642     say "The error was: ",$@->stringify;
  643 
  644 Formats the error as a human readable string.  Usually there's no
  645 reason to call this directly, as it is used automatically if an
  646 C<autodie::exception> object is ever used as a string.
  647 
  648 Child classes can override this method to change how they're
  649 stringified.
  650 
  651 =cut
  652 
  653 sub stringify {
  654     my ($this) = @_;
  655 
  656     my $call        =  $this->function;
  657     my $msg;
  658 
  659     if ($DEBUG) {
  660         my $dying_pkg   = $this->package;
  661         my $sub   = $this->function;
  662         my $caller = $this->caller;
  663         warn "Stringifing exception for $dying_pkg :: $sub / $caller / $call\n";
  664     }
  665 
  666     # TODO - This isn't using inheritance.  Should it?
  667     if ( my $sub = $formatter_of{$call} ) {
  668         $msg = $sub->($this) . $this->add_file_and_line;
  669     } else {
  670         $msg = $this->format_default . $this->add_file_and_line;
  671     }
  672     $msg .=  $this->{$PACKAGE}{_stack_trace}
  673         if $Carp::Verbose;
  674 
  675     return $msg;
  676 }
  677 
  678 =head3 format_default
  679 
  680     my $error_string = $E->format_default;
  681 
  682 This produces the default error string for the given exception,
  683 I<without using any registered message handlers>.  It is primarily
  684 intended to be called from a message handler when they have
  685 been passed an exception they don't want to format.
  686 
  687 Child classes can override this method to change how default
  688 messages are formatted.
  689 
  690 =cut
  691 
  692 # TODO: This produces ugly errors.  Is there any way we can
  693 # dig around to find the actual variable names?  I know perl 5.10
  694 # does some dark and terrible magicks to find them for undef warnings.
  695 
  696 sub format_default {
  697     my ($this) = @_;
  698 
  699     my $call   =  $this->_trim_package_name($this->function);
  700 
  701     local $! = $this->errno;
  702 
  703     my @args = @{ $this->args() };
  704     @args = $this->_beautify_arguments(@args);
  705 
  706     # Format our beautiful error.
  707 
  708     return "Can't $call(".  join(q{, }, @args) . "): $!" ;
  709 
  710     # TODO - Handle user-defined errors from hash.
  711 
  712     # TODO - Handle default error messages.
  713 
  714 }
  715 
  716 =head3 new
  717 
  718     my $error = autodie::exception->new(
  719         args => \@_,
  720         function => "CORE::open",
  721         errno => $!,
  722         context => 'scalar',
  723         return => undef,
  724     );
  725 
  726 
  727 Creates a new C<autodie::exception> object.  Normally called
  728 directly from an autodying function.  The C<function> argument
  729 is required, its the function we were trying to call that
  730 generated the exception.  The C<args> parameter is optional.
  731 
  732 The C<errno> value is optional.  In versions of C<autodie::exception>
  733 1.99 and earlier the code would try to automatically use the
  734 current value of C<$!>, but this was unreliable and is no longer
  735 supported.
  736 
  737 Atrributes such as package, file, and caller are determined
  738 automatically, and cannot be specified.
  739 
  740 =cut
  741 
  742 sub new {
  743     my ($class, @args) = @_;
  744 
  745     my $this = {};
  746 
  747     bless($this,$class);
  748 
  749     # I'd love to use EVERY here, but it causes our code to die
  750     # because it wants to stringify our objects before they're
  751     # initialised, causing everything to explode.
  752 
  753     $this->_init(@args);
  754 
  755     return $this;
  756 }
  757 
  758 sub _init {
  759 
  760     my ($this, %args) = @_;
  761 
  762     # Capturing errno here is not necessarily reliable.
  763     my $original_errno = $!;
  764 
  765     our $init_called = 1;
  766 
  767     my $class = ref $this;
  768 
  769     # We're going to walk up our call stack, looking for the
  770     # first thing that doesn't look like our exception
  771     # code, autodie/Fatal, or some whacky eval.
  772 
  773     my ($package, $file, $line, $sub);
  774 
  775     my $depth = 0;
  776 
  777     while (1) {
  778         $depth++;
  779 
  780         ($package, $file, $line, $sub) = CORE::caller($depth);
  781 
  782         # Skip up the call stack until we find something outside
  783         # of the Fatal/autodie/eval space.
  784 
  785         next if $package->isa('Fatal');
  786         next if $package->isa($class);
  787         next if $package->isa(__PACKAGE__);
  788 
  789         # Anything with the 'autodie::skip' role wants us to skip it.
  790         # https://github.com/pjf/autodie/issues/15
  791 
  792         next if ($package->can('DOES') and $package->DOES('autodie::skip'));
  793 
  794         next if $file =~ /^\(eval\s\d+\)$/;
  795 
  796         last;
  797 
  798     }
  799 
  800     # We now have everything correct, *except* for our subroutine
  801     # name.  If it's __ANON__ or (eval), then we need to keep on
  802     # digging deeper into our stack to find the real name.  However we
  803     # don't update our other information, since that will be correct
  804     # for our current exception.
  805 
  806     my $first_guess_subroutine = $sub;
  807 
  808     while (defined $sub and $sub =~ /^\(eval\)$|::__ANON__$/) {
  809         $depth++;
  810 
  811         $sub = (CORE::caller($depth))[3];
  812     }
  813 
  814     # If we end up falling out the bottom of our stack, then our
  815     # __ANON__ guess is the best we can get.  This includes situations
  816     # where we were called from the top level of a program.
  817 
  818     if (not defined $sub) {
  819         $sub = $first_guess_subroutine;
  820     }
  821 
  822     $this->{$PACKAGE}{package} = $package;
  823     $this->{$PACKAGE}{file}    = $file;
  824     $this->{$PACKAGE}{line}    = $line;
  825     $this->{$PACKAGE}{caller}  = $sub;
  826 
  827     # Tranks to %Carp::CarpInternal all Fatal, autodie and
  828     # autodie::exception stack frames are filtered already, but our
  829     # nameless wrapper is still present, so strip that.
  830 
  831     my $trace = Carp::longmess();
  832     $trace =~ s/^\s*at \(eval[^\n]+\n//;
  833 
  834     # And if we see an __ANON__, then we'll replace that with the actual
  835     # name of our autodying function.
  836 
  837     my $short_func = $args{function};
  838     $short_func =~ s/^CORE:://;
  839     $trace =~ s/(\s*[\w:]+)__ANON__/$1$short_func/;
  840 
  841     # And now we just fill in all our attributes.
  842 
  843     $this->{$PACKAGE}{_stack_trace} = $trace;
  844 
  845     $this->{$PACKAGE}{errno}   = $args{errno} || 0;
  846 
  847     $this->{$PACKAGE}{context} = $args{context};
  848     $this->{$PACKAGE}{return}  = $args{return};
  849     $this->{$PACKAGE}{eval_error}  = $args{eval_error};
  850 
  851     $this->{$PACKAGE}{args}    = $args{args} || [];
  852     $this->{$PACKAGE}{function}= $args{function} or
  853               croak("$class->new() called without function arg");
  854 
  855     return $this;
  856 
  857 }
  858 
  859 1;
  860 
  861 __END__
  862 
  863 =head1 SEE ALSO
  864 
  865 L<autodie>, L<autodie::exception::system>
  866 
  867 =head1 LICENSE
  868 
  869 Copyright (C)2008 Paul Fenwick
  870 
  871 This is free software.  You may modify and/or redistribute this
  872 code under the same terms as Perl 5.10 itself, or, at your option,
  873 any later version of Perl 5.
  874 
  875 =head1 AUTHOR
  876 
  877 Paul Fenwick E<lt>pjf@perltraining.com.auE<gt>