import some (modified) signatures tests

diff --git a/MANIFEST b/MANIFEST
index 7ef9fa0..75d2ab5 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1,11 +1,11 @@
 Changes
-lib/Function/Parameters.pm
-Makefile.PL
 MANIFEST
 MANIFEST.SKIP
-padop_on_crack.c.inc
+Makefile.PL
 Parameters.xs
 README
+lib/Function/Parameters.pm
+padop_on_crack.c.inc
 t/00-load.t
 t/01-compiles.t
 t/02-compiles.t
@@ -21,28 +21,6 @@ t/eating_strict_error.fail
 t/eating_strict_error.t
 t/eating_strict_error_2.fail
 t/elsewhere.t
-t/imports.t
-t/invocant.t
-t/lexical.t
-t/lineno-torture.t
-t/lineno.t
-t/named.t
-t/named_1.fail
-t/named_2.fail
-t/named_3.fail
-t/named_4.fail
-t/pod.t
-t/precedence.t
-t/prototype.t
-t/regress.t
-t/rename.t
-t/strict.t
-t/strict_1.fail
-t/strict_2.fail
-t/strict_3.fail
-t/strict_4.fail
-t/strict_5.fail
-t/unicode.t
 t/foreign/Method-Signatures/anon.t
 t/foreign/Method-Signatures/array_param.t
 t/foreign/Method-Signatures/attributes.t
@@ -71,3 +49,30 @@ t/foreign/MooseX-Method-Signatures/precedence.t
 t/foreign/MooseX-Method-Signatures/sigs-optional.t
 t/foreign/MooseX-Method-Signatures/too_many_args.t
 t/foreign/MooseX-Method-Signatures/undef_method_arg.t
+t/foreign/signatures/anon.t
+t/foreign/signatures/basic.t
+t/foreign/signatures/eval.t
+t/foreign/signatures/proto.t
+t/foreign/signatures/weird.t
+t/imports.t
+t/invocant.t
+t/lexical.t
+t/lineno-torture.t
+t/lineno.t
+t/named.t
+t/named_1.fail
+t/named_2.fail
+t/named_3.fail
+t/named_4.fail
+t/pod.t
+t/precedence.t
+t/prototype.t
+t/regress.t
+t/rename.t
+t/strict.t
+t/strict_1.fail
+t/strict_2.fail
+t/strict_3.fail
+t/strict_4.fail
+t/strict_5.fail
+t/unicode.t

diff --git a/Parameters.xs b/Parameters.xs
index 2031f0b..d6b69a7 100644 (file)
--- a/Parameters.xs
+++ b/Parameters.xs
@@ -673,6 +673,10 @@ static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len
                        my_check_prototype(aTHX_ declarator, proto);
                        lex_read_space(0);
                        c = lex_peek_unichar(0);
+                       if (!(c == ':' || c == '{')) {
+                               lex_stuff_pvs(":", 0);
+                               c = ':';
+                       }
                }
        }
 

diff --git a/t/foreign/signatures/anon.t b/t/foreign/signatures/anon.t
new file mode 100644 (file)
index 0000000..8e5d995
--- /dev/null
+++ b/t/foreign/signatures/anon.t
@@ -0,0 +1,10 @@
+#!perl
+use strict;
+use warnings FATAL => 'all';
+use Test::More tests => 1;
+
+use Function::Parameters;
+
+my $foo = fun ($bar, $baz) { return "${bar}-${baz}" };
+
+is($foo->(qw/bar baz/), 'bar-baz');

diff --git a/t/foreign/signatures/basic.t b/t/foreign/signatures/basic.t
new file mode 100644 (file)
index 0000000..033f640
--- /dev/null
+++ b/t/foreign/signatures/basic.t
@@ -0,0 +1,32 @@
+#!perl
+use strict;
+use warnings FATAL => 'all';
+use Test::More tests => 5;
+
+use Function::Parameters;
+
+fun foo ($bar) { $bar }
+
+fun korv ($wurst, $_unused, $birne) {
+    return "${wurst}-${birne}";
+}
+
+fun array ($scalar, @array) {
+    return $scalar + @array;
+}
+
+fun hash (%hash) {
+    return keys %hash;
+}
+
+fun Name::space ($moo) { $moo }
+
+is(foo('baz'), 'baz');
+is(korv(qw/a b c/), 'a-c');
+is(array(10, 1..10), 20);
+is_deeply(
+    [sort(hash(foo => 1, bar => 2))],
+    [sort(qw/foo bar/)],
+);
+
+is(Name::space('kooh'), 'kooh');

diff --git a/t/foreign/signatures/eval.t b/t/foreign/signatures/eval.t
new file mode 100644 (file)
index 0000000..a82d190
--- /dev/null
+++ b/t/foreign/signatures/eval.t
@@ -0,0 +1,32 @@
+#!perl
+use strict;
+use warnings FATAL => 'all';
+use Test::More tests => 8;
+
+use Function::Parameters;
+
+eval 'fun foo ($bar) { $bar }';
+ok(!$@, 'signatures parse in eval');
+diag $@ if $@;
+ok(\&foo, 'fun declared in eval');
+is(foo(42), 42, 'eval signature works');
+
+no Function::Parameters;
+
+$SIG{__WARN__} = sub {};
+eval 'fun bar ($baz) { $baz }';
+like($@, qr/requires explicit package name/, 'string eval disabled');
+
+{
+    use Function::Parameters;
+
+    eval 'fun bar ($baz) { $baz }';
+    ok(!$@, 'signatures parse in eval');
+    diag $@ if $@;
+    ok(\&bar, 'fun declared in eval');
+    is(bar(42), 42, 'eval signature works');
+}
+
+$SIG{__WARN__} = sub {};
+eval 'fun moo ($kooh) { $kooh }';
+like($@, qr/requires explicit package name/, 'string eval disabled');

diff --git a/t/foreign/signatures/proto.t b/t/foreign/signatures/proto.t
new file mode 100644 (file)
index 0000000..ded1cc4
--- /dev/null
+++ b/t/foreign/signatures/proto.t
@@ -0,0 +1,43 @@
+#!perl
+use strict;
+use warnings;
+use Test::More tests => 7;
+
+use vars qw/@warnings/;
+BEGIN { $SIG{__WARN__} = sub { push @warnings, @_ } }
+
+BEGIN { is(@warnings, 0, 'no warnings yet') }
+
+use Function::Parameters;
+
+fun with_proto ($x, $y, $z) : ($$$) {
+    return $x + $y + $z;
+}
+
+{
+    my $foo;
+    fun with_lvalue () : () lvalue { $foo }
+}
+
+is(prototype('with_proto'), '$$$', ':proto attribute');
+
+is(prototype('with_lvalue'), '', ':proto with other attributes');
+with_lvalue = 1;
+is(with_lvalue, 1, 'other attributes still there');
+
+BEGIN { is(@warnings, 0, 'no warnings with correct :proto declarations') }
+
+fun invalid_proto ($x) : (invalid) { $x }
+
+BEGIN {
+    TODO: {
+        local $TODO = ':proto checks not yet implemented';
+        is(@warnings, 1, 'warning with illegal :proto');
+        like(
+            $warnings[0],
+            qr/Illegal character in prototype for fun invalid_proto : invalid at /,
+            'warning looks sane',
+        );
+    }
+}
+

diff --git a/t/foreign/signatures/weird.t b/t/foreign/signatures/weird.t
new file mode 100644 (file)
index 0000000..82d1093
--- /dev/null
+++ b/t/foreign/signatures/weird.t
@@ -0,0 +1,21 @@
+#!perl
+use strict;
+use warnings FATAL => 'all';
+use Test::More tests => 2;
+
+use Function::Parameters;
+
+  fun
+   foo
+ ($bar, $baz)
+       { return q{($bar, $baz) is }.qq{("$bar", "$baz")} }
+
+  my $moo
+    =
+   fun
+ ($bar, $baz)
+       { return q{($bar, $baz) is }.qq{("$bar", "$baz")} };
+
+is(foo(qw/affe zomtec/),   '($bar, $baz) is ("affe", "zomtec")');
+is($moo->(qw/korv wurst/), '($bar, $baz) is ("korv", "wurst")');
+