File Coverage

blib/lib/Try/Lite.pm

Criterion	Covered	Total	%
statement	48	48	100.0
branch	18	20	90.0
condition	6	9	66.6
subroutine	7	7	100.0
pod	1	1	100.0
total	80	85	94.1

package Try::Lite;
use strict;
use warnings;
use parent 'Exporter';
use 5.008005;
our $VERSION = '0.0.3';

our @EXPORT = 'try';

use Scalar::Util;
use Carp;
$Carp::Internal{+__PACKAGE__}++;

sub try (&;%) {
    my($try, @catches) = @_;

    confess 'Unknown @catches values. Check your usage & try again'
        unless @catches;

    # check @catches
    for (my $i = 0; $i < @catches; $i += 2) {
        confess q{illegal @catches values. try {} 'ClassName' => sub {}, ...;}
            unless $catches[$i] && ref($catches[$i + 1]) eq 'CODE';
    }

    # we need to save this here, the eval block will be in scalar context due
    # to $failed
    my $wantarray = wantarray;

    # save the value of $@ so we can set $@ back to it in the beginning of the eval
    # and restore $@ after the eval finishes
    my $prev_error = $@;

    my @ret;

    # failed will be true if the eval dies, because 1 will not be returned
    # from the eval body
    my $failed = not eval {
        $@ = $prev_error;

        # evaluate the try block in the correct context
        if ( $wantarray ) {
            @ret = $try->();
        } elsif ( defined $wantarray ) {
            $ret[0] = $try->();
        } else {
            $try->();
        };

        return 1; # properly set $fail to false
    };

    # preserve the current error and reset the original value of $@
    my $error = $@;
    $@        = $prev_error;

    if ($failed) {
        for (my $i = 0;$i < @catches;$i += 2) {
            my($class, $code) = ($catches[$i], $catches[$i + 1]);
            next unless $class eq '*' || (Scalar::Util::blessed($error) && UNIVERSAL::isa($error, $class));

            # evaluate the catch block in the correct context
            $@ = $error;
            my @ret;
            if ( $wantarray ) {
                @ret = $code->();
            } elsif ( defined $wantarray ) {
                $ret[0] = $code->();
            } else {
                $code->();
            };

            $@ = $prev_error;
            return $wantarray ? @ret : $ret[0];
        }

        # rethrow
        die $error;
    }

    # no failure, $@ is back to what it was, everything is fine
    return $wantarray ? @ret : $ret[0];
}


1;
__END__