view release on metacpan or  search on metacpan

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

    my $pkg = shift;
    my $callpkg = caller;

    while (my $name = shift @_) {
        if ($name eq '%SIG') {
            # Undef die hook
            $SIG{__DIE__} = '';
        };
    };

    return TRUE;
};


=head1 CONSTRUCTORS

=over

=item catch(I<>) : Self|$@

This method overwrites the default C<catch> constructor.  It works as method
from base class and has one exception in its behavior.

  my $e = CLASS->catch;

If the popped value is an C<Exception::Died> object and has an attribute
C<catch_can_rebless> set, this object is reblessed to class I<$class> with its
attributes unchanged.  It is because original L<Exception::Base>-E<gt>C<catch>
method doesn't change exception class but it should be changed if
C<Exception::Died> handles C<$SIG{__DIE__}> hook.

  use Exception::Base
    'Exception::Fatal'  => { isa => 'Exception::Died' },
    'Exception::Simple' => { isa => 'Exception::Died' };
  use Exception::Died '%SIG' => 'die';

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

  eval { Exception::Simple->throw; };
  my $e = Exception::Fatal->catch;
  print ref $e;   # "Exception::Simple"

=back

=cut

# Rebless Exception::Died into another exception class
sub catch {
    my $self = shift;

    my $class = ref $self ? ref $self : $self;

    my $e = $self->SUPER::catch(@_);

    # Rebless if called as Exception::DiedDerivedClass->catch()
    if (do { local $@; local $SIG{__DIE__}; eval { $e->isa(__PACKAGE__) } }
        and ref $e ne $class and $e->{catch_can_rebless})
    {
        bless $e => $class;
    };

    return $e;
};


=head1 METHODS

=over

=item _collect_system_data(I<>) : Self

Collect system data and fill the attributes of exception object.  This method
is called automatically if exception if thrown.  This class overrides the
method from L<Exception::Base> class.

See L<Exception::Base>.

=back

=cut

# Collect system data
sub _collect_system_data {
    my $self = shift;

    if (not ref $@) {
        $self->{eval_error} = $@;
        while ($self->{eval_error} =~ s/\t\.\.\.propagated at (?!.*\bat\b.*).* line \d+( thread \d+)?\.\n$//s) { }
        $self->{eval_error} =~ s/( at (?!.*\bat\b.*).* line \d+( thread \d+)?\.?)?\n$//s;
        $self->{eval_error} = undef if $self->{eval_error} eq '';
    }
    elsif (do { my $e = $@; local $@; local $SIG{__DIE__}; eval { $e->isa('Exception::Died') } }) {
        $self->{eval_error} = $@->{eval_error};
        $self->{eval_error} = undef if defined $self->{eval_error} and $self->{eval_error} eq '';
    }
    else {
        $self->{eval_error} = undef;
    };

    return $self->SUPER::_collect_system_data(@_);
};


=head1 FUNCTIONS

=over

=item __DIE__()

This is a hook function for $SIG{__DIE__}.  This hook can be enabled with pragma:

  use Exception::Died '%SIG';

or manually, i.e. for local scope:

  {
      local $SIG{__DIE__};
      Exception::Died->import('%SIG');
      # ...