File Coverage

blib/lib/Try/Catch.pm

Criterion	Covered	Total	%
statement	62	62	100.0
branch	34	34	100.0
condition	4	6	66.6
subroutine	8	8	100.0
pod	3	3	100.0
total	111	113	98.2

package Try::Catch;
use strict;
use warnings;
use Carp;
$Carp::Internal{+__PACKAGE__}++;
use base 'Exporter';
our @EXPORT = our @EXPORT_OK = qw(try catch finally);
our $VERSION = '1.1.0';

sub _default_catch {
    croak $_[0];
}

sub try(&;@) {
    my $wantarray =  wantarray;
    my $try       = shift;
    my $caller    = pop;
    my $finally   = pop;
    my $catch     = pop;

    if (!$caller || $caller ne __PACKAGE__){
        croak "syntax error after try block \n" .
                "usage : \n" .
                "try { ... } catch { ... }; \n" .
                "try { ... } finally { ... }; \n" .
                "try { ... } catch { ... } finally { ... }; ";
    }

    #sane behaviour is to throw an error
    #if there is no catch block
    if (!$catch){
        $catch = \&_default_catch;
    }

    my @ret;
    my $prev_error = $@;
    my $fail = not eval {
        $@ = $prev_error;
        if (!defined $wantarray) {
            $try->();
        } elsif (!$wantarray) {
            $ret[0] = $try->();
        } else {
            @ret = $try->();
        }
        return 1;
    };

    my $error = $@;

    if ($fail) {
        my $ret = not eval {
            $@ = $prev_error;
            for ($error) {
                if (!defined $wantarray) {
                    $catch->($error);
                } elsif (!$wantarray) {
                    $ret[0] = $catch->($error);
                } else {
                    @ret = $catch->($error);
                }
                last; ## seems to boost speed by 7%
            }
            return 1;
        };

        if ($ret){
            my $catch_error = $@;
            if ($finally) {
                $@ = $prev_error;
                $finally->($error);
            }
            croak $catch_error;
        }
    }

    if ($finally) {
        $@ = $prev_error;
        $finally->( $fail ? $error : () );
    }

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

sub catch(&;@) {
    croak 'Useless bare catch()' unless wantarray;
    if (@_ > 1){
        croak "syntax error after catch block - maybe a missing semicolon"
            if !$_[2] || $_[2] ne __PACKAGE__;
    } else {
        return ( shift,  undef, __PACKAGE__);
    }
    return (@_);
}

sub finally(&;@) {
    croak 'Useless bare finally()' unless wantarray;
    if (@_ > 1) {
        croak "syntax error after finally block - maybe a missing semicolon";
    }
    return ( shift, __PACKAGE__ );
}

1;

__END__