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

import some (modified) MS tests
---

diff --git a/MANIFEST b/MANIFEST
index 423deab..7ef9fa0 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -43,6 +43,22 @@ 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
+t/foreign/Method-Signatures/caller.t
+t/foreign/Method-Signatures/defaults.t
+t/foreign/Method-Signatures/error_interruption.t
+t/foreign/Method-Signatures/func.t
+t/foreign/Method-Signatures/invocant.t
+t/foreign/Method-Signatures/larna.t
+t/foreign/Method-Signatures/lib/BarfyDie.pm
+t/foreign/Method-Signatures/method.t
+t/foreign/Method-Signatures/one_line.t
+t/foreign/Method-Signatures/optional.t
+t/foreign/Method-Signatures/paren_on_own_line.t
+t/foreign/Method-Signatures/paren_plus_open_block.t
+t/foreign/Method-Signatures/slurpy.t
 t/foreign/MooseX-Method-Signatures/attributes.t
 t/foreign/MooseX-Method-Signatures/caller.t
 t/foreign/MooseX-Method-Signatures/errors.t
diff --git a/t/foreign/Method-Signatures/anon.t b/t/foreign/Method-Signatures/anon.t
new file mode 100644
index 0000000..10a4c37
--- /dev/null
+++ b/t/foreign/Method-Signatures/anon.t
@@ -0,0 +1,22 @@
+#!perl
+use strict;
+use warnings FATAL => 'all';
+
+use Test::More 'no_plan';
+
+{
+    package Stuff;
+
+    use Test::More;
+    use Function::Parameters qw(:strict);
+
+    method echo($arg) {
+        return $arg
+    }
+
+    my $method = method ($arg) {
+        return $self->echo($arg)
+    };
+
+    is( Stuff->$method("foo"), "foo" );
+}
diff --git a/t/foreign/Method-Signatures/array_param.t b/t/foreign/Method-Signatures/array_param.t
new file mode 100644
index 0000000..a7f980d
--- /dev/null
+++ b/t/foreign/Method-Signatures/array_param.t
@@ -0,0 +1,31 @@
+#!perl
+use strict;
+use warnings FATAL => 'all';
+
+use Test::More tests => 3;
+
+{
+    package Bla;
+    use Test::More;
+    use Function::Parameters qw(:strict);
+
+    method new ($class:) {
+        bless {}, $class;
+    }
+
+    method array_param_at_end ($a, $b, @c) {
+        return "$a|$b|@c";
+    }
+
+    eval q{
+         method two_array_params ($a, @b, @c) {}
+    };
+    like($@, qr{\btwo_array_params\b.+\@b\b.+\@c\b}, "Two array params");
+
+    eval q{
+         method two_slurpy_params ($a, %b, $c, @d, $e) {}
+    };
+    like($@, qr{\btwo_slurpy_params\b.+%b\b.+\$c\b}, "Two slurpy params");
+}
+
+is(Bla->new->array_param_at_end(1, 2, 3, 4), "1|2|3 4", "Array parameter at end");
diff --git a/t/foreign/Method-Signatures/attributes.t b/t/foreign/Method-Signatures/attributes.t
new file mode 100644
index 0000000..71e11ce
--- /dev/null
+++ b/t/foreign/Method-Signatures/attributes.t
@@ -0,0 +1,51 @@
+#!perl
+use strict;
+use warnings FATAL => 'all';
+
+use Test::More 'no_plan';
+
+use attributes;
+
+{
+    package Stuff;
+
+    use Test::More;
+    use Function::Parameters qw(:strict);
+
+    method echo($arg) {
+        return $arg;
+    }
+
+    is( Stuff->echo(42), 42 );
+    is_deeply( [attributes::get \&echo], ['method'] );
+}
+
+
+{
+    package Things;
+
+    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($foo, $bar) : Bar Baz(fubar) {
+    }
+
+    # Torture test for the attribute handling.
+    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/Method-Signatures/caller.t b/t/foreign/Method-Signatures/caller.t
new file mode 100644
index 0000000..8b0956b
--- /dev/null
+++ b/t/foreign/Method-Signatures/caller.t
@@ -0,0 +1,59 @@
+#!perl
+use warnings FATAL => 'all';
+use strict;
+
+# Test that caller() works
+
+{
+    package Foo;
+
+    use Test::More 'no_plan';
+
+    use Function::Parameters qw(:strict);
+
+    sub sub_caller {
+        my($self, $level) = @_;
+#line 13
+        return caller($level);
+    }
+
+
+    sub sub_caller2 {
+        my($self, $level) = @_;
+#line 20
+        return $self->sub_caller($level);
+    }
+
+
+    method method_caller($level) {
+#line 13
+        return caller($level);
+    }
+
+
+    method method_caller2($level) {
+#line 20
+        return $self->method_caller($level);
+    }
+
+#line 36
+    my @expected  = Foo->sub_caller2(0);
+    my @expected2 = Foo->sub_caller2(1);
+
+#line 36
+    my @have      = Foo->method_caller2(0);
+    my @have2     = Foo->method_caller2(1);
+
+    $expected[3]  = 'Foo::method_caller';
+    $expected2[3] = 'Foo::method_caller2';
+
+    is_deeply([@have[0..7]],  [@expected[0..7]]);
+    is_deeply([@have2[0..7]], [@expected2[0..7]]);
+
+    # hints and bitmask change and are twitchy so I'm just going to
+    # check that they're there.
+    isnt $have[8],  undef;
+    isnt $have2[8], undef;
+    isnt $have[9],  undef;
+    isnt $have2[9], undef;
+}
diff --git a/t/foreign/Method-Signatures/defaults.t b/t/foreign/Method-Signatures/defaults.t
new file mode 100644
index 0000000..c15c8a0
--- /dev/null
+++ b/t/foreign/Method-Signatures/defaults.t
@@ -0,0 +1,83 @@
+#!perl
+use strict;
+use warnings FATAL => 'all';
+
+use Test::More 'no_plan';
+
+{
+    package Stuff;
+
+    use Test::More;
+    use Function::Parameters qw(:strict);
+
+    method add($this = 23, $that = 42) {
+        return $this + $that;
+    }
+
+    method minus($this = 23, $that = 42) {
+        return $this - $that;
+    }
+
+    is( Stuff->add(),    23 + 42 );
+    is( Stuff->add(99),  99 + 42 );
+    is( Stuff->add(2,3), 5 );
+
+    is( Stuff->minus(),         23 - 42 );
+    is( Stuff->minus(99),       99 - 42 );
+    is( Stuff->minus(2, 3),     2 - 3 );
+
+
+    # Test that undef overrides defaults
+    method echo($message = "what?") {
+        return $message
+    }
+
+    is( Stuff->echo(),          "what?" );
+    is( Stuff->echo(undef),     undef   );
+    is( Stuff->echo("who?"),    'who?'  );
+
+
+    # Test that you can reference earlier args in a default
+    method copy_cat($this, $that = $this) {
+        return $that;
+    }
+
+    is( Stuff->copy_cat("wibble"), "wibble" );
+    is( Stuff->copy_cat(23, 42),   42 );
+}
+
+
+{
+    package Bar;
+    use Test::More;
+    use Function::Parameters qw(:strict);
+
+    method hello($msg = "Hello, world!") {
+        return $msg;
+    }
+
+    is( Bar->hello,               "Hello, world!" );
+    is( Bar->hello("Greetings!"), "Greetings!" );
+
+
+    method hi($msg = q,Hi,) {
+        return $msg;
+    }
+
+    is( Bar->hi,                "Hi" );
+    is( Bar->hi("Yo"),          "Yo" );
+
+
+#    method list(@args = (1,2,3)) {
+#        return @args;
+#    }
+#
+#    is_deeply [Bar->list()], [1,2,3];
+
+
+    method code($num, $code = sub { $num + 2 }) {
+        return $code->();
+    }
+
+    is( Bar->code(42), 44 );
+}
diff --git a/t/foreign/Method-Signatures/error_interruption.t b/t/foreign/Method-Signatures/error_interruption.t
new file mode 100644
index 0000000..e5884a8
--- /dev/null
+++ b/t/foreign/Method-Signatures/error_interruption.t
@@ -0,0 +1,15 @@
+#!perl
+use strict;
+use warnings FATAL => 'all';
+
+use Dir::Self;
+use lib __DIR__ . "/lib";
+
+use Test::More;
+use Test::Fatal;
+
+like exception { require BarfyDie },
+  qr/requires explicit package name/,
+  "F:P doesn't interrupt real compilation error";
+
+done_testing();
diff --git a/t/foreign/Method-Signatures/func.t b/t/foreign/Method-Signatures/func.t
new file mode 100644
index 0000000..3ee64ef
--- /dev/null
+++ b/t/foreign/Method-Signatures/func.t
@@ -0,0 +1,13 @@
+#!perl
+use strict;
+use warnings FATAL => 'all';
+
+use Test::More tests => 1;
+
+use Function::Parameters qw(:strict);
+
+fun echo($arg) {
+    return $arg;
+}
+
+is echo(42), 42, "basic func";
diff --git a/t/foreign/Method-Signatures/invocant.t b/t/foreign/Method-Signatures/invocant.t
new file mode 100644
index 0000000..3d53241
--- /dev/null
+++ b/t/foreign/Method-Signatures/invocant.t
@@ -0,0 +1,67 @@
+#!perl
+
+# Test that you can change the invocant.
+
+use strict;
+use warnings FATAL => 'all';
+
+use Test::More 'no_plan';
+
+our $skip_no_invocants;
+
+{
+    package Stuff;
+
+    use Test::More;
+    use Function::Parameters qw(:strict);
+
+    sub new { bless {}, __PACKAGE__ }
+
+    method bar($arg) {
+        return ref $arg || $arg;
+    }
+
+    method invocant($class:) {
+        $class->bar(0);
+    }
+
+    method with_arg($class: $arg) {
+        $class->bar($arg);
+    }
+
+    method without_space($class:$arg) {
+        $class->bar($arg);
+    }
+
+    eval q{
+
+        method no_invocant_class_type($arg) {
+            $self->bar($arg);
+        }
+
+#        method no_invocant_named_param($arg) {
+#            $self->bar($arg);
+#        }
+
+    };
+    is $@, '', 'compiles without invocant';
+}
+
+{
+    package Foo;
+    sub new { bless {}, __PACKAGE__ }
+}
+
+{
+    package Foo::Bar;
+    sub new { bless {}, __PACKAGE__ }
+}
+
+
+is( Stuff->invocant,                0 );
+is( Stuff->with_arg(42),            42 );
+is( Stuff->without_space(42),       42 );
+
+my $stuff = Stuff->new;
+is( $stuff->no_invocant_class_type(Foo::Bar->new),     'Foo::Bar' );
+#is( $stuff->no_invocant_named_param(arg => Foo->new),  'Foo' );
diff --git a/t/foreign/Method-Signatures/larna.t b/t/foreign/Method-Signatures/larna.t
new file mode 100644
index 0000000..d9ec96a
--- /dev/null
+++ b/t/foreign/Method-Signatures/larna.t
@@ -0,0 +1,17 @@
+#!perl
+use strict;
+use warnings FATAL => 'all';
+
+use Test::More;
+
+use Function::Parameters qw(:strict);;
+
+
+ok eval q{ my $a = [ fun () {}, 1 ]; 1 }, 'anonymous function in list is okay'
+        or diag "eval error: $@";
+
+ok eval q{ my $a = [ method () {}, 1 ]; 1 }, 'anonymous method in list is okay'
+        or diag "eval error: $@";
+
+
+done_testing;
diff --git a/t/foreign/Method-Signatures/lib/BarfyDie.pm b/t/foreign/Method-Signatures/lib/BarfyDie.pm
new file mode 100644
index 0000000..3648068
--- /dev/null
+++ b/t/foreign/Method-Signatures/lib/BarfyDie.pm
@@ -0,0 +1,21 @@
+# For use with t/error_interruption.t
+
+package BarfyDie;
+
+use strict;
+use warnings;
+
+use Function::Parameters qw(:strict);
+
+
+# This _should_ produce a simple error like the following:
+# Global symbol "$foo" requires explicit package name at t/lib/BarfyDie.pm line 13.
+$foo = 'hi!';
+
+
+method foo ($bar)
+{
+}
+
+
+1;
diff --git a/t/foreign/Method-Signatures/method.t b/t/foreign/Method-Signatures/method.t
new file mode 100644
index 0000000..ea3febf
--- /dev/null
+++ b/t/foreign/Method-Signatures/method.t
@@ -0,0 +1,74 @@
+#!perl
+use warnings FATAL => 'all';
+use strict;
+use Test::More 'no_plan';
+
+{
+    package Foo;
+    use Function::Parameters qw(:strict);
+
+    method new (%args) {
+        return bless {%args}, $self;
+    }
+
+    method set ($key, $val) {
+        return $self->{$key} = $val;
+    }
+
+    method get ($key) {
+        return $self->{$key};
+    }
+    
+    method no_proto {
+        return($self, @_);
+    }
+    
+    method empty_proto() {
+        return($self, @_);
+    }
+    
+    method echo(@_) {
+        return($self, @_);
+    }
+    
+    method caller($height = 0) {
+        return (CORE::caller($height))[0..2];
+    }
+
+#line 39
+    method warn($foo = undef) {
+        my $warning = '';
+        local $SIG{__WARN__} = sub { $warning = join '', @_; };
+        CORE::warn "Testing warn";
+        
+        return $warning;
+    }
+
+    # Method with the same name as a loaded class.
+    method strict () {
+        42 
+    }
+}
+
+my $obj = Foo->new( foo => 42, bar => 23 );
+isa_ok $obj, "Foo";
+is $obj->get("foo"), 42;
+is $obj->get("bar"), 23;
+
+$obj->set(foo => 99);
+is $obj->get("foo"), 99;
+
+is_deeply [$obj->no_proto], [$obj];
+for my $method (qw(empty_proto)) {
+    is_deeply [$obj->$method], [$obj];
+    ok !eval { $obj->$method(23); 1 };
+    like $@, qr{\QToo many arguments};
+}
+
+is_deeply [$obj->echo(1,2,3)], [$obj,1,2,3], "echo";
+
+is_deeply [$obj->caller], [__PACKAGE__, $0, __LINE__], 'caller works';
+
+is $obj->warn, "Testing warn at $0 line 42.\n";
+
+is eval { $obj->strict }, 42;
diff --git a/t/foreign/Method-Signatures/one_line.t b/t/foreign/Method-Signatures/one_line.t
new file mode 100644
index 0000000..2bb283c
--- /dev/null
+++ b/t/foreign/Method-Signatures/one_line.t
@@ -0,0 +1,13 @@
+#!perl
+use warnings FATAL => 'all';
+use strict;
+use Test::More tests => 1;
+
+{
+    package Thing;
+
+    use Function::Parameters qw(:strict);
+    method foo {"wibble"}
+
+    ::is( Thing->foo, "wibble" );
+}
diff --git a/t/foreign/Method-Signatures/optional.t b/t/foreign/Method-Signatures/optional.t
new file mode 100644
index 0000000..6c0f960
--- /dev/null
+++ b/t/foreign/Method-Signatures/optional.t
@@ -0,0 +1,55 @@
+#!perl
+
+# Test the $arg = undef optional syntax.
+
+use strict;
+use warnings FATAL => 'all';
+
+use Test::More;
+
+{
+    package Stuff;
+
+    use Test::More;
+    use Test::Fatal;
+    use Function::Parameters qw(:strict);
+
+    method whatever($this = undef) {
+        return $this;
+    }
+
+    is( Stuff->whatever(23),    23 );
+
+    method things($this = 99) {
+        return $this;
+    }
+
+    is( Stuff->things(),        99 );
+
+    method some_optional($that, $this = undef) {
+        return $that + ($this || 0);
+    }
+
+    is( Stuff->some_optional(18, 22), 18 + 22 );
+    is( Stuff->some_optional(18), 18 );
+
+
+#    # are named parameters optional by default?
+#    method named_params(:$this, :$that) {}
+#
+#    lives_ok { Stuff->named_params(this => 0) } 'can leave out some named params';
+#    lives_ok { Stuff->named_params(         ) } 'can leave out all named params';
+
+
+    # are slurpy parameters optional by default?
+    # (throwing in a default just for a little feature interaction test)
+    method slurpy_param($this, $that = 0, @other) {}
+
+    my @a = ();
+    is exception { Stuff->slurpy_param(0, 0, @a) }, undef, 'can pass empty array to slurpy param';
+    is exception { Stuff->slurpy_param(0, 0    ) }, undef, 'can omit slurpy param altogether';
+    is exception { Stuff->slurpy_param(0       ) }, undef, 'can omit other optional params as well as slurpy param';
+}
+
+
+done_testing;
diff --git a/t/foreign/Method-Signatures/paren_on_own_line.t b/t/foreign/Method-Signatures/paren_on_own_line.t
new file mode 100644
index 0000000..65d5d19
--- /dev/null
+++ b/t/foreign/Method-Signatures/paren_on_own_line.t
@@ -0,0 +1,20 @@
+#!perl
+
+package Foo;
+
+use strict;
+use warnings FATAL => 'all';
+
+use Function::Parameters qw(:strict);
+use Test::More 'no_plan';
+
+# The problem goes away inside an eval STRING.
+method foo(
+    $arg
+)
+{
+    return $arg;
+}
+
+is $@, '';
+is( Foo->foo(42), 42 );
diff --git a/t/foreign/Method-Signatures/paren_plus_open_block.t b/t/foreign/Method-Signatures/paren_plus_open_block.t
new file mode 100644
index 0000000..ca8738f
--- /dev/null
+++ b/t/foreign/Method-Signatures/paren_plus_open_block.t
@@ -0,0 +1,18 @@
+#!perl
+
+use strict;
+use warnings FATAL => 'all';
+
+package Foo;
+
+use Test::More "no_plan";
+use Function::Parameters qw(:strict);
+
+method foo(
+    $arg
+) 
+{
+    return $arg
+}
+
+is( Foo->foo(23), 23 );
diff --git a/t/foreign/Method-Signatures/slurpy.t b/t/foreign/Method-Signatures/slurpy.t
new file mode 100644
index 0000000..63e106c
--- /dev/null
+++ b/t/foreign/Method-Signatures/slurpy.t
@@ -0,0 +1,61 @@
+#!perl
+
+# Test slurpy parameters
+
+use strict;
+use warnings FATAL => 'all';
+
+use Test::More;
+
+{
+    package Stuff;
+    use Function::Parameters qw(:strict);
+    use Test::More;
+
+    method slurpy(@that) { return \@that }
+    method slurpy_required(@that) { return \@that }
+    method slurpy_last($this, @that) { return $this, \@that; }
+
+    ok !eval q[fun slurpy_first(@that, $this) { return $this, \@that; }];
+    like $@, qr{\@that\b.+\$this\b};
+    TODO: {
+        #local $TODO = "error message incorrect inside an eval";
+
+        like $@, qr{\bslurpy_first\b};
+    }
+
+    ok !eval q[fun slurpy_middle($this, @that, $other) { return $this, \@that, $other }];
+    like $@, qr{\@that\b.+\$other\b};
+    TODO: {
+        #local $TODO = "error message incorrect inside an eval";
+
+        like $@, qr{\bslurpy_middle\b};
+    }
+
+#    ok !eval q[fun slurpy_positional(:@that) { return \@that; }];
+#    like $@, qr{slurpy parameter \@that cannot be named, use a reference instead};
+#
+#    TODO: {
+#        local $TODO = "error message incorrect inside an eval";
+#
+#        like $@, qr{Stuff::};
+#        like $@, qr{slurpy_positional\(\)};
+#    }
+
+    ok !eval q[fun slurpy_two($this, @that, @other) { return $this, \@that, \@other }];
+    like $@, qr{\@that\b.+\@other\b};
+}
+
+
+note "Optional slurpy params accept 0 length list"; {
+    is_deeply [Stuff->slurpy()], [[]];
+    is_deeply [Stuff->slurpy_last(23)], [23, []];
+}
+
+#note "Required slurpy params require an argument"; {
+#    throws_ok { Stuff->slurpy_required() }
+#      qr{slurpy_required\Q()\E, missing required argument \@that at \Q$0\E line @{[__LINE__ - 1]}};
+#}
+
+
+done_testing;