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
-use 5.014;
+use 5.006;
use strict;
use warnings;
use ExtUtils::MakeMaker;
BUILD_REQUIRES => {
'Dir::Self' => 0,
'Test::More' => 0,
+ 'Test::Fatal' => 0,
},
PREREQ_PM => {
'Carp' => 0,
},
},
depend => { Makefile => '$(VERSION_FROM)' },
+ test => { TESTS => 't/*.t t/foreign/*.t t/foreign/*/*.t' },
dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },
clean => { FILES => 'Function-Parameters-*' },
);
--- /dev/null
+#!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');
--- /dev/null
+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";
--- /dev/null
+#!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");
+}
--- /dev/null
+#!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;
--- /dev/null
+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;
+
--- /dev/null
+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;
--- /dev/null
+#!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;
+#}
--- /dev/null
+#!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;
--- /dev/null
+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;
--- /dev/null
+#!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);
--- /dev/null
+#!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;
--- /dev/null
+#!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;
projects / p5sagit/Function-Parameters.git / commitdiff