From: Lukas Mai <l.mai@web.de>
Date: Wed, 24 Oct 2012 00:25:12 +0000 (+0200)
Subject: import some (modified) MXMS tests
X-Git-Tag: v0.10_01~2
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=595edbcf92e56b601822a62deddef2758aa7f3b5;p=p5sagit%2FFunction-Parameters.git

import some (modified) MXMS tests
---

diff --git a/MANIFEST b/MANIFEST
index 4470c4c..423deab 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -43,3 +43,15 @@ t/strict_3.fail
 t/strict_4.fail
 t/strict_5.fail
 t/unicode.t
+t/foreign/MooseX-Method-Signatures/attributes.t
+t/foreign/MooseX-Method-Signatures/caller.t
+t/foreign/MooseX-Method-Signatures/errors.t
+t/foreign/MooseX-Method-Signatures/eval.t
+t/foreign/MooseX-Method-Signatures/lib/InvalidCase01.pm
+t/foreign/MooseX-Method-Signatures/lib/Redefined.pm
+t/foreign/MooseX-Method-Signatures/list.t
+t/foreign/MooseX-Method-Signatures/no_signature.t
+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
diff --git a/Makefile.PL b/Makefile.PL
index 1fd1cbe..3456a07 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -1,4 +1,4 @@
-use 5.014;
+use 5.006;
 use strict;
 use warnings;
 use ExtUtils::MakeMaker;
@@ -16,6 +16,7 @@ WriteMakefile(
     BUILD_REQUIRES => {
         'Dir::Self' => 0,
         'Test::More' => 0,
+        'Test::Fatal' => 0,
     },
     PREREQ_PM => {
     	'Carp' => 0,
@@ -35,6 +36,7 @@ WriteMakefile(
     	},
     },
     depend => { Makefile => '$(VERSION_FROM)' },
+    test => { TESTS => 't/*.t t/foreign/*.t t/foreign/*/*.t' },
     dist                => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },
     clean               => { FILES => 'Function-Parameters-*' },
 );
diff --git a/t/foreign/MooseX-Method-Signatures/attributes.t b/t/foreign/MooseX-Method-Signatures/attributes.t
new file mode 100644
index 0000000..3cefdfc
--- /dev/null
+++ b/t/foreign/MooseX-Method-Signatures/attributes.t
@@ -0,0 +1,30 @@
+#!perl
+use strict;
+use warnings FATAL => 'all';
+
+use Test::More tests => 2;
+
+use attributes;
+use Function::Parameters qw(:strict);
+
+my $attrs;
+my $cb_called;
+
+sub MODIFY_CODE_ATTRIBUTES {
+    my ($pkg, $code, @attrs) = @_;
+    $cb_called = 1;
+    $attrs = \@attrs;
+    return ();
+}
+
+method moo ($a, $b) : Bar Baz(fubar) {
+}
+
+method foo
+:
+Bar
+:Moo(:Ko{oh)
+: Baz(fu{bar:): { return {} }
+
+ok($cb_called, 'attribute handler got called');
+is_deeply($attrs, [qw/Bar Moo(:Ko{oh) Baz(fu{bar:)/], '... with the right attributes');
diff --git a/t/foreign/MooseX-Method-Signatures/caller.t b/t/foreign/MooseX-Method-Signatures/caller.t
new file mode 100644
index 0000000..cbf009a
--- /dev/null
+++ b/t/foreign/MooseX-Method-Signatures/caller.t
@@ -0,0 +1,23 @@
+use strict;
+use warnings FATAL => 'all';
+use Test::More tests => 1;
+
+{
+	package TestClass;
+
+	use Function::Parameters qw(:strict);
+
+	use Carp ();
+
+	method callstack_inner($class:) {
+		return Carp::longmess("Callstack is");
+	}
+
+	method callstack($class:) {
+		return $class->callstack_inner;
+	}
+}
+
+my $callstack = TestClass->callstack();
+
+unlike $callstack, qr/Test::Class::.*?__ANON__/, "No anon methods in call chain";
diff --git a/t/foreign/MooseX-Method-Signatures/errors.t b/t/foreign/MooseX-Method-Signatures/errors.t
new file mode 100644
index 0000000..6d1493e
--- /dev/null
+++ b/t/foreign/MooseX-Method-Signatures/errors.t
@@ -0,0 +1,23 @@
+#!perl
+use strict;
+use warnings FATAL => 'all';
+use Test::More tests => 4;
+
+use Dir::Self;
+use lib __DIR__ . "/lib";
+
+eval "use InvalidCase01;";
+ok($@, "Got an error");
+like($@,
+     qr/^Global symbol "\$op" requires explicit package name at .*?\bInvalidCase01.pm line 8\b/,
+     "Sane error message for syntax error");
+
+{
+  my $warnings = "";
+  local $SIG{__WARN__} = sub { $warnings .= $_[0] };
+
+  eval "use Redefined;";
+  is($@, '', "No error");
+  like($warnings, qr/^Subroutine meth1 redefined at .*?\bRedefined.pm line 9\b/,
+       "Redefined method warning");
+}
diff --git a/t/foreign/MooseX-Method-Signatures/eval.t b/t/foreign/MooseX-Method-Signatures/eval.t
new file mode 100644
index 0000000..f4bd321
--- /dev/null
+++ b/t/foreign/MooseX-Method-Signatures/eval.t
@@ -0,0 +1,36 @@
+#!perl
+use strict;
+use warnings FATAL => 'all';
+
+use Test::More tests => 3;    # last test to print
+use Function::Parameters qw(:strict);
+
+
+my $evalcode = do {
+    local $/ = undef;
+    <DATA>;
+};
+
+ok(
+    do {
+        my $r = eval $evalcode;
+        die $@ if not $r;
+        1;
+    },
+    'Basic Eval Moose'
+);
+
+my $foo = foo->new({});
+is ($foo->example (), 1, 'First method declared');
+is ($foo->example2(), 2, 'Second method declared (after injected semicolon)');
+
+__DATA__
+{
+    package foo;
+
+    use Function::Parameters qw(:strict);
+    method new($class: $init) { bless $init, $class }
+    method example  { 1 } # look Ma, no semicolon!
+    method example2 { 2 }
+}
+1;
diff --git a/t/foreign/MooseX-Method-Signatures/lib/InvalidCase01.pm b/t/foreign/MooseX-Method-Signatures/lib/InvalidCase01.pm
new file mode 100644
index 0000000..d0ccc1a
--- /dev/null
+++ b/t/foreign/MooseX-Method-Signatures/lib/InvalidCase01.pm
@@ -0,0 +1,18 @@
+package InvalidCase01;
+use strict;
+use warnings; no warnings 'syntax';
+use Function::Parameters qw(:strict);
+use Carp qw/croak/;
+
+method meth1{
+  croak "Binary operator $op expects 2 children, got " . $#$_
+    if @{$_} > 3;
+}
+
+method meth2{ {
+  "a" "b"
+}
+
+method meth3 {}
+1;
+
diff --git a/t/foreign/MooseX-Method-Signatures/lib/Redefined.pm b/t/foreign/MooseX-Method-Signatures/lib/Redefined.pm
new file mode 100644
index 0000000..ed36787
--- /dev/null
+++ b/t/foreign/MooseX-Method-Signatures/lib/Redefined.pm
@@ -0,0 +1,20 @@
+package Redefined;
+use strict;
+use warnings;
+use Function::Parameters qw(:strict);
+use Carp qw/croak/;
+
+method meth1 {}
+
+method meth1 {}
+
+# this one should not trigger a redfined warning
+sub meth2 {}
+method meth2 {}
+
+# This one shouldn't either
+method meth3 {}
+{ no warnings 'redefine';
+  method meth3 {}
+}
+1;
diff --git a/t/foreign/MooseX-Method-Signatures/list.t b/t/foreign/MooseX-Method-Signatures/list.t
new file mode 100644
index 0000000..1bb1051
--- /dev/null
+++ b/t/foreign/MooseX-Method-Signatures/list.t
@@ -0,0 +1,79 @@
+#!perl
+use strict;
+use warnings FATAL => 'all';
+use Test::More tests => 21;
+use Test::Fatal;
+use Function::Parameters qw(:strict);
+
+my $o = bless {} => 'Foo';
+
+{
+    my @meths = (
+        method ($foo, $bar, @rest) {
+            return join q{,}, @rest;
+        },
+        method ($foo, $bar, %rest) {
+            return join q{,}, map { $_ => $rest{$_} } keys %rest;
+        },
+    );
+
+    for my $meth (@meths) {
+        ok(exception { $o->$meth() });
+        ok(exception { $o->$meth('foo') });
+
+        is(exception {
+            is($o->$meth('foo', 'bar'), q{});
+        }, undef);
+
+        is(exception {
+            is($o->$meth('foo', 'bar', 1 .. 6), q{1,2,3,4,5,6});
+        }, undef);
+    }
+}
+
+{
+    my $meth = method ($foo, $bar, @rest) {
+        return join q{,}, @rest;
+    };
+
+    is(exception {
+        is($o->$meth('foo', 42), q{});
+    }, undef);
+
+    is(exception {
+        is($o->$meth('foo', 42, 23, 13), q{23,13});
+    }, undef);
+
+#    like(exception {
+#        $o->$meth('foo', 42, 'moo', 13);
+#    }, qr/Validation failed/);
+}
+
+{
+    my $meth = method (@foo) {
+        return join q{,}, map { @{ $_ } } @foo;
+    };
+
+    is(exception {
+        is($o->$meth([42, 23], [12], [18]), '42,23,12,18');
+    }, undef);
+
+#    like(exception {
+#        $o->$meth([42, 23], 12, [18]);
+#    }, qr/Validation failed/);
+}
+
+{
+    my $meth = method ($foo, @_rest) {};
+    is(exception { $meth->($o, 'foo') }, undef);
+    is(exception { $meth->($o, 'foo', 42) }, undef);
+    is(exception { $meth->($o, 'foo', 42, 23) }, undef);
+}
+
+#{
+#    eval 'my $meth = method (:$foo, :@bar) { }';
+#    like $@, qr/arrays or hashes cannot be named/i;
+#
+#    eval 'my $meth = method ($foo, @bar, :$baz) { }';
+#    like $@, qr/named parameters can not be combined with slurpy positionals/i;
+#}
diff --git a/t/foreign/MooseX-Method-Signatures/no_signature.t b/t/foreign/MooseX-Method-Signatures/no_signature.t
new file mode 100644
index 0000000..8a447ba
--- /dev/null
+++ b/t/foreign/MooseX-Method-Signatures/no_signature.t
@@ -0,0 +1,24 @@
+#!perl
+use strict;
+use warnings FATAL => 'all';
+use Test::More;
+use Test::Fatal;
+
+{
+    package Foo;
+    use Function::Parameters qw(:strict);
+    method new($class:) { bless {}, $class }
+    method bar { 42 }
+}
+
+my $foo = Foo->new;
+
+is(exception {
+    $foo->bar
+}, undef, 'method without signature succeeds when called without args');
+
+is(exception {
+    $foo->bar(42)
+}, undef, 'method without signature succeeds when called with args');
+
+done_testing;
diff --git a/t/foreign/MooseX-Method-Signatures/precedence.t b/t/foreign/MooseX-Method-Signatures/precedence.t
new file mode 100644
index 0000000..100c27c
--- /dev/null
+++ b/t/foreign/MooseX-Method-Signatures/precedence.t
@@ -0,0 +1,10 @@
+use strict;
+use warnings;
+use Test::More tests => 4;
+
+use Function::Parameters qw(:strict);
+
+my @methods = (method { 1 }, method { 2 }, method { 3 });
+is(scalar @methods, 3);
+
+isa_ok($_, 'CODE') for @methods;
diff --git a/t/foreign/MooseX-Method-Signatures/sigs-optional.t b/t/foreign/MooseX-Method-Signatures/sigs-optional.t
new file mode 100644
index 0000000..8c27f57
--- /dev/null
+++ b/t/foreign/MooseX-Method-Signatures/sigs-optional.t
@@ -0,0 +1,21 @@
+#!perl
+use strict;
+use warnings FATAL => 'all';
+use Test::More tests => 4;
+
+{
+    package Optional;
+    use Function::Parameters;
+    method foo ($class: $arg) {
+        $arg;
+    }
+
+    method bar ($class: $hr = {}) {
+        ++$hr->{bar};
+    }
+}
+
+is( Optional->foo(), undef);
+is( Optional->foo(1), 1);
+is( Optional->bar(), 1);
+is( Optional->bar({bar=>1}), 2);
diff --git a/t/foreign/MooseX-Method-Signatures/too_many_args.t b/t/foreign/MooseX-Method-Signatures/too_many_args.t
new file mode 100644
index 0000000..ed881d6
--- /dev/null
+++ b/t/foreign/MooseX-Method-Signatures/too_many_args.t
@@ -0,0 +1,19 @@
+#!perl
+use strict;
+use warnings FATAL => 'all';
+use Test::More;
+use Test::Fatal;
+
+{
+    package Foo;
+    use Function::Parameters qw(:strict);
+
+	method new($class:) { bless {}, $class }
+    method foo ($bar) { $bar }
+}
+
+my $o = Foo->new;
+is(exception { $o->foo(42) }, undef);
+like(exception { $o->foo(42, 23) }, qr/Too many arguments/);
+
+done_testing;
diff --git a/t/foreign/MooseX-Method-Signatures/undef_method_arg.t b/t/foreign/MooseX-Method-Signatures/undef_method_arg.t
new file mode 100644
index 0000000..b149bcf
--- /dev/null
+++ b/t/foreign/MooseX-Method-Signatures/undef_method_arg.t
@@ -0,0 +1,32 @@
+#!perl
+use strict;
+use warnings FATAL => 'all';
+use Test::More;
+use Test::Fatal;
+
+{
+    package Foo;
+    use Function::Parameters qw(:strict);
+
+	method new($class:) { bless {}, $class }
+
+#    method m1(:$bar!) { }
+#    method m2(:$bar?) { }
+#    method m3(:$bar ) { }
+
+#    method m4( $bar!) { }
+    method m5( $bar = undef ) { }
+    method m6( $bar ) { }
+}
+
+my $foo = Foo->new;
+
+#is(exception { $foo->m1(bar => undef) }, undef, 'Explicitly pass undef to positional required arg');
+#is(exception { $foo->m2(bar => undef) }, undef, 'Explicitly pass undef to positional explicit optional arg');
+#is(exception { $foo->m3(bar => undef) }, undef, 'Explicitly pass undef to positional implicit optional arg');
+
+#is(exception { $foo->m4(undef) }, undef, 'Explicitly pass undef to required arg');
+is(exception { $foo->m5(undef) }, undef, 'Explicitly pass undef to explicit required arg');
+is(exception { $foo->m6(undef) }, undef, 'Explicitly pass undef to implicit required arg');
+
+done_testing;