v0.002

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;

t/finally.t

@@ -2,7 +2,7 @@
 
 use strict;
 use warnings;
-use Test::More tests => 20;
+use Test::More tests => 21;
 
 use Try::Catch;
 

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");

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;