From 93dd811c1233c3e9d28d92a56166436a81c3e854 Mon Sep 17 00:00:00 2001 From: Jesse Luehrs Date: Sat, 18 Aug 2012 15:08:00 -0500 Subject: first implementation --- Try.xs | 82 +++++++++++++++++++++++++++++++++ dist.ini | 3 ++ lib/Try.pm | 28 ++++++++++++ t/basic.t | 137 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ t/context.t | 54 ++++++++++++++++++++++ t/finally.t | 88 ++++++++++++++++++++++++++++++++++++ t/given_when.t | 30 +++++++++++++ t/lib/Error1.pm | 14 ++++++ t/lib/Error2.pm | 14 ++++++ t/syntax.t | 33 ++++++++++++++ t/when.t | 30 +++++++++++++ 11 files changed, 513 insertions(+) create mode 100644 Try.xs create mode 100644 t/basic.t create mode 100644 t/context.t create mode 100644 t/finally.t create mode 100644 t/given_when.t create mode 100644 t/lib/Error1.pm create mode 100644 t/lib/Error2.pm create mode 100644 t/syntax.t create mode 100644 t/when.t 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; -- cgit v1.2.3