From 597610ad1c915a5b004148fdb3151b0cec976790 Mon Sep 17 00:00:00 2001 From: Jesse Luehrs Date: Sun, 21 Jul 2013 16:50:34 -0400 Subject: add tests for Fun --- dist.ini | 2 +- t/fun/anon.t | 17 +++++ t/fun/basic.t | 34 ++++++++++ t/fun/closure-proto.t | 20 ++++++ t/fun/compile-time.t | 13 ++++ t/fun/defaults.t | 58 ++++++++++++++++ t/fun/lib/Fun.pm | 157 +++++++++++++++++++++++++++++++++++++++++++ t/fun/name.t | 48 +++++++++++++ t/fun/package.t | 17 +++++ t/fun/recursion.t | 37 ++++++++++ t/fun/slurpy-syntax-errors.t | 29 ++++++++ t/fun/slurpy.t | 20 ++++++ t/fun/state.t | 18 +++++ 13 files changed, 469 insertions(+), 1 deletion(-) create mode 100644 t/fun/anon.t create mode 100644 t/fun/basic.t create mode 100644 t/fun/closure-proto.t create mode 100644 t/fun/compile-time.t create mode 100644 t/fun/defaults.t create mode 100644 t/fun/lib/Fun.pm create mode 100644 t/fun/name.t create mode 100644 t/fun/package.t create mode 100644 t/fun/recursion.t create mode 100644 t/fun/slurpy-syntax-errors.t create mode 100644 t/fun/slurpy.t create mode 100644 t/fun/state.t diff --git a/dist.ini b/dist.ini index adf1cce..0e9bb8b 100644 --- a/dist.ini +++ b/dist.ini @@ -13,7 +13,7 @@ awesome = =inc::MakeMaker [AutoPrereqs] skip = ^Error.*$ -skip = ^Try$ +skip = ^(?:Try|Fun)$ [Prereqs / ConfigureRequires] Devel::CallParser = 0 diff --git a/t/fun/anon.t b/t/fun/anon.t new file mode 100644 index 0000000..88b6991 --- /dev/null +++ b/t/fun/anon.t @@ -0,0 +1,17 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use lib 't/fun/lib'; + +use Fun; + +my $fun = fun ($x, $y) { $x * $y }; + +is($fun->(3, 4), 12); + +my $fun2 = fun ($z, $w = 10) { $z / $w }; + +is($fun2->(60), 6); + +done_testing; diff --git a/t/fun/basic.t b/t/fun/basic.t new file mode 100644 index 0000000..53a8476 --- /dev/null +++ b/t/fun/basic.t @@ -0,0 +1,34 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use lib 't/fun/lib'; + +use Fun; + +fun mul ($x, $y) { + return $x * $y; +} + +is(mul(3, 4), 12); + +fun sum (@nums) { + my $sum; + for my $num (@nums) { + $sum += $num; + } + return $sum; +} + +is(sum(1, 2, 3, 4), 10); + +{ + package Foo; + use Fun; + fun foo { } + foo(); +} + +ok(exists $Foo::{foo}); + +done_testing; diff --git a/t/fun/closure-proto.t b/t/fun/closure-proto.t new file mode 100644 index 0000000..bc9ede5 --- /dev/null +++ b/t/fun/closure-proto.t @@ -0,0 +1,20 @@ +#!/usr/bin/env perl + +use strict; +use warnings; +use Test::More; +use lib 't/fun/lib'; + +use Fun; + +{ + my $x = 10; + + fun bar ($y) { + $x * $y + } +} + +is(bar(3), 30); + +done_testing; diff --git a/t/fun/compile-time.t b/t/fun/compile-time.t new file mode 100644 index 0000000..cc72455 --- /dev/null +++ b/t/fun/compile-time.t @@ -0,0 +1,13 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use lib 't/fun/lib'; + +use Fun; + +is(foo(), "FOO"); + +fun foo { "FOO" } + +done_testing; diff --git a/t/fun/defaults.t b/t/fun/defaults.t new file mode 100644 index 0000000..49bd5aa --- /dev/null +++ b/t/fun/defaults.t @@ -0,0 +1,58 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use lib 't/fun/lib'; + +use Fun; + +fun foo ($x, $y = 5) { + return $x + $y; +} + +is(foo(3, 4), 7); +is(foo(3), 8); +{ + my $warning; + local $SIG{__WARN__} = sub { $warning = $_[0] }; + is(foo, 5); + like($warning, qr/Use of uninitialized value \$x in addition \(\+\)/); +} + +fun bar ($baz, $quux = foo(1) * 2, $blorg = sub { return "ran sub, got " . $_[0] }) { + $blorg->($baz + $quux); +} + +is(bar(3, 4, sub { $_[0] }), 7); +is(bar(5, 6), "ran sub, got 11"); +is(bar(7), "ran sub, got 19"); +{ + my $warning; + local $SIG{__WARN__} = sub { $warning = $_[0] }; + is(bar, "ran sub, got 12"); + like($warning, qr/Use of uninitialized value \$baz in addition \(\+\)/); +} + +fun baz ($a, $b = our $FOO) { + return "$a $b"; +} + +{ + no warnings 'misc'; # 'not imported' warning because we use $FOO later + eval '$FOO'; + like($@, qr/Global symbol "\$FOO" requires explicit package name/, "doesn't leak scope"); +} + +our $FOO = "abc"; +is(baz("123"), "123 abc"); + +fun goorch ($x, $y = []) { + return $y +} + +my $goorch_y_1 = goorch( 10 ); +my $goorch_y_2 = goorch( 10 ); + +isnt($goorch_y_1, $goorch_y_2, '... not the same reference'); + +done_testing; diff --git a/t/fun/lib/Fun.pm b/t/fun/lib/Fun.pm new file mode 100644 index 0000000..57bea91 --- /dev/null +++ b/t/fun/lib/Fun.pm @@ -0,0 +1,157 @@ +package Fun; +use strict; +use warnings; + +use Parse::Keyword { fun => \&fun_parser }; +use Sub::Name 'subname'; + +use Exporter 'import'; + +our @EXPORT = 'fun'; + +# XXX this isn't quite right, i think, but probably close enough for now? +my $start_rx = qr/^[\p{ID_Start}_]$/; +my $cont_rx = qr/^\p{ID_Continue}$/; + +sub fun { @_ ? $_[0] : () } + +sub fun_parser { + my ($name, $prototype, $body); + + lex_read_space; + + if (lex_peek =~ /$start_rx|^:$/) { + $name = parse_name(1); + } + + lex_read_space; + + if (lex_peek eq '(') { + $prototype = parse_prototype(); + } + + lex_read_space; + + if (lex_peek eq '{') { + local $Fun::{'DEFAULTS::'}; + if ($prototype) { + lex_read; + + my $preamble = '{'; + + my @names = map { $_->{name} } @$prototype; + $preamble .= 'my (' . join(', ', @names) . ') = @_;'; + + my $index = 1; + for my $var (grep { defined $_->{default} } @$prototype) { + { + no strict 'refs'; + *{ 'Fun::DEFAULTS::default_' . $index } = sub () { + $var->{default} + }; + } + $preamble .= $var->{name} . ' = Fun::DEFAULTS::default_' . $index . '->()' . ' unless @_ > ' . $var->{index} . ';'; + $index++; + } + + lex_stuff($preamble); + } + $body = parse_block; + } + else { + die "syntax error"; + } + + if (defined $name) { + my $full_name = join('::', compiling_package, $name); + { + no strict 'refs'; + *$full_name = subname $full_name, $body; + } + return (sub {}, 1); + } + else { + return (sub { $body }, 0); + } +} + +sub parse_name { + my ($allow_package) = @_; + my $name = ''; + + my $char_rx = $start_rx; + + while (1) { + my $char = lex_peek; + last unless length $char; + if ($char =~ $char_rx) { + $name .= $char; + lex_read(1); + $char_rx = $cont_rx; + } + elsif ($allow_package && $char eq ':') { + die "syntax error" unless lex_peek(3) =~ /^::(?:[^:]|$)/; + $name .= '::'; + lex_read(2); + } + else { + last; + } + } + + return length($name) ? $name : undef; +} + +sub parse_prototype { + die "syntax error" unless lex_peek eq '('; + lex_read; + lex_read_space; + + if (lex_peek eq ')') { + lex_read; + return; + } + + my $seen_slurpy; + my @vars; + while ((my $sigil = lex_peek) ne ')') { + my $var = {}; + die "syntax error" + unless $sigil eq '$' || $sigil eq '@' || $sigil eq '%'; + die "Can't declare parameters after a slurpy parameter" + if $seen_slurpy; + + $seen_slurpy = 1 if $sigil eq '@' || $sigil eq '%'; + + lex_read; + lex_read_space; + my $name = parse_name(0); + lex_read_space; + + $var->{name} = "$sigil$name"; + + if (lex_peek eq '=') { + lex_read; + lex_read_space; + $var->{default} = parse_arithexpr; + } + + $var->{index} = @vars; + + push @vars, $var; + + die "syntax error" + unless lex_peek eq ')' || lex_peek eq ','; + + if (lex_peek eq ',') { + lex_read; + lex_read_space; + } + } + + lex_read; + + return \@vars; +} + +1; diff --git a/t/fun/name.t b/t/fun/name.t new file mode 100644 index 0000000..3294791 --- /dev/null +++ b/t/fun/name.t @@ -0,0 +1,48 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use lib 't/fun/lib'; + +use Carp; + +my $file = __FILE__; +my $line = __LINE__; + +{ + package Foo; + use Fun; + fun foo ($x, $y) { + Carp::confess "$x $y"; + } + + eval { + foo("abc", "123"); + }; + + my $line_confess = $line + 6; + my $line_foo = $line + 10; + + ::like($@, qr/^abc 123 at $file line $line_confess\.?\n\tFoo::foo\('abc', 123\) called at $file line $line_foo/); +} + +SKIP: { skip "Sub::Name required", 1 unless eval { require Sub::Name }; + +{ + package Bar; + use Fun; + *bar = Sub::Name::subname(bar => fun ($a, $b) { Carp::confess($a + $b) }); + + eval { + bar(4, 5); + }; + + my $line_confess = $line + 24; + my $line_bar = $line + 27; + + ::like($@, qr/^9 at $file line $line_confess\.?\n\tBar::bar\(4, 5\) called at $file line $line_bar/); +} + +} + +done_testing; diff --git a/t/fun/package.t b/t/fun/package.t new file mode 100644 index 0000000..52a2266 --- /dev/null +++ b/t/fun/package.t @@ -0,0 +1,17 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use lib 't/fun/lib'; + +use Fun; + +fun Foo::foo ($x, $y) { + $x + $y; +} + +ok(!main->can('foo')); +ok(Foo->can('foo')); +is(Foo::foo(1, 2), 3); + +done_testing; diff --git a/t/fun/recursion.t b/t/fun/recursion.t new file mode 100644 index 0000000..75663ec --- /dev/null +++ b/t/fun/recursion.t @@ -0,0 +1,37 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use lib 't/fun/lib'; + +BEGIN { + if (!eval { require 5.016; 1 }) { + plan skip_all => "This test requires 5.16"; + } +} + +use 5.016; + +use Fun; + +fun fact ($n) { + if ($n < 2) { + return 1; + } + return $n * __SUB__->($n - 1); +} + +is(fact(5), 120); + +is(fun ($n = 8) { $n < 2 ? 1 : $n * __SUB__->($n - 1) }->(), 40320); + +fun fact2 ($n) { + if ($n < 2) { + return 1; + } + return $n * fact2($n - 1); +} + +is(fact2(5), 120); + +done_testing; diff --git a/t/fun/slurpy-syntax-errors.t b/t/fun/slurpy-syntax-errors.t new file mode 100644 index 0000000..90337a5 --- /dev/null +++ b/t/fun/slurpy-syntax-errors.t @@ -0,0 +1,29 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use lib 't/fun/lib'; + +use Fun; + +{ + eval 'fun ( $foo, @bar, $baz ) { return [] }'; + ok $@, '... got an error'; +} + +{ + eval 'fun ( $foo, %bar, $baz ) { return {} }'; + ok $@, '... got an error'; +} + +{ + eval 'fun ( $foo, @bar, %baz ) { return [] }'; + ok $@, '... got an error'; +} + +{ + eval 'fun ( $foo, %bar, @baz ) { return {} }'; + ok $@, '... got an error'; +} + +done_testing; diff --git a/t/fun/slurpy.t b/t/fun/slurpy.t new file mode 100644 index 0000000..42a7f10 --- /dev/null +++ b/t/fun/slurpy.t @@ -0,0 +1,20 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use lib 't/fun/lib'; + +use Fun; + +fun test_array ( $foo, @bar ) { + return [ $foo, @bar ]; +} + +fun test_hash ( $foo, %bar ) { + return { foo => $foo, %bar }; +} + +is_deeply( test_array( 1, 2 .. 10 ), [ 1, 2 .. 10 ], '... slurpy array worked' ); +is_deeply( test_hash( 1, ( two => 2, three => 3 ) ), { foo => 1, two => 2, three => 3 }, '... slurpy hash worked' ); + +done_testing; diff --git a/t/fun/state.t b/t/fun/state.t new file mode 100644 index 0000000..7b8f8fb --- /dev/null +++ b/t/fun/state.t @@ -0,0 +1,18 @@ +#!/usr/bin/env perl + +use strict; +use warnings; +use Test::More; +use lib 't/fun/lib'; + +use 5.10.0; +use Fun; + +fun bar ($y) { + state $x = 10; + $x * $y; +} + +is(bar(3), 30); + +done_testing; -- cgit v1.2.3-54-g00ecf