first commit

.travis.yml

@@ -0,0 +1,4 @@
+language: perl
+perl:
+  - "5.16"
+  - "5.14"

Changes

@@ -0,0 +1,5 @@
+Revision history for Perl extension Try::Catch.
+
+0.01  Thu Dec 18 23:25:21 2012
+	- original version; created by h2xs 1.23 with options
+		-X -n URI::Simple

MANIFEST

@@ -0,0 +1,13 @@
+.travis.yml
+Changes
+lib/Try/Catch.pm
+Makefile.PL
+MANIFEST			This list of files
+README.md
+t/basic.t
+t/context.t
+t/erroneous_usage.t
+t/finally.t
+t/given_when.t
+t/global_destruction_forked.t
+t/when.t

Makefile.PL

@@ -0,0 +1,12 @@
+use 5.010001;
+use ExtUtils::MakeMaker;
+# See lib/ExtUtils/MakeMaker.pm for details of how to influence
+# the contents of the Makefile that is written.
+WriteMakefile(
+    NAME              => 'Try::Catch',
+    VERSION_FROM      => 'lib/Try/Catch.pm', # finds $VERSION
+    PREREQ_PM         => {}, # none
+    ($] >= 5.005 ?     ## Add these new keywords supported since 5.005
+      (ABSTRACT_FROM  => 'lib/Try/Catch.pm', # retrieve abstract from module
+       AUTHOR         => 'Mamod A. Mehyar <[email protected]>') : ())
+);

README.md

@@ -0,0 +1,9 @@
+Try-Catch version 0.001
+========================
+
+A Try::Tiny Copy with Speed in mind
+
+USAGE
+=====
+
+Same as Try::Tiny

bench/trycatch.pl

@@ -0,0 +1,83 @@
+use strict;
+use warnings;
+use lib '../lib';
+use Try::Catch();
+use Try::Tiny();
+
+use Benchmark qw(:all) ;
+
+##simple
+cmpthese(100000, {
+    'Try::Tiny' => sub {
+        Try::Tiny::try {
+
+        }  Try::Tiny::catch {
+
+        };
+    },
+    'Try::Catch' => sub {
+        Try::Catch::try {
+
+        }  Try::Catch::catch {
+
+        };
+    },
+});
+
+##try dies
+cmpthese(100000, {
+    'Try::Tiny Dies' => sub {
+        my @t = Try::Tiny::try {
+            die "foo";
+        }  Try::Tiny::catch {
+
+        };
+    },
+    'Try::Catch Dies' => sub {
+        my @t = Try::Catch::try {
+            die "foo";
+        }  Try::Catch::catch {
+
+        };
+    },
+});
+
+##try finally no die
+cmpthese(100000, {
+    'Try::Tiny Finally no die' => sub {
+        my @t = Try::Tiny::try {
+
+        }  Try::Tiny::finally {
+
+        };
+    },
+    'Try::Catch finally no die' => sub {
+        my @t = Try::Catch::try {
+
+        }  Try::Catch::finally {
+
+        };
+    },
+});
+
+###try catch and finally blocks
+cmpthese(100000, {
+    'Try::Tiny with finally' => sub {
+        Try::Tiny::try {
+            die "foo";
+        } Try::Tiny::catch {
+
+        } Try::Tiny::finally {
+
+        };
+    },
+    'Try::Catch with finally' => sub {
+        Try::Catch::try {
+            die "foo";
+        }  Try::Catch::catch {
+
+        } Try::Catch::finally {
+
+        };
+    }
+});

lib/Try/Catch.pm

@@ -0,0 +1,87 @@
+package Try::Catch;
+use strict;
+use warnings;
+use Carp;
+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;
+
+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 @ret;
+    my $prev_error = $@;
+
+    my $fail = not eval {
+        $@ = $prev_error;
+        if (!defined $wantarray) {
+            $code->();
+        } elsif (!$wantarray) {
+            $ret[0] = $code->();
+        } else {
+            @ret = $code->();
+        }
+
+        return 1;
+    };
+
+    my @args = $fail ? ($@) : ();
+    $@ = $prev_error;
+
+    if ($fail) {
+        if ($catch_code) {
+            local $_ = $args[0];
+            for ($_){
+                if (!defined $wantarray) {
+                    $catch_code->(@args);
+                } elsif (!$wantarray) {
+                    $ret[0] = $catch_code->(@args);
+                } else {
+                    @ret = $catch_code->(@args);
+                }
+                last; ## seems to boost speed by 7%
+            }
+        }
+    }
+
+    $finally_code->(@args) if $finally_code;
+    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;
+}
+
+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;
+}
+
+1;
+
+__END__
+=head1 NAME
+
+Try::Catch - A Try::Tiny copy with speed in mind
+
+=head1 USAGE
+
+Same as Try::Tiny

t/basic.t

@@ -0,0 +1,158 @@
+use strict;
+use warnings;
+
+use Test::More;
+
+use Try::Catch;
+
+sub _eval {
+  local $@;
+  local $Test::Builder::Level = $Test::Builder::Level + 2;
+  return ( scalar(eval { $_[0]->(); 1 }), $@ );
+}
+
+sub lives_ok (&$) {
+  my ( $code, $desc ) = @_;
+  local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+  my ( $ok, $error ) = _eval($code);
+
+  ok($ok, $desc );
+
+  diag "error: $@" unless $ok;
+}
+
+
+sub throws_ok (&$$) {
+  my ( $code, $regex, $desc ) = @_;
+  local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+  my ( $ok, $error ) = _eval($code);
+
+  if ( $ok ) {
+    fail($desc);
+  } else {
+    like($error || '', $regex, $desc );
+  }
+}
+
+
+my $prev;
+
+lives_ok {
+  try {
+    die "foo";
+  };
+} "basic try";
+
+
+throws_ok {
+  try {
+    die "foo";
+  } catch { die $_ };
+} qr/foo/, "rethrow";
+
+
+{
+  local $@ = "magic";
+  is( try { 42 }, 42, "try block evaluated" );
+  is( $@, "magic", '$@ untouched' );
+}
+
+{
+  local $@ = "magic";
+  is( try { die "foo" }, undef, "try block died" );
+  is( $@, "magic", '$@ untouched' );
+}
+
+{
+  local $@ = "magic";
+  like( (try { die "foo" } catch { $_ }), qr/foo/, "catch block evaluated" );
+  is( $@, "magic", '$@ untouched' );
+}
+#
+is( scalar(try { "foo", "bar", "gorch" }), "gorch", "scalar context try" );
+is_deeply( [ try {qw(foo bar gorch)} ], [qw(foo bar gorch)], "list context try" );
+#
+is( scalar(try { die } catch { "foo", "bar", "gorch" }), "gorch", "scalar context catch" );
+is_deeply( [ try { die } catch {qw(foo bar gorch)} ], [qw(foo bar gorch)], "list context catch" );
+
+
+lives_ok {
+  try {
+    die "foo";
+  } catch {
+    my $err = shift;
+
+    try {
+      like $err, qr/foo/;
+    } catch {
+      fail("shouldn't happen");
+    };
+
+    pass "got here";
+  }
+} "try in try catch block";
+
+throws_ok {
+  try {
+    die "foo";
+  } catch {
+    my $err = shift;
+
+    try { } catch { };
+
+    die "rethrowing $err";
+  }
+} qr/rethrowing foo/, "rethrow with try in catch block";
+
+
+sub Evil::DESTROY {
+  eval { "oh noes" };
+}
+
+sub Evil::new { bless { }, $_[0] }
+
+{
+  local $@ = "magic";
+  local $_ = "other magic";
+
+  try {
+    my $object = Evil->new;
+    die "foo";
+  } catch {
+    pass("catch invoked");
+    local $TODO = "i don't think we can ever make this work sanely, maybe with SIG{__DIE__}" if $] < 5.014;
+    like($_, qr/foo/);
+  };
+
+  is( $@, "magic", '$@ untouched' );
+  is( $_, "other magic", '$_ untouched' );
+}
+
+
+{
+  my ( $caught, $prev );
+
+  {
+    local $@;
+
+    eval { die "bar\n" };
+
+    is( $@, "bar\n", 'previous value of $@' );
+
+    try {
+      die {
+        prev => $@,
+      }
+    } catch {
+      $caught = $_;
+      $prev = $@;
+    }
+  }
+
+  is_deeply( $caught, { prev => "bar\n" }, 'previous value of $@ available for capture' );
+  is( $prev, "bar\n", 'previous value of $@ also available in catch block' );
+}
+
+done_testing();