add some (failing) tests

10 files changed, 476 insertions, 0 deletions

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;