Exception-Base

 view release on metacpan or  search on metacpan

lib/Exception/Base.pm  view on Meta::CPAN

matching the exception by class, message or other attributes

=item *

matching with string, regex or closure function

=item *

creating automatically the derived exception classes (L<perlfunc/use>
interface)

=item *

easily expendable, see L<Exception::System> class for example

=item *

prints just an error message or dumps full stack trace

=item *

can propagate (rethrow) an exception

=item *

can ignore some packages for stack trace output

=item *

some defaults (i.e. verbosity) can be different for different exceptions

=back

=for readme stop

=cut

use 5.006;

use strict;
use warnings;

our $VERSION = '0.2501';


# Safe operations on symbol stash
BEGIN {
    eval {
        require Symbol;
        Symbol::qualify_to_ref('Symbol::qualify_to_ref');
    };
    if (not $@) {
        *_qualify_to_ref = \*Symbol::qualify_to_ref;
    }
    else {
        *_qualify_to_ref = sub ($;) { no strict 'refs'; \*{ $_[0] } };
    };
};


# Use weaken ref on stack if available
BEGIN {
    eval {
        require Scalar::Util;
        my $ref = \1;
        Scalar::Util::weaken($ref);
    };
    if (not $@) {
        *_HAVE_SCALAR_UTIL_WEAKEN = sub () { !! 1 };
    }
    else {
        *_HAVE_SCALAR_UTIL_WEAKEN = sub () { !! 0 };
    };
};


BEGIN {
    my %OVERLOADS = (fallback => 1);

=head1 OVERLOADS

=over

=item Boolean context

True value.  See C<to_bool> method.

  eval { Exception::Base->throw( message=>"Message", value=>123 ) };
  if ($@) {
     # the exception object is always true
  }

=cut

    $OVERLOADS{'bool'} = 'to_bool';

=item Numeric context

Content of attribute pointed by C<numeric_attribute> attribute.  See
C<to_number> method.

  eval { Exception::Base->throw( message=>"Message", value=>123 ) };
  print 0+$@;           # 123

=cut

    $OVERLOADS{'0+'}   = 'to_number';

=item String context

Content of attribute which is combined from C<string_attributes> attributes
with additional information, depended on C<verbosity> setting.  See
C<to_string> method.

  eval { Exception::Base->throw( message=>"Message", value=>123 ) };
  print "$@";           # "Message at -e line 1.\n"

=cut

    $OVERLOADS{'""'}   = 'to_string';

=item "~~"

Smart matching operator.  See C<matches> method.

  eval { Exception::Base->throw( message=>"Message", value=>123 ) };

lib/Exception/Base.pm  view on Meta::CPAN

=item pid (ro)

Contains the PID of the Perl process at time of thrown exception.  Collected
if the verbosity on throwing exception was greater than 1.

  eval { Exception::Base->throw( message=>"Message" ); };
  kill 10, $@->pid;

=cut

    $ATTRS{pid}                  = { is => 'ro' };

=item tid (ro)

Contains the tid of the thread or undef if threads are not used.  Collected
if the verbosity on throwing exception was greater than 1.

=cut

    $ATTRS{tid}                  = { is => 'ro' };

=item uid (ro)

=cut

    $ATTRS{uid}                  = { is => 'ro' };

=item euid (ro)

=cut

    $ATTRS{euid}                 = { is => 'ro' };


=item gid (ro)

=cut

    $ATTRS{gid}                  = { is => 'ro' };

=item egid (ro)

Contains the real and effective uid and gid of the Perl process at time of
thrown exception.  Collected if the verbosity on throwing exception was
greater than 1.

=cut

    $ATTRS{egid}                 = { is => 'ro' };

=item caller_stack (ro)

Contains the error stack as array of array with information about caller
functions.  The first 8 elements of the array's row are the same as first 8
elements of the output of C<caller> function.  Further elements are optional
and are the arguments of called function.  Collected if the verbosity on
throwing exception was greater than 1.  Contains only the first element of
caller stack if the verbosity was lower than 3.

If the arguments of called function are references and
C<L<Scalar::Util>::weaken> function is available then reference is weakened.

  eval { Exception::Base->throw( message=>"Message" ); };
  ($package, $filename, $line, $subroutine, $hasargs, $wantarray,
  $evaltext, $is_require, @args) = $@->caller_stack->[0];

=cut

    $ATTRS{caller_stack}         = { is => 'ro' };

=item propagated_stack (ro)

Contains the array of array which is used for generating "...propagated at"
message.  The elements of the array's row are the same as first 3 elements of
the output of C<caller> function.

=cut

    $ATTRS{propagated_stack}     = { is => 'ro' };

=item max_arg_len (rw, default: 64)

Contains the maximal length of argument for functions in backtrace output.
Zero means no limit for length.

  sub a { Exception::Base->throw( max_arg_len=>5 ) }
  a("123456789");

=cut

    $ATTRS{max_arg_len}          = { is => 'rw', default => 64 };

=item max_arg_nums (rw, default: 8)

Contains the maximal number of arguments for functions in backtrace output.
Zero means no limit for arguments.

  sub a { Exception::Base->throw( max_arg_nums=>1 ) }
  a(1,2,3);

=cut

    $ATTRS{max_arg_nums}         = { is => 'rw', default => 8 };

=item max_eval_len (rw, default: 0)

Contains the maximal length of eval strings in backtrace output.  Zero means
no limit for length.

  eval "Exception->throw( max_eval_len=>10 )";
  print "$@";

=cut

    $ATTRS{max_eval_len}         = { is => 'rw', default => 0 };

=item defaults

Meta-attribute contains the list of default values.

  my $e = Exception::Base->new;

lib/Exception/Base.pm  view on Meta::CPAN

    return map { ref $_ eq 'ARRAY'
                 ? sprintf(@$_[0], @$_[1..$#$_])
                 : $_ }
           grep { defined $_ and (ref $_ or $_ ne '') }
           map { $self->{$_} }
           @{ $self->{defaults}->{string_attributes} };
};


=item _collect_system_data

Collects system data and fills the attributes of exception object.  This
method is called automatically if exception if thrown or created by
C<new> constructor.  It can be overridden by derived class.

  package Exception::Special;
  use base 'Exception::Base';
  use constant ATTRS => {
    %{Exception::Base->ATTRS},
    'special' => { is => 'ro' },
  };
  sub _collect_system_data {
    my $self = shift;
    $self->SUPER::_collect_system_data(@_);
    $self->{special} = get_special_value();
    return $self;
  }
  BEGIN {
    __PACKAGE__->_make_accessors;
  }
  1;

Method returns the reference to the self object.

=cut

# Collect system data and fill the attributes and caller stack.
sub _collect_system_data {
    my ($self) = @_;

    # Collect system data only if verbosity is meaning
    my $verbosity = defined $self->{verbosity} ? $self->{verbosity} : $self->{defaults}->{verbosity};
    if ($verbosity >= 2) {
        $self->{time} = CORE::time();
        $self->{tid}  = threads->tid if defined &threads::tid;
        @{$self}{qw < pid uid euid gid egid >} =
                (     $$, $<, $>,  $(, $)    );

        # Collect stack info
        my @caller_stack;
        my $level = 1;

        while (my @c = do { package DB; caller($level++) }) {
            # Skip own package
            next if ! defined $Isa_Package{$c[0]} ? $Isa_Package{$c[0]} = do { local $@; local $SIG{__DIE__}; eval { $c[0]->isa(__PACKAGE__) } } : $Isa_Package{$c[0]};
            # Collect the caller stack
            my @args = @DB::args;
            if (_HAVE_SCALAR_UTIL_WEAKEN) {
                foreach (@args) {
                    Scalar::Util::weaken($_) if ref $_;
                };
            };
            my @stacktrace_element = ( @c[0 .. 7], @args );
            push @caller_stack, \@stacktrace_element;
            # Collect only one entry if verbosity is lower than 3 and skip ignored packages
            last if $verbosity == 2 and not $self->_skip_ignored_package($stacktrace_element[0]);
        };
        $self->{caller_stack} = \@caller_stack;
    };

    return $self;
};


# Check if package should be ignored
sub _skip_ignored_package {
    my ($self, $package) = @_;

    my $ignore_package = defined $self->{ignore_package}
                     ? $self->{ignore_package}
                     : $self->{defaults}->{ignore_package};

    my $ignore_class = defined $self->{ignore_class}
                     ? $self->{ignore_class}
                     : $self->{defaults}->{ignore_class};

    if (defined $ignore_package) {
        if (ref $ignore_package eq 'ARRAY') {
            if (@{ $ignore_package }) {
                do { return 1 if defined $_ and (ref $_ eq 'Regexp' and $package =~ $_ or ref $_ ne 'Regexp' and $package eq $_) } foreach @{ $ignore_package };
            };
        }
        else {
            return 1 if ref $ignore_package eq 'Regexp' ? $package =~ $ignore_package : $package eq $ignore_package;
        };
    }
    if (defined $ignore_class) {
        if (ref $ignore_class eq 'ARRAY') {
            if (@{ $ignore_class }) {
                return 1 if grep { do { local $@; local $SIG{__DIE__}; eval { $package->isa($_) } } } @{ $ignore_class };
            };
        }
        else {
            return 1 if do { local $@; local $SIG{__DIE__}; eval { $package->isa($ignore_class) } };
        };
    };

    return '';
};


# Return info about caller. Stolen from Carp
sub _caller_info {
    my ($self, $i) = @_;
    my %call_info;
    my @call_info = ();

    @call_info = @{ $self->{caller_stack}->[$i] }
        if defined $self->{caller_stack} and defined $self->{caller_stack}->[$i];