summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorJesse Luehrs <doy@tozt.net>2012-08-18 15:08:00 -0500
committerJesse Luehrs <doy@tozt.net>2012-08-18 16:25:59 -0500
commit93dd811c1233c3e9d28d92a56166436a81c3e854 (patch)
tree56710060e64212f37f85a651c5174c3523bd5bb1
parente590eb7516d6c3533254fb85699473e43ac9c8d8 (diff)
downloadtry-93dd811c1233c3e9d28d92a56166436a81c3e854.tar.gz
try-93dd811c1233c3e9d28d92a56166436a81c3e854.zip
first implementation
-rw-r--r--Try.xs82
-rw-r--r--dist.ini3
-rw-r--r--lib/Try.pm28
-rw-r--r--t/basic.t137
-rw-r--r--t/context.t54
-rw-r--r--t/finally.t88
-rw-r--r--t/given_when.t30
-rw-r--r--t/lib/Error1.pm14
-rw-r--r--t/lib/Error2.pm14
-rw-r--r--t/syntax.t33
-rw-r--r--t/when.t30
11 files changed, 513 insertions, 0 deletions
diff --git a/Try.xs b/Try.xs
new file mode 100644
index 0000000..59f9b64
--- /dev/null
+++ b/Try.xs
@@ -0,0 +1,82 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "callparser1.h"
+#include "XSUB.h"
+
+static int check_keyword(const char *keyword)
+{
+ STRLEN len;
+
+ len = strlen(keyword);
+ if (PL_parser->bufend - PL_parser->bufptr < len) {
+ return 0;
+ }
+
+ if (strnNE(PL_parser->bufptr, keyword, len)) {
+ return 0;
+ }
+
+ if (PL_parser->bufptr + len != PL_parser->bufend
+ && isALNUM(*(PL_parser->bufptr + len))) {
+ return 0;
+ }
+
+ lex_read_to(PL_parser->bufptr + len);
+
+ return 1;
+}
+
+static OP *parse_try(pTHX_ GV *namegv, SV *psobj, U32 *flagsp)
+{
+ OP *try, *catch, *finally, *ret;
+ I32 floor;
+
+ *flagsp |= CALLPARSER_STATEMENT;
+
+ lex_read_space(0);
+ if (*(PL_parser->bufptr) != '{') {
+ croak("syntax error");
+ }
+ floor = start_subparse(0, CVf_ANON);
+ try = newANONSUB(floor, NULL, parse_block(0));
+
+ lex_read_space(0);
+ if (check_keyword("catch")) {
+ lex_read_space(0);
+ if (*(PL_parser->bufptr) != '{') {
+ croak("syntax error");
+ }
+ floor = start_subparse(0, CVf_ANON);
+ catch = newANONSUB(floor, NULL, parse_block(0));
+ }
+ else {
+ catch = newOP(OP_UNDEF, 0);
+ }
+
+ lex_read_space(0);
+ if (check_keyword("finally")) {
+ lex_read_space(0);
+ if (*(PL_parser->bufptr) != '{') {
+ croak("syntax error");
+ }
+ floor = start_subparse(0, CVf_ANON);
+ finally = newANONSUB(floor, NULL, parse_block(0));
+ }
+ else {
+ finally = newOP(OP_UNDEF, 0);
+ }
+
+ ret = newLISTOP(OP_LIST, 0, try, catch);
+ op_append_elem(OP_LIST, ret, finally);
+
+ return ret;
+}
+
+MODULE = Try PACKAGE = Try
+
+PROTOTYPES: DISABLE
+
+BOOT:
+{
+ cv_set_call_parser(get_cv("Try::try", 0), parse_try, &PL_sv_undef);
+}
diff --git a/dist.ini b/dist.ini
index 96399b3..1c1ddc6 100644
--- a/dist.ini
+++ b/dist.ini
@@ -7,5 +7,8 @@ copyright_holder = Jesse Luehrs
:version = 0.08
dist = Try
repository = github
+awesome = =inc::MakeMaker
[AutoPrereqs]
+[Prereqs]
+perl = 5.014
diff --git a/lib/Try.pm b/lib/Try.pm
index e69de29..d85d497 100644
--- a/lib/Try.pm
+++ b/lib/Try.pm
@@ -0,0 +1,28 @@
+package Try;
+use strict;
+use warnings;
+# ABSTRACT: nicer exception handling syntax
+
+use Devel::CallParser;
+use XSLoader;
+
+XSLoader::load(
+ __PACKAGE__,
+ exists $Try::{VERSION} ? ${ $Try::{VERSION} } : (),
+);
+
+use Exporter 'import';
+our @EXPORT = ('try');
+
+use Try::Tiny ();
+
+sub try {
+ my ($try, $catch, $finally) = @_;
+ &Try::Tiny::try(
+ $try,
+ ($catch ? (&Try::Tiny::catch($catch)) : ()),
+ ($finally ? (&Try::Tiny::finally($finally)) : ()),
+ );
+}
+
+1;
diff --git a/t/basic.t b/t/basic.t
new file mode 100644
index 0000000..0e2e324
--- /dev/null
+++ b/t/basic.t
@@ -0,0 +1,137 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+
+use Try;
+
+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";
+ }
+ pass("syntax ok");
+} "basic try";
+
+throws_ok {
+ try {
+ die "foo";
+ } catch { die $_ }
+ pass("syntax ok");
+} qr/foo/, "rethrow";
+
+lives_ok {
+ try {
+ die "foo";
+ } catch {
+ my $err = shift;
+
+ try {
+ like $err, qr/foo/;
+ } catch {
+ fail("shouldn't happen");
+ }
+
+ pass "got here";
+ }
+ pass("syntax ok");
+} "try in try catch block";
+
+throws_ok {
+ try {
+ die "foo";
+ } catch {
+ my $err = shift;
+
+ try { } catch { }
+ pass("syntax ok");
+
+ die "rethrowing $err";
+ }
+ pass("syntax ok");
+} 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__}";
+ like($_, qr/foo/);
+ }
+ pass("syntax ok");
+
+ 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 = $@;
+ }
+ pass("syntax ok");
+ }
+
+ 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;
diff --git a/t/context.t b/t/context.t
new file mode 100644
index 0000000..d35f97f
--- /dev/null
+++ b/t/context.t
@@ -0,0 +1,54 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+
+use Try;
+
+my $ctx_index = {
+ VOID => undef,
+ LIST => 1,
+ SCALAR => '',
+};
+my ($ctx, $die);
+
+for (sort keys %$ctx_index) {
+ $ctx = $_;
+ for (0,1) {
+ $die = $_;
+ if ($ctx_index->{$ctx}) {
+ is_deeply(
+ [ run() ],
+ [ $die ? 'catch' : 'try' ],
+ );
+ }
+ elsif (defined $ctx_index->{$ctx}) {
+ is_deeply(
+ [ scalar run() ],
+ [ $die ? 'catch' : 'try' ],
+ );
+ }
+ else {
+ run();
+ 1;
+ }
+ }
+}
+
+sub run {
+ try {
+ is (wantarray, $ctx_index->{$ctx}, "Proper context $ctx in try{}");
+ die if $die;
+ return 'try';
+ }
+ catch {
+ is (wantarray, $ctx_index->{$ctx}, "Proper context $ctx in catch{}");
+ return 'catch';
+ }
+ finally {
+ is (wantarray, undef, "Proper VOID context in finally{}");
+ return 'finally';
+ }
+}
+
+done_testing;
diff --git a/t/finally.t b/t/finally.t
new file mode 100644
index 0000000..216f699
--- /dev/null
+++ b/t/finally.t
@@ -0,0 +1,88 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+
+use Try;
+
+try {
+ my $a = 1+1;
+} catch {
+ fail('Cannot go into catch block because we did not throw an exception')
+} finally {
+ pass('Moved into finally from try');
+}
+
+try {
+ die('Die');
+} catch {
+ ok($_ =~ /Die/, 'Error text as expected');
+ pass('Into catch block as we died in try');
+} finally {
+ pass('Moved into finally from catch');
+}
+
+try {
+ die('Die');
+} finally {
+ pass('Moved into finally block when try throws an exception and we have no catch block');
+}
+
+try {
+ # do not die
+} finally {
+ if (@_) {
+ fail("errors reported: @_");
+ } else {
+ pass("no error reported") ;
+ }
+}
+
+try {
+ die("Die\n");
+} finally {
+ is_deeply(\@_, [ "Die\n" ], "finally got passed the exception");
+}
+
+try {
+ try {
+ die "foo";
+ }
+ catch {
+ die "bar";
+ }
+ finally {
+ pass("finally called");
+ }
+ pass("syntax ok");
+}
+
+$_ = "foo";
+try {
+ is($_, "foo", "not localized in try");
+}
+catch {
+}
+finally {
+ is(scalar(@_), 0, "nothing in \@_ (finally)");
+ is($_, "foo", "\$_ not localized (finally)");
+}
+is($_, "foo", "same afterwards");
+
+$_ = "foo";
+try {
+ is($_, "foo", "not localized in try");
+ die "bar\n";
+}
+catch {
+ is($_[0], "bar\n", "error in \@_ (catch)");
+ is($_, "bar\n", "error in \$_ (catch)");
+}
+finally {
+ is(scalar(@_), 1, "error in \@_ (finally)");
+ is($_[0], "bar\n", "error in \@_ (finally)");
+ is($_, "foo", "\$_ not localized (finally)");
+}
+is($_, "foo", "same afterwards");
+
+done_testing;
diff --git a/t/given_when.t b/t/given_when.t
new file mode 100644
index 0000000..3c18e0d
--- /dev/null
+++ b/t/given_when.t
@@ -0,0 +1,30 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+use 5.014;
+
+use Try;
+
+my ( $error, $topic );
+
+given ("foo") {
+ when (qr/./) {
+ try {
+ die "blah\n";
+ } catch {
+ $topic = $_;
+ $error = $_[0];
+ }
+ pass("syntax ok");
+ };
+}
+
+is( $error, "blah\n", "error caught" );
+
+{
+ local $TODO = "perhaps a workaround can be found";
+ is( $topic, $error, 'error is also in $_' );
+}
+
+done_testing;
diff --git a/t/lib/Error1.pm b/t/lib/Error1.pm
new file mode 100644
index 0000000..eb2d62a
--- /dev/null
+++ b/t/lib/Error1.pm
@@ -0,0 +1,14 @@
+package Error1;
+use strict;
+use warnings;
+
+use Try;
+
+try {
+}
+catch {
+}
+finallyy {
+}
+
+1;
diff --git a/t/lib/Error2.pm b/t/lib/Error2.pm
new file mode 100644
index 0000000..242bdc6
--- /dev/null
+++ b/t/lib/Error2.pm
@@ -0,0 +1,14 @@
+package Error2;
+use strict;
+use warnings;
+
+use Try;
+
+try {
+}
+finally {
+}
+catch {
+}
+
+1;
diff --git a/t/syntax.t b/t/syntax.t
new file mode 100644
index 0000000..2ca4559
--- /dev/null
+++ b/t/syntax.t
@@ -0,0 +1,33 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+use lib 't/lib';
+
+use Try;
+
+my $err;
+
+try {
+ require Error1;
+}
+catch {
+ $err = $_;
+}
+like(
+ $err,
+ qr/Can't call method "finallyy" without a package or object reference at /,
+);
+
+try {
+ require Error2;
+}
+catch {
+ $err = $_;
+}
+like(
+ $err,
+ qr/Can't call method "catch" without a package or object reference at /,
+);
+
+done_testing;
diff --git a/t/when.t b/t/when.t
new file mode 100644
index 0000000..3d9ad62
--- /dev/null
+++ b/t/when.t
@@ -0,0 +1,30 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+use 5.014;
+
+use Try;
+
+my ( $foo, $bar, $other );
+
+$_ = "magic";
+
+try {
+ die "foo";
+} catch {
+
+ like( $_, qr/foo/ );
+
+ when (/bar/) { $bar++ };
+ when (/foo/) { $foo++ };
+ default { $other++ };
+}
+
+is( $_, "magic", '$_ not clobbered' );
+
+ok( !$bar, "bar didn't match" );
+ok( $foo, "foo matched" );
+ok( !$other, "fallback didn't match" );
+
+done_testing;