From be8cfb28cb18499cf6ddfff9eff256d08537dd18 Mon Sep 17 00:00:00 2001 From: Jesse Luehrs Date: Fri, 19 Jul 2013 02:02:33 -0400 Subject: add some (failing) tests --- t/basic.t | 19 ++++++++ t/try/basic.t | 137 ++++++++++++++++++++++++++++++++++++++++++++++++++++ t/try/context.t | 55 +++++++++++++++++++++ t/try/finally.t | 89 ++++++++++++++++++++++++++++++++++ t/try/given_when.t | 31 ++++++++++++ t/try/lib/Error1.pm | 14 ++++++ t/try/lib/Error2.pm | 14 ++++++ t/try/lib/Try.pm | 53 ++++++++++++++++++++ t/try/syntax.t | 33 +++++++++++++ t/try/when.t | 31 ++++++++++++ 10 files changed, 476 insertions(+) create mode 100644 t/basic.t create mode 100644 t/try/basic.t create mode 100644 t/try/context.t create mode 100644 t/try/finally.t create mode 100644 t/try/given_when.t create mode 100644 t/try/lib/Error1.pm create mode 100644 t/try/lib/Error2.pm create mode 100644 t/try/lib/Try.pm create mode 100644 t/try/syntax.t create mode 100644 t/try/when.t diff --git a/t/basic.t b/t/basic.t new file mode 100644 index 0000000..119e586 --- /dev/null +++ b/t/basic.t @@ -0,0 +1,19 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; + +{ + package Foo; + + use Parse::Keyword { bar => \&bar_parser }; + + sub bar { @_ } + sub bar_parser { + return sub { return (1, 2, 3) } + } + + ::is_deeply([bar], [1, 2, 3]); +} + +done_testing; diff --git a/t/try/basic.t b/t/try/basic.t new file mode 100644 index 0000000..9d71138 --- /dev/null +++ b/t/try/basic.t @@ -0,0 +1,137 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use lib 't/try/lib'; + +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"); + 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/try/context.t b/t/try/context.t new file mode 100644 index 0000000..d5ebfe6 --- /dev/null +++ b/t/try/context.t @@ -0,0 +1,55 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use lib 't/try/lib'; + +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/try/finally.t b/t/try/finally.t new file mode 100644 index 0000000..e4ae792 --- /dev/null +++ b/t/try/finally.t @@ -0,0 +1,89 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use lib 't/try/lib'; + +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/try/given_when.t b/t/try/given_when.t new file mode 100644 index 0000000..48d006d --- /dev/null +++ b/t/try/given_when.t @@ -0,0 +1,31 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use lib 't/try/lib'; +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/try/lib/Error1.pm b/t/try/lib/Error1.pm new file mode 100644 index 0000000..eb2d62a --- /dev/null +++ b/t/try/lib/Error1.pm @@ -0,0 +1,14 @@ +package Error1; +use strict; +use warnings; + +use Try; + +try { +} +catch { +} +finallyy { +} + +1; diff --git a/t/try/lib/Error2.pm b/t/try/lib/Error2.pm new file mode 100644 index 0000000..242bdc6 --- /dev/null +++ b/t/try/lib/Error2.pm @@ -0,0 +1,14 @@ +package Error2; +use strict; +use warnings; + +use Try; + +try { +} +finally { +} +catch { +} + +1; diff --git a/t/try/lib/Try.pm b/t/try/lib/Try.pm new file mode 100644 index 0000000..372f10e --- /dev/null +++ b/t/try/lib/Try.pm @@ -0,0 +1,53 @@ +package Try; +use strict; +use warnings; + +use Try::Tiny (); + +use Parse::Keyword { try => \&try_parser }; +use Exporter 'import'; + +our @EXPORT = ('try'); + +sub try { + my ($try, $catch, $finally) = @_; + + &Try::Tiny::try( + $try, + ($catch ? (&Try::Tiny::catch($catch)) : ()), + ($finally ? (&Try::Tiny::finally($finally)) : ()), + ); +} + +sub try_parser { + my ($try, $catch, $finally); + + lex_read_space; + + die "syntax error" unless lex_peek_unichar eq '{'; + $try = parse_block; + + lex_read_space; + + ensure_linestr_len(5); + if (linestr =~ /^catch/) { + lex_read_to(5); + lex_read_space; + die "syntax error" unless lex_peek_unichar eq '{'; + $catch = parse_block; + } + + lex_read_space; + + ensure_linestr_len(7); + if (linestr =~ /^finally/) { + lex_read_to(7); + lex_read_space; + die "syntax error" unless lex_peek_unichar eq '{'; + $finally = parse_block; + } + + return (sub { ($try, $catch, $finally) }, 1); +} + +1; diff --git a/t/try/syntax.t b/t/try/syntax.t new file mode 100644 index 0000000..8e8a6e0 --- /dev/null +++ b/t/try/syntax.t @@ -0,0 +1,33 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use lib 't/try/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 |Can't locate object method "finallyy" via package "1" \(perhaps you forgot to load "1"\?\) at /, +); + +try { + require Error2; +} +catch { + $err = $_; +} +like( + $err, + qr/Can't call method "catch" without a package or object reference at |Can't locate object method "catch" via package "1" \(perhaps you forgot to load "1"\?\) at /, +); + +done_testing; diff --git a/t/try/when.t b/t/try/when.t new file mode 100644 index 0000000..60322b7 --- /dev/null +++ b/t/try/when.t @@ -0,0 +1,31 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use lib 't/try/lib'; +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-54-g00ecf