view release on metacpan or  search on metacpan

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

The constructor reads the list of class attributes from ATTRS constant
function and stores it in the internal cache for performance reason.  The
defaults values for the class are also stored in internal cache.

=item C<CLASS>-E<gt>throw([%I<args>]])

Creates the exception object and immediately throws it with C<die> system
function.

  open my $fh, $file
    or Exception::Base->throw( message=>"Can not open file: $file" );

The C<throw> is also exported as a function.

  open my $fh, $file
    or throw 'Exception::Base' => message=>"Can not open file: $file";

=back

The C<throw> can be also used as a method.

=cut

# Constructor
sub new {
    my ($self, %args) = @_;

    my $class = ref $self || $self;

    my $attributes;
    my $defaults;

    # Use cached value if available
    if (not defined $Class_Attributes{$class}) {
        $attributes = $Class_Attributes{$class} = $class->ATTRS;
        $defaults = $Class_Defaults{$class} = {
            map { $_ => $attributes->{$_}->{default} }
                grep { defined $attributes->{$_}->{default} }
                    (keys %$attributes)
        };
    }
    else {
        $attributes = $Class_Attributes{$class};
        $defaults = $Class_Defaults{$class};
    };

    my $e = {};

    # If the attribute is rw, initialize its value. Otherwise: ignore.
    no warnings 'uninitialized';
    foreach my $key (keys %args) {
        if ($attributes->{$key}->{is} eq 'rw') {
            $e->{$key} = $args{$key};
        };
    };

    # Defaults for this object
    $e->{defaults} = { %$defaults };

    bless $e => $class;

    # Collect system data and eval error
    $e->_collect_system_data;

    return $e;
};


=head1 METHODS

=over

=item C<$obj>-E<gt>throw([%I<args>])

Immediately throws exception object.  It can be used for rethrowing existing
exception object.  Additional arguments will override the attributes in
existing exception object.

  $e = Exception::Base->new;
  # (...)
  $e->throw( message=>"thrown exception with overridden message" );

  eval { Exception::Base->throw( message=>"Problem", value=>1 ) };
  $@->throw if $@->value;

=item C<$obj>-E<gt>throw(I<message>, [%I<args>])

If the number of I<args> list for arguments is odd, the first argument is a
message.  This message can be overridden by message from I<args> list.

  Exception::Base->throw( "Problem", message=>"More important" );
  eval { die "Bum!" };
  Exception::Base->throw( $@, message=>"New message" );

=item I<CLASS>-E<gt>throw($I<exception>, [%I<args>])

Immediately rethrows an existing exception object as an other exception class.

  eval { open $f, "w", "/etc/passwd" or Exception::System->throw };
  # convert Exception::System into Exception::Base
  Exception::Base->throw($@);

=cut

# Create the exception and throw it or rethrow existing
sub throw {
    my $self = shift;

    my $class = ref $self || $self;

    my $old_e;

    if (not ref $self) {
        # CLASS->throw
        if (not ref $_[0]) {
            # Throw new exception
            if (scalar @_ % 2 == 0) {
                # Throw normal error
                die $self->new(@_);
            }
            else {
                # First argument is a default attribute; it can be overridden with normal args
                my $argument = shift;
                my $e = $self->new(@_);
                my $default_attribute = $e->{defaults}->{default_attribute};
                $e->{$default_attribute} = $argument if not defined $e->{$default_attribute};
                die $e;
            };
        }
        else {
            # First argument is an old exception
            $old_e = shift;
        };
    }
    else {
        # $e->throw
        $old_e = $self;
    };

    # Rethrow old exception with replaced attributes
    no warnings 'uninitialized';
    my %args = @_;
    my $attrs = $old_e->ATTRS;
    foreach my $key (keys %args) {
        if ($attrs->{$key}->{is} eq 'rw') {
            $old_e->{$key} = $args{$key};
        };
    };
    $old_e->PROPAGATE;
    if (ref $old_e ne $class) {
        # Rebless old object for new class
        bless $old_e => $class;
    };

    die $old_e;
};


=item I<CLASS>-E<gt>catch([$I<variable>])

The exception is recovered from I<variable> argument or C<$@> variable if
I<variable> argument was empty.  Then also C<$@> is replaced with empty string
to avoid an endless loop.

The method returns an exception object if exception is caught or undefined
value otherwise.

  eval { Exception::Base->throw; };
  if ($@) {
      my $e = Exception::Base->catch;
      print $e->to_string;
  }

If the value is not empty and does not contain the C<Exception::Base> object,
new exception object is created with class I<CLASS> and its message is based
on previous value with removed C<" at file line 123."> string and the last end
of line (LF).

  eval { die "Died\n"; };
  my $e = Exception::Base->catch;
  print ref $e;   # "Exception::Base"

=cut

# Recover $@ variable and return exception object
sub catch {
    my ($self) = @_;

    my $class = ref $self || $self;

    my $e;
    my $new_e;


    if (@_ > 1) {
        # Recover exception from argument
        $e = $_[1];
    }
    else {
        # Recover exception from $@ and clear it
        $e = $@;
        $@ = '';
    };

    if (ref $e and do { local $@; local $SIG{__DIE__}; eval { $e->isa(__PACKAGE__) } }) {
        # Caught exception
        $new_e = $e;
    }
    elsif ($e eq '') {
        # No error in $@
        $new_e = undef;
    }