File Coverage

blib/lib/Devel/EvalError.pm

Criterion	Covered	Total	%
statement	83	105	79.0
branch	25	50	50.0
condition	6	15	40.0
subroutine	16	21	76.1
pod	9	9	100.0
total	139	200	69.5

package Devel::EvalError;
use strict;


use vars qw( $VERSION );

BEGIN {
    $VERSION= 0.001_002;
    my $idx= 0;
    for my $name (
        '_prevReason',  # Value from $@ when c'ted, restored to $@ in d'tor
        '_reasons',     # List of possible failure reasons from $SIG{__DIE__}
        '_prevHandler', # Value of $SIG{__DIE__} before c'ted
        '_newHandler',  # Address of $SIG{__DIE__} after c'ted
        '_succeeded',   # Whether the eval() was successful
        '_knowReason',  # True if $@ survived
    ) {
        my $code= "sub $name() { $idx; }";
        eval "$code; 1"
            or  die "Couldn't compile constant ($code): $@\n";
        $idx++;
    }
}


sub _croak {    # Die but report the caller's line number
    require Carp;
    Carp::croak( @_ );
}

sub _confess {  # Die with stack trace
    require Carp;
    local $Carp::CarpLevel= $Carp::CarpLevel + 1;
    Carp::confess( @_ );
}

sub _cluck {    # Warn with stack trace
    require Carp;
    local $Carp::CarpLevel= $Carp::CarpLevel + 1;
    Carp::cluck( @_ );
}


sub new {
    my( $we )= @_;
    _croak( "Devel::EvalError: new() via an object is not allowed" )
        if  ref $we;
    my $me= bless [], $we;
    $me->_init();
    return $me;
}


sub _init {
    my( $me )= @_;
    _confess( "Devel::EvalError: Erase() required before _init()" )
        if  $me->[_reasons];
    $me->[_prevReason]=     $@;
    $me->[_reasons]=        my $reasons= [];
    $me->[_prevHandler]=    my $prevHandler= $SIG{__DIE__};
    my $newHandler= sub { _handleDie( $reasons, $prevHandler, @_ ); };
    $me->[_newHandler]=     0 + $newHandler;
    $SIG{__DIE__}= $newHandler;
    return;
}


sub _handleDie {
    my $list= shift @_;
    my $handler= shift @_;
    push @{ $list },
        ( 1 == @_ )  ?  $_[0]  :  join '', @_;
    $handler->( @_ )
        if  $handler;
    return;
}


sub Erase {
    my( $me )= @_;
    $me->_revertHandler();
    my $prevReason= $me->[_prevReason];
    $@= $prevReason
        if  $prevReason;
    return;
}


sub Reuse {
    my( $me )= @_;
    $me->Erase();
    $me->_init();
    return $me;
}


sub ExpectOne {
    my $me= shift @_;
    my $okay;
    if(  @_ <= 1  &&  ! defined $_[0]  ) {
        $okay= 0;
    } elsif(  1 == @_  &&  1 eq $_[0]  ) {
        $okay= 1;
    }
    $me->_expected( $okay, @_ );
    return $me;
}


sub ExpectNonEmpty {
    my $me= shift @_;
    my $okay=  0 == @_ ? 0 : 1;
    $me->_expected( $okay, @_ );
    return wantarray ? @_ : $_[0];
}


sub _expected {
    my $me=     shift @_;
    my $okay=   shift @_;
    my $reason= $@;   # Copy early as $@ can easily change
    my $caller= (caller 1)[3];
    $me->_revertHandler();
    _croak( 'Devel::EvalError: $caller() called on Erase()d object' )
        if  ! $me->[_reasons];
    _croak( 'Devel::EvalError: $caller() called on object more than once' )
        if  defined $me->[_succeeded];
    $me->[_succeeded]= $okay;
    if( ! defined $okay ) {
        _croak(
            "Devel::EvalError: $caller() misused, passed( ",
            join( ", ", map { defined $_ ? $_ : "(undef)" } @_ ),
            " )",
        );
    }
    if(  ! $okay  &&  $reason  ) {
        $me->[_knowReason]= 1;
        push @{ $me->[_reasons] }, $reason
            if  $reason ne $me->[_reasons][-1];
    }
}


sub _revertHandler {
    my( $me )= @_;
    return
        if  ! $me->[_reasons];
    my $handler= $me->[_prevHandler];
    if(  '0' ne $handler  ) {
        my $current= $SIG{__DIE__};
        $SIG{__DIE__}= $handler;
        if(  $current != $me->[_newHandler]  ) {
            _cluck(
                '$SIG{__DIE__} changed out from under Devel::EvalError',
            );
        }
        $me->[_prevHandler]= 0;
    }
    return;
}


sub AllReasons {
    my( $me )= @_;
    return @{ $me->[_reasons] || [] };
}


sub Reason {
    my( $me )= @_;
    my @reasons= @{ $me->[_reasons] || [] };
    return ''
        if  ! defined $me->[_succeeded] # if eval() not called (yet?)
        ||  $me->[_succeeded];          # or eval() succeeded.
    if(  ! @reasons  ) {
        # We "know" eval() failed but we never intercepted a die() message.
        # There are several possibilities (likeliest first):
        #   1)  $ee->ExpectNonEmpty( eval { getList(); } );
        #       but getList() returned an empty list.
        #   2)  $ee->ExpectOne( eval { return; } ); # or similar
        #   3)  Some unexpected way for eval() to fail without our
        #       $SIG{__DIE__} handler ever getting called.  This might be
        #       a Perl bug or something strange that XS code can do or such.
        #   4)  Somebody meddling with our object's internals.  C'est le Vie.
        #   5)  etc.
        return 'Unknown failure reason or returned empty list!';
    }
    return $reasons[-1]
        if  1 == @reasons  ||  $me->[_knowReason];
    return join "\nTHEN ", @reasons;
}


sub Succeeded {
    my( $me )= @_;
    my $okay= $me->[_succeeded];
    _croak(
        'Devel::EvalError: Expect*() not called before checking for success',
    )   if  ! defined $okay;
    return $okay;
}


sub Failed {
    my( $me )= @_;
    return  ! $me->Succeeded();
}



sub DESTROY {
    my( $me )= @_;
    $me->Erase();
}


'Devel::EvalError';
__END__