libtry-tiny-smartcatch-perl 0.5-1 / usr / share / perl5 / Try / Tiny / SmartCatch.pm

package Try::Tiny::SmartCatch;

use 5.006;
use strict;
use warnings;

use vars qw/@EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION @ISA/;

BEGIN {
    require Exporter;
    @ISA = qw/Exporter/;
}

@EXPORT = qw/try catch_when catch_default then finally/;
@EXPORT_OK = (@EXPORT, qw/throw/);
%EXPORT_TAGS = (
    all => [@EXPORT_OK],
);

++$Carp::Internal{+__PACKAGE__};

$VERSION = '0.5';

sub try($;@) {
    my ($try, @code_refs) = @_;

    my ($catch_default, @catch_when, $code_ref, @finally, $ref_type, $then, $wantarray);

    $wantarray = wantarray ();

    foreach $code_ref (@code_refs) {
        next if (!$code_ref);

        $ref_type = ref($code_ref);

        ## zero or more 'catch_when' blocks
        if ($ref_type eq 'Try::Tiny::SmartCatch::Catch::When') {
            ## we need to save same handler for many different exception types
            push(@catch_when, $code_ref);
        }
        ## zero or one 'catch_default' blocks
        elsif ($ref_type eq 'Try::Tiny::SmartCatch::Catch::Default') {
            $catch_default = $$code_ref{code}
                if (!defined($catch_default));
        }
        ## zero or more 'finally' blocks
        elsif ($ref_type eq 'Try::Tiny::SmartCatch::Finally') {
            push(@finally, $$code_ref);
        }
        ## zero or one 'then' blocks
        elsif ($ref_type eq 'Try::Tiny::SmartCatch::Then') {
            $then = $$code_ref
                if (!defined($then));
        }
        ## unknown block type
        else {
            require Carp;
            Carp::confess("Unknown code ref type given '$ref_type'. Check your usage & try again");
        }
    }

    my ($error, $failed, $prev_error, @ret);

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

    {
        ## localize $@ to prevent clobbering of previous value by a successful eval.
        local $@;

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

            ## call try block in list context if try subroutine is called in list context, or we have 'then' block
            ## result of 'try' block is passed as arguments to then block, so we need do that in that way
            if ($wantarray || $then) {
                @ret = &$try();
            }
            elsif (defined($wantarray)) {
                $ret[0] = &$try();
            }
            else {
                &$try();
            }

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

        ## copy $@ to $error; when we leave this scope, local $@ will revert $@
        ## back to its previous value
        $error = $@;
    }

    ## set up a scope guard to invoke the finally block at the end
    my @guards = (
        map {
            Try::Tiny::SmartCatch::ScopeGuard->_new($_, $failed ? $error : ())
        } @finally
    );

    ## at this point $failed contains a true value if the eval died, even if some
    ## destructor overwrote $@ as the eval was unwinding.
    if ($failed) {
        ## if we got an error, invoke the catch block.
        if (scalar(@catch_when) || $catch_default) {

            ## This works like given($error), but is backwards compatible and
            ## sets $_ in the dynamic scope for the body of $catch
            for ($error) {
                my ($catch_data);
                foreach $catch_data (@catch_when) {
                    return &{$$catch_data{code}}($error)
                        if ($catch_data->for_error($error));
                }

                return &$catch_default($error)
                    if ($catch_default);

                die($error);
            }
        }

        return;
    }

    ## no failure, $@ is back to what it was, everything is fine
    else {
        ## do we have then block? if we does, execute it in correct context
        if ($then) {
            if ($wantarray) {
                @ret = &$then(@ret);
            }
            elsif (defined($wantarray)) {
                $ret[0] = &$then(@ret);
            }
            else {
                &$then(@ret);
            }
        }

        return if (!defined($wantarray));
        return $wantarray ? @ret : $ret[0];
    }
}

sub catch_when ($$;@) {
    my ($types, $block) = (shift(@_), shift(@_));

    my $catch = Try::Tiny::SmartCatch::Catch::When->new($block, $types);

    return ($catch, @_);
}

sub catch_default ($;@) {
    my $block = shift(@_);

    my $catch = Try::Tiny::SmartCatch::Catch::Default->new($block);

    return ($catch, @_);
}

sub then ($;@) {
    my $block = shift(@_);

    my $then = bless(\$block, 'Try::Tiny::SmartCatch::Then');

    return ($then, @_);
}

sub finally ($;@) {
    my $block = shift(@_);

    my $finally = bless(\$block, 'Try::Tiny::SmartCatch::Finally');

    return ($finally, @_);
}

sub throw {
    return die (@_);
}

package # hide from PAUSE
    Try::Tiny::SmartCatch::ScopeGuard;
{

    sub _new {
        shift(@_);
        return bless([ @_ ]);
    }

    sub DESTROY {
        my ($guts) = @_;

        my $code = shift(@$guts);
        return &$code(@$guts);
    }
}

package Try::Tiny::SmartCatch::Catch::Default;
{
    sub new {
        my ($class, $code) = @_;

        my $self = { code => $code };
        $self    = bless($self, $class);

        return $self;
    }
}

package Try::Tiny::SmartCatch::Catch::When;
{
    use Scalar::Util qw/blessed/;

    sub new {
        my ($class, $code, $types) = @_;

        my $self = {
            code  => $code,
            types => (
                ref($types) eq 'ARRAY' ? $types   :
                defined($types)        ? [$types] :
                                         []
            ),
        };

        return bless($self, $class);
    }

    sub for_error {
        my ($self, $error, $types) = @_;

        $types = $$self{types}
            if (!defined($types));
        $types = [$types]
            if (ref($types) ne 'ARRAY');

        if (blessed($error)) {
            foreach (@$types) {
                return 1 if ($error->isa($_));
            }
        }
        else {
            my $type;
            foreach $type (@$types) {
                return 1 if (
                    (ref($type) eq 'Regexp' && $error =~ /$type/) ||
                    (!ref($type) && index($error, $type) > -1)
                );
            }
        }

        return;
    }

}


1;

__END__

=head1 NAME

Try::Tiny::SmartCatch - lightweight Perl module for powerful exceptions handling

=head1 VERSION

Version 0.5

=head1 SYNOPSIS

    use Try::Tiny::SmartCatch;

    try sub {}, # at least one try block
    catch_when 'ExceptionName' => sub {}, # zero or more catch_when blocks
    catch_when 'exception message' => sub {},
    catch_when qr/exception  message regexp/ => sub {},
    catch_default sub {}, # zero or one catch_default block
    then sub {}, # if no exception is raised, execute then block
    finally sub {}; #zero or more finally blocks
    
    use Try::Tiny::SmartCatch qw/throw/; # import only throw
    # You can import also all function at once:
    # use Try::Tiny::SmartCatch qw/:all/;
    throw('some exception');
    throw(SomeException->new ('message'));

=head1 DESCRIPTION

Goals are mostly the same as L<Try::Tiny> module, but there are few changes
to it's specification. Main difference is possibility to catch just some kinds
of exceptions in place of catching everything. Another one is slightly changed
syntax.

When raised exception is an object, L<Try::Tiny::SmartCatch> will test for
exception type (using C<UNIVERSAL::isa>). When raised exception is just
a text message (like: C<die ('message')>), there can be specified part of
message to test for.

There are also explicit C<sub> blocks. In opposite to C<Try::Tiny>,
every block in C<Try::Tiny::SmartCatch>: C<try>, C<catch_when>, C<catch_default>,
C<then> and C<finally> must have explicit subroutines specified. Thanks to trick
with function prototype, calling C<Try::Tiny::try> or C<Try::Tiny::catch>
creates implicit subroutines:

    sub test_function {
        try {
            # yes, here is implicit subroutine!
            # return statement here exits just from try block,
            # not from test_function!
            return 1;
        };
    
        say 'Hello!';
    }
    
    test_function();

Above snippet produces us text on STDOUT: C<Hello!>

But more obvious would be no output... (by C<return> statement). This is because of
implicit subroutine created with braces: C<{}> after C<try>,
 C<catch> or C<finally> from C<Try::Tiny>. C<Try::Tiny::SmartCatch> is
more explicit - you must always use C<sub> when defining blocks (look
at [Syntax](#Syntax) above).

An exception object or message is passed to defined blocks in two ways:
* in C<$_> variable
* as function arguments, so through C<@_> array.

L<Try::Tiny::SmartCatch> defines also C<throw> function (not imported
by default). Currently it is an alias for C<die>, but is more explicit then C<die> :)

It can be imported separately:

    use Try::Tiny::SmartCatch qw/throw/;

Or with rest of functions:

    use Try::Tiny::SmartCatch qw/:all/;

=head1 EXPORT

By default exported are functions:

=over

=item try

=item catch_when

=item catch_default

=item then

=item finally

=back

You can also explicit import C<throw> function:

    use Try::Tiny::SmartCatch qw/throw/;

Or all functions at all:

    use Try::Tiny::SmartCatch qw/:all/;

=head1 SUBROUTINES/METHODS

=head2 try($;@)

Works like L<Try::Tiny> C<try> subroutine, here is nothing to add :)

The only difference is that here must be given evident sub reference, not anonymous block:

    try sub {
        # some code
    };

=head2 catch_when($$;@)

Intended to be used in the second argument position of C<try>.

Works similarly to L<Try::Tiny> C<catch> subroutine, but have a little different syntax:

    try sub {
        # some code
    },
    catch_when 'Exception1' => sub {
        # catch only Exception1 exception
    },
    catch_when ['Exception1', 'Exception2'] => sub {
        # catch Exception2 or Exception3 exceptions
    };

If raised exception is a blessed reference (or object), C<Exception1> means that exception
class has to be or inherits from C<Exception1> class. In other case, it search for given
string in exception message (using C<index> function or regular expressions - depending on
type of given operator). For example:

    try sub {
        throw('some exception message');
    },
    catch_when 'exception' => sub {
        say 'exception caught!';
    };

Other case:

    try sub {
        throw('some exception3 message');
    },
    catch_when qr/exception\d/ => sub {
        say 'exception caught!';
    };

Or:

    try sub {
        # ValueError extends RuntimeError
        throw(ValueError->new ('Some error message'));
    },
    catch_when 'RuntimeError' => sub {
        say 'RuntimeError exception caught!';
    };

=head2 catch_default($;@)

Works exactly like L<Try::Tiny> C<catch> function (OK, there is difference:
need to specify evident sub block instead of anonymous block):

    try sub {
        # some code
    },
    catch_default sub {
        say 'caught every exception';
    };

=head2 then($;@)

C<then> block is executed after C<try> clause, if none of C<catch_when> or
C<catch_default> blocks was executed (it means, if no exception occured).
It's executed before C<finally> blocks.

    try sub {
        # some code
    },
    catch_when 'MyException' => sub {
        say 'caught MyException exception';
    },
    then sub {
        say 'No exception was raised';
    },
    finally sub {
        say 'executed always';
    };

=head2 finally($;@)

Works exactly like L<Try::Tiny> C<finally> function (OK, again, explicit sub
instead of implicit):

    try sub {
        # some code
    },
    finally sub {
        say 'executed always';
    };

=head2 throw

Currently it's an alias to C<die> function, but C<throw> is more obvious then C<die> when working with exceptions :)

In future it also can do more then just call C<die>.

It's not exported by default (see: L</EXPORT>)

=head1 SEE ALSO

=over 4

=item L<https://github.com/mysz/try-tiny-smartcatch>

Try::Tiny::SmartCatch home.

=item L<Try::Tiny>

Minimal try/catch with proper localization of $@, base of L<Try::Tiny::SmartCatch>

=item L<TryCatch>

First class try catch semantics for Perl, without source filters.

=back

=head1 AUTHOR

Marcin Sztolcman, C<< <marcin at urzenia.net> >>

=head1 BUGS

Please report any bugs or feature requests through the web interface at
L<http://github.com/mysz/try-tiny-smartcatch/issues>.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Try::Tiny::SmartCatch

You can also look for information at:

=over 4

=item * Try::Tiny::SmartCatch home & source code

L<http://github.com/mysz/try-tiny-smartcatch>

=item * Issue tracker (report bugs here)

L<http://github.com/mysz/try-tiny-smartcatch/issues>

=item * Search CPAN

L<http://search.cpan.org/dist/Try-Tiny-SmartCatch/>

=back

=head1 ACKNOWLEDGEMENTS

=over

=item Yuval Kogman

for his L<Try::Tiny> module

=item mst - Matt S Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>

for good package name and few great features

=back

=head1 LICENSE AND COPYRIGHT

    Copyright (c) 2012-2013 Marcin Sztolcman. All rights reserved.

    Base code is borrowed from Yuval Kogman L<Try::Tiny> module,
    released under MIT License.

    This program is free software; you can redistribute
    it and/or modify it under the terms of the MIT license.

=cut