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
--- /dev/null
+#!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" );
+}
--- /dev/null
+#!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");
--- /dev/null
+#!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');
+}
--- /dev/null
+#!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;
+}
--- /dev/null
+#!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 );
+}
--- /dev/null
+#!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();
--- /dev/null
+#!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";
--- /dev/null
+#!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' );
--- /dev/null
+#!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;
--- /dev/null
+# 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;
--- /dev/null
+#!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;
--- /dev/null
+#!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" );
+}
--- /dev/null
+#!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;
--- /dev/null
+#!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 );
--- /dev/null
+#!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 );
--- /dev/null
+#!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;
projects / p5sagit/Function-Parameters.git / commitdiff