diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/autodie/exception.pm')
| -rw-r--r-- | Master/tlpkg/tlperl/lib/autodie/exception.pm | 741 |
1 files changed, 741 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/autodie/exception.pm b/Master/tlpkg/tlperl/lib/autodie/exception.pm new file mode 100644 index 00000000000..8646099c4c8 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/autodie/exception.pm @@ -0,0 +1,741 @@ +package autodie::exception; +use 5.008; +use strict; +use warnings; +use Carp qw(croak); + +our $DEBUG = 0; + +use overload + q{""} => "stringify" +; + +# Overload smart-match only if we're using 5.10 + +use if ($] >= 5.010), overload => '~~' => "matches"; + +our $VERSION = '2.06_01'; + +my $PACKAGE = __PACKAGE__; # Useful to have a scalar for hash keys. + +=head1 NAME + +autodie::exception - Exceptions from autodying functions. + +=head1 SYNOPSIS + + eval { + use autodie; + + open(my $fh, '<', 'some_file.txt'); + + ... + }; + + if (my $E = $@) { + say "Ooops! ",$E->caller," had problems: $@"; + } + + +=head1 DESCRIPTION + +When an L<autodie> enabled function fails, it generates an +C<autodie::exception> object. This can be interrogated to +determine further information about the error that occurred. + +This document is broken into two sections; those methods that +are most useful to the end-developer, and those methods for +anyone wishing to subclass or get very familiar with +C<autodie::exception>. + +=head2 Common Methods + +These methods are intended to be used in the everyday dealing +of exceptions. + +The following assume that the error has been copied into +a separate scalar: + + if ($E = $@) { + ... + } + +This is not required, but is recommended in case any code +is called which may reset or alter C<$@>. + +=cut + +=head3 args + + my $array_ref = $E->args; + +Provides a reference to the arguments passed to the subroutine +that died. + +=cut + +sub args { return $_[0]->{$PACKAGE}{args}; } + +=head3 function + + my $sub = $E->function; + +The subroutine (including package) that threw the exception. + +=cut + +sub function { return $_[0]->{$PACKAGE}{function}; } + +=head3 file + + my $file = $E->file; + +The file in which the error occurred (eg, C<myscript.pl> or +C<MyTest.pm>). + +=cut + +sub file { return $_[0]->{$PACKAGE}{file}; } + +=head3 package + + my $package = $E->package; + +The package from which the exceptional subroutine was called. + +=cut + +sub package { return $_[0]->{$PACKAGE}{package}; } + +=head3 caller + + my $caller = $E->caller; + +The subroutine that I<called> the exceptional code. + +=cut + +sub caller { return $_[0]->{$PACKAGE}{caller}; } + +=head3 line + + my $line = $E->line; + +The line in C<< $E->file >> where the exceptional code was called. + +=cut + +sub line { return $_[0]->{$PACKAGE}{line}; } + +=head3 context + + my $context = $E->context; + +The context in which the subroutine was called. This can be +'list', 'scalar', or undefined (unknown). It will never be 'void', as +C<autodie> always captures the return value in one way or another. + +=cut + +sub context { return $_[0]->{$PACKAGE}{context} } + +=head3 return + + my $return_value = $E->return; + +The value(s) returned by the failed subroutine. When the subroutine +was called in a list context, this will always be a reference to an +array containing the results. When the subroutine was called in +a scalar context, this will be the actual scalar returned. + +=cut + +sub return { return $_[0]->{$PACKAGE}{return} } + +=head3 errno + + my $errno = $E->errno; + +The value of C<$!> at the time when the exception occurred. + +B<NOTE>: This method will leave the main C<autodie::exception> class +and become part of a role in the future. You should only call +C<errno> for exceptions where C<$!> would reasonably have been +set on failure. + +=cut + +# TODO: Make errno part of a role. It doesn't make sense for +# everything. + +sub errno { return $_[0]->{$PACKAGE}{errno}; } + +=head3 eval_error + + my $old_eval_error = $E->eval_error; + +The contents of C<$@> immediately after autodie triggered an +exception. This may be useful when dealing with modules such +as L<Text::Balanced> that set (but do not throw) C<$@> on error. + +=cut + +sub eval_error { return $_[0]->{$PACKAGE}{eval_error}; } + +=head3 matches + + if ( $e->matches('open') ) { ... } + + if ( $e ~~ 'open' ) { ... } + +C<matches> is used to determine whether a +given exception matches a particular role. On Perl 5.10, +using smart-match (C<~~>) with an C<autodie::exception> object +will use C<matches> underneath. + +An exception is considered to match a string if: + +=over 4 + +=item * + +For a string not starting with a colon, the string exactly matches the +package and subroutine that threw the exception. For example, +C<MyModule::log>. If the string does not contain a package name, +C<CORE::> is assumed. + +=item * + +For a string that does start with a colon, if the subroutine +throwing the exception I<does> that behaviour. For example, the +C<CORE::open> subroutine does C<:file>, C<:io> and C<:all>. + +See L<autodie/CATEGORIES> for futher information. + +=back + +=cut + +{ + my (%cache); + + sub matches { + my ($this, $that) = @_; + + # TODO - Handle references + croak "UNIMPLEMENTED" if ref $that; + + my $sub = $this->function; + + if ($DEBUG) { + my $sub2 = $this->function; + warn "Smart-matching $that against $sub / $sub2\n"; + } + + # Direct subname match. + return 1 if $that eq $sub; + return 1 if $that !~ /:/ and "CORE::$that" eq $sub; + return 0 if $that !~ /^:/; + + # Cached match / check tags. + require Fatal; + + if (exists $cache{$sub}{$that}) { + return $cache{$sub}{$that}; + } + + # This rather awful looking line checks to see if our sub is in the + # list of expanded tags, caches it, and returns the result. + + return $cache{$sub}{$that} = grep { $_ eq $sub } @{ $this->_expand_tag($that) }; + } +} + +# This exists primarily so that child classes can override or +# augment it if they wish. + +sub _expand_tag { + my ($this, @args) = @_; + + return Fatal->_expand_tag(@args); +} + +=head2 Advanced methods + +The following methods, while usable from anywhere, are primarily +intended for developers wishing to subclass C<autodie::exception>, +write code that registers custom error messages, or otherwise +work closely with the C<autodie::exception> model. + +=cut + +# The table below records customer formatters. +# TODO - Should this be a package var instead? +# TODO - Should these be in a completely different file, or +# perhaps loaded on demand? Most formatters will never +# get used in most programs. + +my %formatter_of = ( + 'CORE::close' => \&_format_close, + 'CORE::open' => \&_format_open, + 'CORE::dbmopen' => \&_format_dbmopen, + 'CORE::flock' => \&_format_flock, +); + +# TODO: Our tests only check LOCK_EX | LOCK_NB is properly +# formatted. Try other combinations and ensure they work +# correctly. + +sub _format_flock { + my ($this) = @_; + + require Fcntl; + + my $filehandle = $this->args->[0]; + my $raw_mode = $this->args->[1]; + + my $mode_type; + my $lock_unlock; + + if ($raw_mode & Fcntl::LOCK_EX() ) { + $lock_unlock = "lock"; + $mode_type = "for exclusive access"; + } + elsif ($raw_mode & Fcntl::LOCK_SH() ) { + $lock_unlock = "lock"; + $mode_type = "for shared access"; + } + elsif ($raw_mode & Fcntl::LOCK_UN() ) { + $lock_unlock = "unlock"; + $mode_type = ""; + } + else { + # I've got no idea what they're trying to do. + $lock_unlock = "lock"; + $mode_type = "with mode $raw_mode"; + } + + my $cooked_filehandle; + + if ($filehandle and not ref $filehandle) { + + # A package filehandle with a name! + + $cooked_filehandle = " $filehandle"; + } + else { + # Otherwise we have a scalar filehandle. + + $cooked_filehandle = ''; + + } + + local $! = $this->errno; + + return "Can't $lock_unlock filehandle$cooked_filehandle $mode_type: $!"; + +} + +# Default formatter for CORE::dbmopen +sub _format_dbmopen { + my ($this) = @_; + my @args = @{$this->args}; + + # TODO: Presently, $args flattens out the (usually empty) hash + # which is passed as the first argument to dbmopen. This is + # a bug in our args handling code (taking a reference to it would + # be better), but for the moment we'll just examine the end of + # our arguments list for message formatting. + + my $mode = $args[-1]; + my $file = $args[-2]; + + # If we have a mask, then display it in octal, not decimal. + # We don't do this if it already looks octalish, or doesn't + # look like a number. + + if ($mode =~ /^[^\D0]\d+$/) { + $mode = sprintf("0%lo", $mode); + }; + + local $! = $this->errno; + + return "Can't dbmopen(%hash, '$file', $mode): '$!'"; +} + +# Default formatter for CORE::close + +sub _format_close { + my ($this) = @_; + my $close_arg = $this->args->[0]; + + local $! = $this->errno; + + # If we've got an old-style filehandle, mention it. + if ($close_arg and not ref $close_arg) { + return "Can't close filehandle '$close_arg': '$!'"; + } + + # TODO - This will probably produce an ugly error. Test and fix. + return "Can't close($close_arg) filehandle: '$!'"; + +} + +# Default formatter for CORE::open + +use constant _FORMAT_OPEN => "Can't open '%s' for %s: '%s'"; + +sub _format_open_with_mode { + my ($this, $mode, $file, $error) = @_; + + my $wordy_mode; + + if ($mode eq '<') { $wordy_mode = 'reading'; } + elsif ($mode eq '>') { $wordy_mode = 'writing'; } + elsif ($mode eq '>>') { $wordy_mode = 'appending'; } + + return sprintf _FORMAT_OPEN, $file, $wordy_mode, $error if $wordy_mode; + + Carp::confess("Internal autodie::exception error: Don't know how to format mode '$mode'."); + +} + +sub _format_open { + my ($this) = @_; + + my @open_args = @{$this->args}; + + # Use the default formatter for single-arg and many-arg open + if (@open_args <= 1 or @open_args >= 4) { + return $this->format_default; + } + + # For two arg open, we have to extract the mode + if (@open_args == 2) { + my ($fh, $file) = @open_args; + + if (ref($fh) eq "GLOB") { + $fh = '$fh'; + } + + my ($mode) = $file =~ m{ + ^\s* # Spaces before mode + ( + (?> # Non-backtracking subexp. + < # Reading + |>>? # Writing/appending + ) + ) + [^&] # Not an ampersand (which means a dup) + }x; + + if (not $mode) { + # Maybe it's a 2-arg open without any mode at all? + # Detect the most simple case for this, where our + # file consists only of word characters. + + if ( $file =~ m{^\s*\w+\s*$} ) { + $mode = '<' + } + else { + # Otherwise, we've got no idea what's going on. + # Use the default. + return $this->format_default; + } + } + + # Localising $! means perl make make it a pretty error for us. + local $! = $this->errno; + + return $this->_format_open_with_mode($mode, $file, $!); + } + + # Here we must be using three arg open. + + my $file = $open_args[2]; + + local $! = $this->errno; + + my $mode = $open_args[1]; + + local $@; + + my $msg = eval { $this->_format_open_with_mode($mode, $file, $!); }; + + return $msg if $msg; + + # Default message (for pipes and odd things) + + return "Can't open '$file' with mode '$open_args[1]': '$!'"; +} + +=head3 register + + autodie::exception->register( 'CORE::open' => \&mysub ); + +The C<register> method allows for the registration of a message +handler for a given subroutine. The full subroutine name including +the package should be used. + +Registered message handlers will receive the C<autodie::exception> +object as the first parameter. + +=cut + +sub register { + my ($class, $symbol, $handler) = @_; + + croak "Incorrect call to autodie::register" if @_ != 3; + + $formatter_of{$symbol} = $handler; + +} + +=head3 add_file_and_line + + say "Problem occurred",$@->add_file_and_line; + +Returns the string C< at %s line %d>, where C<%s> is replaced with +the filename, and C<%d> is replaced with the line number. + +Primarily intended for use by format handlers. + +=cut + +# Simply produces the file and line number; intended to be added +# to the end of error messages. + +sub add_file_and_line { + my ($this) = @_; + + return sprintf(" at %s line %d\n", $this->file, $this->line); +} + +=head3 stringify + + say "The error was: ",$@->stringify; + +Formats the error as a human readable string. Usually there's no +reason to call this directly, as it is used automatically if an +C<autodie::exception> object is ever used as a string. + +Child classes can override this method to change how they're +stringified. + +=cut + +sub stringify { + my ($this) = @_; + + my $call = $this->function; + + if ($DEBUG) { + my $dying_pkg = $this->package; + my $sub = $this->function; + my $caller = $this->caller; + warn "Stringifing exception for $dying_pkg :: $sub / $caller / $call\n"; + } + + # TODO - This isn't using inheritance. Should it? + if ( my $sub = $formatter_of{$call} ) { + return $sub->($this) . $this->add_file_and_line; + } + + return $this->format_default . $this->add_file_and_line; + +} + +=head3 format_default + + my $error_string = $E->format_default; + +This produces the default error string for the given exception, +I<without using any registered message handlers>. It is primarily +intended to be called from a message handler when they have +been passed an exception they don't want to format. + +Child classes can override this method to change how default +messages are formatted. + +=cut + +# TODO: This produces ugly errors. Is there any way we can +# dig around to find the actual variable names? I know perl 5.10 +# does some dark and terrible magicks to find them for undef warnings. + +sub format_default { + my ($this) = @_; + + my $call = $this->function; + + local $! = $this->errno; + + # TODO: This is probably a good idea for CORE, is it + # a good idea for other subs? + + # Trim package name off dying sub for error messages. + $call =~ s/.*:://; + + # Walk through all our arguments, and... + # + # * Replace undef with the word 'undef' + # * Replace globs with the string '$fh' + # * Quote all other args. + + my @args = @{ $this->args() }; + + foreach my $arg (@args) { + if (not defined($arg)) { $arg = 'undef' } + elsif (ref($arg) eq "GLOB") { $arg = '$fh' } + else { $arg = qq{'$arg'} } + } + + # Format our beautiful error. + + return "Can't $call(". join(q{, }, @args) . "): $!" ; + + # TODO - Handle user-defined errors from hash. + + # TODO - Handle default error messages. + +} + +=head3 new + + my $error = autodie::exception->new( + args => \@_, + function => "CORE::open", + errno => $!, + context => 'scalar', + return => undef, + ); + + +Creates a new C<autodie::exception> object. Normally called +directly from an autodying function. The C<function> argument +is required, its the function we were trying to call that +generated the exception. The C<args> parameter is optional. + +The C<errno> value is optional. In versions of C<autodie::exception> +1.99 and earlier the code would try to automatically use the +current value of C<$!>, but this was unreliable and is no longer +supported. + +Atrributes such as package, file, and caller are determined +automatically, and cannot be specified. + +=cut + +sub new { + my ($class, @args) = @_; + + my $this = {}; + + bless($this,$class); + + # I'd love to use EVERY here, but it causes our code to die + # because it wants to stringify our objects before they're + # initialised, causing everything to explode. + + $this->_init(@args); + + return $this; +} + +sub _init { + + my ($this, %args) = @_; + + # Capturing errno here is not necessarily reliable. + my $original_errno = $!; + + our $init_called = 1; + + my $class = ref $this; + + # We're going to walk up our call stack, looking for the + # first thing that doesn't look like our exception + # code, autodie/Fatal, or some whacky eval. + + my ($package, $file, $line, $sub); + + my $depth = 0; + + while (1) { + $depth++; + + ($package, $file, $line, $sub) = CORE::caller($depth); + + # Skip up the call stack until we find something outside + # of the Fatal/autodie/eval space. + + next if $package->isa('Fatal'); + next if $package->isa($class); + next if $package->isa(__PACKAGE__); + next if $file =~ /^\(eval\s\d+\)$/; + + last; + + } + + # We now have everything correct, *except* for our subroutine + # name. If it's __ANON__ or (eval), then we need to keep on + # digging deeper into our stack to find the real name. However we + # don't update our other information, since that will be correct + # for our current exception. + + my $first_guess_subroutine = $sub; + + while (defined $sub and $sub =~ /^\(eval\)$|::__ANON__$/) { + $depth++; + + $sub = (CORE::caller($depth))[3]; + } + + # If we end up falling out the bottom of our stack, then our + # __ANON__ guess is the best we can get. This includes situations + # where we were called from the top level of a program. + + if (not defined $sub) { + $sub = $first_guess_subroutine; + } + + $this->{$PACKAGE}{package} = $package; + $this->{$PACKAGE}{file} = $file; + $this->{$PACKAGE}{line} = $line; + $this->{$PACKAGE}{caller} = $sub; + $this->{$PACKAGE}{package} = $package; + + $this->{$PACKAGE}{errno} = $args{errno} || 0; + + $this->{$PACKAGE}{context} = $args{context}; + $this->{$PACKAGE}{return} = $args{return}; + $this->{$PACKAGE}{eval_error} = $args{eval_error}; + + $this->{$PACKAGE}{args} = $args{args} || []; + $this->{$PACKAGE}{function}= $args{function} or + croak("$class->new() called without function arg"); + + return $this; + +} + +1; + +__END__ + +=head1 SEE ALSO + +L<autodie>, L<autodie::exception::system> + +=head1 LICENSE + +Copyright (C)2008 Paul Fenwick + +This is free software. You may modify and/or redistribute this +code under the same terms as Perl 5.10 itself, or, at your option, +any later version of Perl 5. + +=head1 AUTHOR + +Paul Fenwick E<lt>pjf@perltraining.com.auE<gt> |