From 3a43e357719d921e3614ea0e757cb901483cceee Mon Sep 17 00:00:00 2001 From: mamod Date: Fri, 19 Dec 2014 07:51:05 +0300 Subject: [PATCH] v0.002 --- lib/Try/Catch.pm | 83 ++++++++++++++++++++++---------------- t/finally.t | 2 +- t/fork.t | 57 ++++++++++++++++++++++++++ t/nested.t | 101 +++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 209 insertions(+), 34 deletions(-) create mode 100644 t/fork.t create mode 100644 t/nested.t diff --git a/lib/Try/Catch.pm b/lib/Try/Catch.pm index abc3bee..60a7529 100644 --- a/lib/Try/Catch.pm +++ b/lib/Try/Catch.pm @@ -6,73 +6,90 @@ use Data::Dumper; $Carp::Internal{+__PACKAGE__}++; use base 'Exporter'; our @EXPORT = our @EXPORT_OK = qw(try catch finally); -our $VERSION = 0.001; - -my $finally; -my $catch; +our $VERSION = 0.002; sub try(&;@) { my $wantarray = wantarray; - ##copy then reset - #reset blocks and counter - my $catch_code = $catch; - my $finally_code = $finally; - $finally = undef; - $catch = undef; - my $code = shift; + my $try = shift; + my $blocks = shift; + + my ($catch, $finally); + if ($blocks && ref $blocks eq 'HASH'){ + $catch = $blocks->{_try_catch}; + $finally = $blocks->{_try_finally}; + } + my @ret; my $prev_error = $@; - my $fail = not eval { $@ = $prev_error; if (!defined $wantarray) { - $code->(); + $try->(); } elsif (!$wantarray) { - $ret[0] = $code->(); + $ret[0] = $try->(); } else { - @ret = $code->(); + @ret = $try->(); } - return 1; }; - my @args = $fail ? ($@) : (); - $@ = $prev_error; + my $error = $@; + my @args = $fail ? ($error) : (); - if ($fail) { - if ($catch_code) { + if ($fail && $catch) { + my $ret = not eval { + $@ = $prev_error; local $_ = $args[0]; for ($_){ if (!defined $wantarray) { - $catch_code->(@args); + $catch->(@args); } elsif (!$wantarray) { - $ret[0] = $catch_code->(@args); + $ret[0] = $catch->(@args); } else { - @ret = $catch_code->(@args); + @ret = $catch->(@args); } last; ## seems to boost speed by 7% } + return 1; + }; + + if ($ret){ + $finally->(@args) if $finally; + croak $@; } } - - $finally_code->(@args) if $finally_code; + + $@ = $prev_error; + $finally->(@args) if $finally; return $wantarray ? @ret : $ret[0]; } sub catch(&;@) { croak 'Useless bare catch()' unless wantarray; - croak 'One catch block allowed' if $catch; - croak 'Missing semicolon after catch block' if $_[1]; - $catch = $_[0]; - return; + my $ret = { _try_catch => shift }; + if (@_) { + my $prev_block = shift; + if (ref $prev_block ne 'HASH' || !$prev_block->{_try_finally}){ + croak 'Missing semicolon after catch block '; + } + croak 'One catch block allowed' if $prev_block->{_try_catch}; + $ret->{_try_finally} = $prev_block->{_try_finally}; + } + return $ret; } sub finally(&;@) { croak 'Useless bare finally()' unless wantarray; - croak 'One finally block allowed' if $finally; - croak 'Missing semicolon after finally block ' if $_[1]; - $finally = $_[0]; - return; + my $ret = { _try_finally => shift }; + if (@_) { + my $prev_block = shift; + if (ref $prev_block ne 'HASH' || !$prev_block->{_try_catch}){ + croak 'Missing semicolon after finally block '; + } + croak 'One finally block allowed' if $prev_block->{_try_finally}; + $ret->{_try_catch} = $prev_block->{_try_catch}; + } + return $ret; } 1; diff --git a/t/finally.t b/t/finally.t index 171f17d..5fdb13b 100644 --- a/t/finally.t +++ b/t/finally.t @@ -2,7 +2,7 @@ use strict; use warnings; -use Test::More tests => 20; +use Test::More tests => 21; use Try::Catch; diff --git a/t/fork.t b/t/fork.t new file mode 100644 index 0000000..e4aa58a --- /dev/null +++ b/t/fork.t @@ -0,0 +1,57 @@ +use strict; +use warnings; +use Test::More tests => 3; +use Try::Catch; + +{ + package WithCatch; + use Try::Catch; + + sub DESTROY { + try {} + catch {}; + return; + } +} + +{ + package WithFinally; + use Try::Catch; + + sub DESTROY { + try {} + finally {}; + return; + } +} + +my $parent = $$; + +try { + my $pid = fork; + unless ($pid) { + my $o = bless {}, 'WithCatch'; + $SIG{__DIE__} = sub { + exit 1 + if $_[0] =~ /A try\(\) may not be followed by multiple catch\(\) blocks/; + exit 2; + }; + exit 0; + } + waitpid $pid, 0; + is $?, 0, 'nested try in cleanup after fork does not maintain outer catch block'; +} +catch {}; + +try { + my $pid = fork; + unless ($pid) { + my $o = bless {}, 'WithFinally'; + exit 0; + } + waitpid $pid, 0; + is $?, 0, 'nested try in cleanup after fork does not maintain outer finally block'; +} +finally { exit 1 if $parent != $$ }; + +pass("Didn't just exit"); diff --git a/t/nested.t b/t/nested.t new file mode 100644 index 0000000..4d825a6 --- /dev/null +++ b/t/nested.t @@ -0,0 +1,101 @@ +use strict; +use warnings; +use Test::More; +use Try::Catch; + +############################################################# +# this test pass javascript but not this module since we don't +# throw an error if there is no catch block, I'll keep it here +# in order to see if it's a better approach to throw by default +############################################################## +# { +# try { +# try { +# die "inner oops"; +# } +# finally { +# pass("finally called"); +# }; +# } +# catch { +# ok ($_ =~ /^inner oops/); +# }; +# } + + +{ + try { + try { + die "inner oops"; + } + catch { + ok ($_ =~ /^inner oops/); + } + finally { + pass("finally called"); + }; + } + catch { + fail("should not be called"); + }; +} + +{ + try { + try { + die "inner2 oops"; + } + catch { + ok($_ =~ /^inner2 oops/); + die $_; + } + finally { + pass("finally called"); + }; + } + catch { + ok($_ =~ /^inner2 oops/); + }; +} + +{ + my $val = 0; + my @expected; + try { + try { + try { + try { + die "9"; + } catch { + $val = 9; + die $_; + } finally { + try { + push @expected, 1; + is($val, 9, "first finally called"); + die "new Error"; + } catch {}; + }; + } catch { + pass("cach called"); + push @expected, 2; + } finally { + die "second finally called $val\n"; + }; + fail("should not reach here"); + } catch { + $val = 10; + die $_; + } finally { + push @expected, 3; + is ($val, 10, "final finally called"); + }; + fail("should not reach here"); + } catch { + ok ($_ =~ /^second finally called 9/); + }; + is_deeply \@expected, [1,2,3]; +} + +done_testing(10); +1;