From: Lukas Mai Date: Sun, 15 Sep 2013 14:31:42 +0000 (+0200) Subject: update foreign tests X-Git-Tag: v1.0301~10 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=1a52f2db46f6d870454428a07bfae09e0359eeee;p=p5sagit%2FFunction-Parameters.git update foreign tests --- diff --git a/t/foreign/Method-Signatures-Simple/03-config.t b/t/foreign/Method-Signatures-Simple/03-config.t index 580ccfb..ba9e530 100644 --- a/t/foreign/Method-Signatures-Simple/03-config.t +++ b/t/foreign/Method-Signatures-Simple/03-config.t @@ -10,9 +10,9 @@ use Test::More tests => 3; use Function::Parameters; use Function::Parameters { - action => { shift => '$monster', invocant => 1 }, - constructor => { shift => '$species', invocant => 1 }, - function => 'function', + action => { shift => '$monster', invocant => 1 }, + constructor => { shift => '$species', invocant => 1 }, + function => 'function', }; constructor spawn { diff --git a/t/foreign/Method-Signatures-Simple/RT80505.t b/t/foreign/Method-Signatures-Simple/RT80505.t new file mode 100644 index 0000000..e7b49d4 --- /dev/null +++ b/t/foreign/Method-Signatures-Simple/RT80505.t @@ -0,0 +1,30 @@ +#!perl +use strict; +use warnings FATAL => 'all'; +use Test::More tests => 2; + +{ + package My::Obj; + use Function::Parameters qw(:strict); + method new () { + bless {}, $self; + } + method foo ( + $x, # the X + $y, # the Y + ) { + return $x * $y; + } + my $bar = method ( + $P, # comment + $Q, # comment + ) { # comment + $P + $Q + }; +} + +my $o = My::Obj->new; +is $o->foo(4, 5), 20, "should allow comments and newlines in proto"; +is __LINE__, 28, "should leave line number intact"; + +__END__ diff --git a/t/foreign/Method-Signatures-Simple/RT80507.t b/t/foreign/Method-Signatures-Simple/RT80507.t new file mode 100644 index 0000000..718aac8 --- /dev/null +++ b/t/foreign/Method-Signatures-Simple/RT80507.t @@ -0,0 +1,28 @@ +#!perl +use strict; +use warnings FATAL => 'all'; +use Function::Parameters qw(:strict); +use Test::More tests => 2; + +{ + my $uniq = 0; + + method fresh_name() { + $self->prefix . $uniq++ + } +} + +method prefix() { + $self->{prefix} +} + +my $o = bless {prefix => "foo_" }, main::; +is $o->fresh_name, 'foo_0'; + +#TODO: { +# local $TODO = 'do not know how to handle the scope change in line 7'; + is __LINE__, 24; +#} + +__END__ + diff --git a/t/foreign/Method-Signatures-Simple/RT80508.t b/t/foreign/Method-Signatures-Simple/RT80508.t new file mode 100644 index 0000000..3384f40 --- /dev/null +++ b/t/foreign/Method-Signatures-Simple/RT80508.t @@ -0,0 +1,18 @@ +#!perl +use strict; +use warnings FATAL => 'all'; +use Test::More tests => 1; + +{ + package My::Obj; + use Function::Parameters qw(:strict); + + method with_space ( $this : $that ) { + return ($this, $that); + } +} + +is_deeply [ My::Obj->with_space (1) ], [ 'My::Obj', 1 ], 'space between invocant name and colon should parse'; + +__END__ + diff --git a/t/foreign/Method-Signatures-Simple/RT80510.t b/t/foreign/Method-Signatures-Simple/RT80510.t new file mode 100644 index 0000000..3097146 --- /dev/null +++ b/t/foreign/Method-Signatures-Simple/RT80510.t @@ -0,0 +1,13 @@ +#!perl +use strict; +use warnings FATAL => 'all'; +use Test::More tests => 2; + +use Function::Parameters; + +fun empty ($x) {} + +is scalar empty(1), undef, "empty func returns nothing (scalar context)"; +is_deeply [empty(1,2)], [], "empty func returns nothing (list context)"; + +__END__ diff --git a/t/foreign/Method-Signatures/attributes.t b/t/foreign/Method-Signatures/attributes.t index 71e11ce..784c075 100644 --- a/t/foreign/Method-Signatures/attributes.t +++ b/t/foreign/Method-Signatures/attributes.t @@ -22,6 +22,17 @@ use attributes; { + package Foo; + + use Test::More; + use Function::Parameters qw(:strict); + + my $code = fun () : method {}; + is_deeply( [attributes::get $code], ['method'] ); +} + + +{ package Things; use Function::Parameters qw(:strict); diff --git a/t/foreign/Method-Signatures/comments.t b/t/foreign/Method-Signatures/comments.t index 34bf716..d1369e6 100644 --- a/t/foreign/Method-Signatures/comments.t +++ b/t/foreign/Method-Signatures/comments.t @@ -3,9 +3,9 @@ use strict; use warnings FATAL => 'all'; use Test::More - eval { require Moose; 1 } - ? (tests => 2) - : (skip_all => "Moose required for testing types") + eval { require Moose; 1 } + ? (tests => 5) + : (skip_all => "Moose required for testing types") ; use Test::Fatal; @@ -43,24 +43,45 @@ is exception #{ # eval { require MooseX::Declare } or skip "MooseX::Declare required for this test", 1; # -# lives_ok -# { -# eval q{ + is exception + { + eval q{ # use MooseX::Declare; # use Method::Signatures::Modifiers; -# -# class Foo -# { -# method bar ( Int :$foo, Int :$bar ) # this is a signature -# { -# } -# } -# -# 1; -# } or die; -# } -# 'survives comments between signature and open brace'; + + package Foo + { + method bar ( Int :$foo, Int :$bar ) # this is a signature + { + } + } + + 1; + } or die; + }, undef, + 'survives comments between signature and open brace'; #} -# -# + + +#TODO: { +# local $TODO = "closing paren in comment: rt.cpan.org 81364"; + + is exception + { +# # When this fails, it produces 'Variable "$bar" is not imported' +# # This is expected to fail, don't bother the user. +# no warnings; + eval q{ + fun special_comment ( + $foo, # ) + $bar + ) + { 42 } + 1; + } or die; + }, undef, + 'closing paren in comment'; + is eval q[special_comment("this", "that")], 42; +#} + #done_testing(); diff --git a/t/foreign/Method-Signatures/debugger.t b/t/foreign/Method-Signatures/debugger.t new file mode 100644 index 0000000..093623d --- /dev/null +++ b/t/foreign/Method-Signatures/debugger.t @@ -0,0 +1,44 @@ +#!perl +use strict; +use warnings FATAL => 'all'; + +use Dir::Self; +use Test::More 'no_plan'; + +#TODO: { +# todo_skip "This is still totally hosed", 2; + + is eval { + local $SIG{ALRM} = sub { die "Alarm!\n"; }; + + alarm 5; + my $ret = qx{$^X "-Ilib" -le "package Foo; use Function::Parameters; method foo() { 42 } print Foo->foo()"}; + alarm 0; + $ret; + }, "42\n", 'one-liner'; + is $@, ''; +#} + + +is eval { + local $SIG{ALRM} = sub { die "Alarm!\n"; }; + + alarm 5; + my $ret = qx{$^X "-Ilib" -MFunction::Parameters -le "package Foo; use Function::Parameters; method foo() { 42 } print Foo->foo()"}; + alarm 0; + $ret; +}, "42\n", 'one liner with -MFunction::Parameters'; +is $@, ''; + + +is eval { + local $SIG{ALRM} = sub { die "Alarm!\n"; }; + my $simple_plx = __DIR__ . '/simple.plx'; + + local $ENV{PERLDB_OPTS} = 'NonStop'; + alarm 5; + my $ret = qx{$^X "-Ilib" -dw $simple_plx}; + alarm 0; + $ret; +}, "42", 'debugger'; +is $@, ''; diff --git a/t/foreign/Method-Signatures/into.t b/t/foreign/Method-Signatures/into.t new file mode 100644 index 0000000..c202e42 --- /dev/null +++ b/t/foreign/Method-Signatures/into.t @@ -0,0 +1,21 @@ +#!perl +use strict; +use warnings FATAL => 'all'; + +# Importing always affects the currently compiling scope. + +package Foo; + +use Test::More 'no_plan'; + +BEGIN { + package Bar; + require Function::Parameters; + Function::Parameters->import; +} + +is( Foo->foo(42), 42 ); + +method foo ($arg) { + return $arg; +} diff --git a/t/foreign/Method-Signatures/invocant.t b/t/foreign/Method-Signatures/invocant.t index 4242aee..6f66d1c 100644 --- a/t/foreign/Method-Signatures/invocant.t +++ b/t/foreign/Method-Signatures/invocant.t @@ -5,7 +5,11 @@ use strict; use warnings FATAL => 'all'; -use Test::More 'no_plan'; +use Test::More + eval { require Moose } + ? (tests => 6) + : (skip_all => "Moose required for testing types") +; our $skip_no_invocants; @@ -35,11 +39,11 @@ our $skip_no_invocants; eval q{ - method no_invocant_class_type($arg) { + method no_invocant_class_type(Foo::Bar $arg) { $self->bar($arg); } - method no_invocant_named_param(:$arg) { + method no_invocant_named_param(Foo :$arg) { $self->bar($arg); } diff --git a/t/foreign/Method-Signatures/larna.t b/t/foreign/Method-Signatures/larna.t index d9ec96a..0cc8eb3 100644 --- a/t/foreign/Method-Signatures/larna.t +++ b/t/foreign/Method-Signatures/larna.t @@ -6,12 +6,20 @@ use Test::More; use Function::Parameters qw(:strict);; - -ok eval q{ my $a = [ fun () {}, 1 ]; 1 }, 'anonymous function in list is okay' +{ + my $a; + ok eval q{ $a = [ fun () {}, 1 ]; 1 }, 'anonymous function in list is okay' or diag "eval error: $@"; + is ref $a->[0], "CODE"; + is $a->[1], 1; +} -ok eval q{ my $a = [ method () {}, 1 ]; 1 }, 'anonymous method in list is okay' +{ + my $a; + ok eval q{ $a = [ method () {}, 1 ]; 1 }, 'anonymous method in list is okay' or diag "eval error: $@"; - + is ref $a->[0], "CODE"; + is $a->[1], 1; +} done_testing; diff --git a/t/foreign/Method-Signatures/method.t b/t/foreign/Method-Signatures/method.t index ea3febf..e156651 100644 --- a/t/foreign/Method-Signatures/method.t +++ b/t/foreign/Method-Signatures/method.t @@ -18,19 +18,19 @@ use Test::More 'no_plan'; 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]; } @@ -40,13 +40,13 @@ use Test::More 'no_plan'; 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 + 42 } } diff --git a/t/foreign/Method-Signatures/odd_number.t b/t/foreign/Method-Signatures/odd_number.t index 254b98a..6d625ec 100644 --- a/t/foreign/Method-Signatures/odd_number.t +++ b/t/foreign/Method-Signatures/odd_number.t @@ -1,6 +1,5 @@ #!perl -package Foo; use warnings FATAL => 'all'; use strict; @@ -9,8 +8,10 @@ use Test::Fatal; use Function::Parameters qw(:strict); -method foo(:$name, :$value) { - return $name, $value; +package Foo { + method foo(:$name, :$value) { + return $name, $value; + } } -like exception { Foo->foo(name => 42, value =>) }, qr/Not enough arguments/; +like exception { Foo->foo(name => 42, value =>) }, qr/Not enough arguments.+ line 17/; diff --git a/t/foreign/Method-Signatures/simple.plx b/t/foreign/Method-Signatures/simple.plx new file mode 100644 index 0000000..241c436 --- /dev/null +++ b/t/foreign/Method-Signatures/simple.plx @@ -0,0 +1,12 @@ +package Foo; + +use strict; +use warnings; + +use Function::Parameters; + +method echo($msg) { + return $msg +} + +print Foo->echo(42); diff --git a/t/foreign/Method-Signatures/slurpy.t b/t/foreign/Method-Signatures/slurpy.t index b9c4fcf..6b959e2 100644 --- a/t/foreign/Method-Signatures/slurpy.t +++ b/t/foreign/Method-Signatures/slurpy.t @@ -6,6 +6,7 @@ use strict; use warnings FATAL => 'all'; use Test::More; +#use Test::Exception; { package Stuff; @@ -18,23 +19,32 @@ use Test::More; 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"; +# TODO: { +# local $TODO = "error message incorrect inside an eval"; +# like $@, qr{Stuff::}; 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"; +# TODO: { +# local $TODO = "error message incorrect inside an eval"; +# like $@, qr{Stuff::}; like $@, qr{\bslurpy_middle\b}; - } +# } ok !eval q[fun slurpy_positional(:@that) { return \@that; }]; like $@, qr{\bnamed\b.+\@that\b.+\barray\b}; +# TODO: { +# local $TODO = "error message incorrect inside an eval"; + +# like $@, qr{Stuff::}; + like $@, qr{\bslurpy_positional\b}; +# } + ok !eval q[fun slurpy_two($this, @that, @other) { return $this, \@that, \@other }]; like $@, qr{\@that\b.+\@other\b}; } diff --git a/t/foreign/Method-Signatures/too_many_args.t b/t/foreign/Method-Signatures/too_many_args.t index 7f5ebd3..7e2997b 100644 --- a/t/foreign/Method-Signatures/too_many_args.t +++ b/t/foreign/Method-Signatures/too_many_args.t @@ -16,7 +16,8 @@ fun one_named(:$foo) { return $foo; } fun one_named_one_positional($bar, :$foo) { return($foo, $bar) } note "too many arguments"; { - is_deeply [no_sig(42)], [42]; + is_deeply [no_sig(42)], [42]; + ok !eval { no_args(42); 1 }, "no args"; like $@, qr{Too many arguments}; @@ -36,8 +37,10 @@ note "with positionals"; { is one_named(foo => 23, foo => 42), 42; + is_deeply [one_named_one_positional(23, foo => 42)], [42, 23]; is_deeply [one_named_one_positional(23, foo => 42, foo => 23)], [23, 23]; + } diff --git a/t/foreign/Method-Signatures/trailing_comma.t b/t/foreign/Method-Signatures/trailing_comma.t new file mode 100644 index 0000000..4c91673 --- /dev/null +++ b/t/foreign/Method-Signatures/trailing_comma.t @@ -0,0 +1,18 @@ +#!perl + +# Make sure we allow a trailing comma. + +use strict; +use warnings FATAL => 'all'; + +use Test::More; + +use Function::Parameters qw(:strict); + +fun foo($foo, $bar,) { + return [$foo, $bar]; +} + +is_deeply foo(23, 42), [23, 42]; + +done_testing; diff --git a/t/foreign/Method-Signatures/type_check.t b/t/foreign/Method-Signatures/type_check.t index 1a51914..9fbb3e8 100644 --- a/t/foreign/Method-Signatures/type_check.t +++ b/t/foreign/Method-Signatures/type_check.t @@ -4,9 +4,9 @@ use strict; use warnings FATAL => 'all'; use Test::More - eval { require Moose; 1 } - ? () - : (skip_all => "Moose required for testing types") + eval { require Moose; 1 } + ? () + : (skip_all => "Moose required for testing types") ; use Test::More; use Test::Fatal; @@ -38,10 +38,15 @@ our @TYPES = maybe_int => 'Maybe[Int]' => [ 42, undef ] => 'foo' , paramized_aref => 'ArrayRef[Num]' => [[ 6.5, 42, 1e23 ]] => [[ 6.5, 42, 'thing' ]] , paramized_href => 'HashRef[Num]' => { a => 6.5, b => 2, c => 1e23 } => { a => 6.5, b => 42, c => 'thing' } , + paramized_nested=> 'HashRef[ArrayRef[Int]]' + => { foo=>[1..3], bar=>[1] } => { foo=>['a'] } , ## ScalarRef[X] not implemented in Mouse, so this test is moved to typeload_moose.t ## if Mouse starts supporting it, the test could be restored here paramized_sref => 'ScalarRef[Num]' => \42 => \'thing' , int_or_aref => 'Int|ArrayRef[Int]' => [ 42 , [42 ] ] => 'foo' , + int_or_aref_or_undef + => 'Int|ArrayRef[Int]|Undef' + => [ 42 , [42 ], undef ] => 'foo' , ); @@ -49,9 +54,14 @@ our $tester; { package TypeCheck::Class; + use strict; + use warnings; + use Test::More; use Test::Fatal; + use Function::Parameters qw(:strict); + method new ($class:) { bless {}, $class; } sub _list { return ref $_[0] eq 'ARRAY' ? @{$_[0]} : ( $_[0] ); } @@ -67,7 +77,7 @@ our $tester; # make sure the declaration of the method doesn't throw a warning is eval qq{ method $method ($type \$bar) {} 42 }, 42; - is $@, ''; + is $@, ''; # positive test--can we call it with a good value? my @vals = _list($goodval); @@ -131,8 +141,9 @@ our $tester; $method = 'unknown_paramized_type'; $type = 'Bmoogle[Int]'; is eval qq{ method $method ($type \$bar) {} 42 }, undef; - like $@, qr/\QCould not locate the base type (Bmoogle)/; + like $@, qr/\QCould not locate the base type (Bmoogle)/; like exception { $tester->$method(42) }, qr/\QCan't locate object method "unknown_paramized_type" via package "TypeCheck::Class"/; + } diff --git a/t/foreign/Method-Signatures/typeload_moose.t b/t/foreign/Method-Signatures/typeload_moose.t index c3d08c0..2ece30d 100644 --- a/t/foreign/Method-Signatures/typeload_moose.t +++ b/t/foreign/Method-Signatures/typeload_moose.t @@ -5,23 +5,37 @@ use warnings FATAL => 'all'; use Dir::Self; use lib __DIR__ . '/lib'; -use Test::More - eval { require Moose; 1 } - ? (tests => 2) - : (skip_all => "Moose required for testing types") -; +use Test::More; +use Test::Fatal; -require MooseLoadTest; +SKIP: +{ + eval { require Moose } or skip "Moose required for testing Moose types", 1; -my $foobar = Foo::Bar->new; + require MooseLoadTest; -# can't check for type module not being loaded here, because Moose will drag it in + my $foobar = Foo::Bar->new; + # can't check for type module not being loaded here, because Moose will drag it in -$foobar->check_int(42); -# now we should have loaded Moose, not Mouse, to do our type checking + $foobar->check_int(42); -is $INC{'Mouse/Util/TypeConstraints.pm'}, undef, "didn't load Mouse"; -like $INC{'Moose/Util/TypeConstraints.pm'}, qr{Moose/Util/TypeConstraints\.pm$}, 'loaded Moose'; + # now we should have loaded Moose to do our type checking + + like $INC{'Moose/Util/TypeConstraints.pm'}, qr{Moose/Util/TypeConstraints\.pm$}, 'loaded Moose'; + + + # tests for ScalarRef[X] have to live here, because they only work with Moose + + my $method = 'check_paramized_sref'; + my $bad_ref = \'thing'; + is exception { $foobar->$method(\42) }, undef, 'call with good value for paramized_sref passes'; + like exception { $foobar->$method($bad_ref) }, + qr/\bcheck_paramized_sref\b.+\$bar\b.+ScalarRef\[Num\]/, + 'call with bad value for paramized_sref dies'; +} + + +done_testing; diff --git a/t/foreign/Method-Signatures/typeload_notypes.t b/t/foreign/Method-Signatures/typeload_notypes.t index 71ad5ea..46cc081 100644 --- a/t/foreign/Method-Signatures/typeload_notypes.t +++ b/t/foreign/Method-Signatures/typeload_notypes.t @@ -16,23 +16,21 @@ use Test::More; method new ($class:) { bless {}, $class; } - # not using a type here, so we won't expect Moose *or* Mouse to get loaded + # not using a type here, so we won't expect Moose to get loaded method foo1 ($bar) {}; } my $foobar = Foo::Bar->new; -# at this point, neither Mouse nor Moose should be loaded +# at this point, Moose should not be loaded -is $INC{'Mouse/Util/TypeConstraints.pm'}, undef, 'no type checking module loaded before method call'; is $INC{'Moose/Util/TypeConstraints.pm'}, undef, 'no type checking module loaded before method call'; $foobar->foo1(42); -# _still_ should have no Moose and no Mouse, because we haven't requested any type checking +# _still_ should have no Moose because we haven't requested any type checking -is $INC{'Mouse/Util/TypeConstraints.pm'}, undef, 'no type checking module loaded before method call'; is $INC{'Moose/Util/TypeConstraints.pm'}, undef, 'no type checking module loaded before method call'; diff --git a/t/foreign/MooseX-Method-Signatures/caller.t b/t/foreign/MooseX-Method-Signatures/caller.t index cbf009a..d434be7 100644 --- a/t/foreign/MooseX-Method-Signatures/caller.t +++ b/t/foreign/MooseX-Method-Signatures/caller.t @@ -3,19 +3,19 @@ use warnings FATAL => 'all'; use Test::More tests => 1; { - package TestClass; + package TestClass; - use Function::Parameters qw(:strict); + use Function::Parameters qw(:strict); - use Carp (); + use Carp (); - method callstack_inner($class:) { - return Carp::longmess("Callstack is"); - } + method callstack_inner($class:) { + return Carp::longmess("Callstack is"); + } - method callstack($class:) { - return $class->callstack_inner; - } + method callstack($class:) { + return $class->callstack_inner; + } } my $callstack = TestClass->callstack(); diff --git a/t/foreign/MooseX-Method-Signatures/closure.t b/t/foreign/MooseX-Method-Signatures/closure.t new file mode 100644 index 0000000..4466b12 --- /dev/null +++ b/t/foreign/MooseX-Method-Signatures/closure.t @@ -0,0 +1,38 @@ +#!perl +use strict; +use warnings FATAL => 'all'; +use Test::More + eval { require Moose } + ? (tests => 7) + : (skip_all => "Moose required for testing types") +; + +{ + package Foo; + + use Moose; + use Function::Parameters qw(:strict); + + for my $meth (qw/foo bar baz/) { + Foo->meta->add_method("anon_$meth" => method (Str $bar) { + $meth . $bar + }); + + eval qq{ + method str_$meth (Str \$bar) { + \$meth . \$bar + } + }; + die $@ if $@; + } +} + +can_ok('Foo', map { ("anon_$_", "str_$_") } qw/foo bar baz/); + +my $foo = Foo->new; + +for my $meth (qw/foo bar baz/) { + is($foo->${\"anon_$meth"}('bar'), $meth . 'bar'); + is($foo->${\"str_$meth"}('bar'), $meth . 'bar'); +} + diff --git a/t/foreign/MooseX-Method-Signatures/errors.t b/t/foreign/MooseX-Method-Signatures/errors.t index 6d1493e..0a621d5 100644 --- a/t/foreign/MooseX-Method-Signatures/errors.t +++ b/t/foreign/MooseX-Method-Signatures/errors.t @@ -1,17 +1,26 @@ #!perl use strict; use warnings FATAL => 'all'; -use Test::More tests => 4; +use Test::More; use Dir::Self; use lib __DIR__ . "/lib"; eval "use InvalidCase01;"; ok($@, "Got an error"); + +#TODO: { +# +#local $TODO = 'Devel::Declare and Eval::Closure have unresolved issues' +# if Eval::Closure->VERSION > 0.06; + 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] }; @@ -21,3 +30,5 @@ like($@, like($warnings, qr/^Subroutine meth1 redefined at .*?\bRedefined.pm line 9\b/, "Redefined method warning"); } + +done_testing; diff --git a/t/foreign/MooseX-Method-Signatures/eval.t b/t/foreign/MooseX-Method-Signatures/eval.t index f4bd321..847b97f 100644 --- a/t/foreign/MooseX-Method-Signatures/eval.t +++ b/t/foreign/MooseX-Method-Signatures/eval.t @@ -34,3 +34,5 @@ __DATA__ method example2 { 2 } } 1; + + diff --git a/t/foreign/MooseX-Method-Signatures/lib/My/Annoyingly/Long/Name/Space.pm b/t/foreign/MooseX-Method-Signatures/lib/My/Annoyingly/Long/Name/Space.pm new file mode 100644 index 0000000..796a0bb --- /dev/null +++ b/t/foreign/MooseX-Method-Signatures/lib/My/Annoyingly/Long/Name/Space.pm @@ -0,0 +1,3 @@ +package My::Annoyingly::Long::Name::Space; +use Moose; +1; diff --git a/t/foreign/MooseX-Method-Signatures/list.t b/t/foreign/MooseX-Method-Signatures/list.t index 9699590..1a9b93e 100644 --- a/t/foreign/MooseX-Method-Signatures/list.t +++ b/t/foreign/MooseX-Method-Signatures/list.t @@ -1,79 +1,87 @@ #!perl use strict; use warnings FATAL => 'all'; -use Test::More tests => 23; +use Test::More + eval { require Moose } + ? (tests => 25) + : (skip_all => "Moose required for testing types") +; use Test::Fatal; use Function::Parameters qw(:strict); my $o = bless {} => 'Foo'; { - my @meths = ( - method ($foo, $bar, @rest) { + my %meths = ( + rest_list => method ($foo, $bar, @rest) { return join q{,}, @rest; }, - method ($foo, $bar, %rest) { + rest_named => method ($foo, $bar, %rest) { return join q{,}, map { $_ => $rest{$_} } sort keys %rest; }, ); - for my $meth (@meths) { - ok(exception { $o->$meth() }); - ok(exception { $o->$meth('foo') }); + for my $meth_name (keys %meths) { + my $meth = $meths{$meth_name}; + like(exception { $o->$meth() }, qr/Not enough arguments/, "$meth_name dies without args"); + like(exception { $o->$meth('foo') }, qr/Not enough arguments/, "$meth_name dies with one arg"); is(exception { - is($o->$meth('foo', 'bar'), q{}); - }, undef); + is($o->$meth('foo', 'bar'), q{}, "$meth_name - empty \@rest list"); + }, undef, '...and validates'); is(exception { - is($o->$meth('foo', 'bar', 1 .. 6), q{1,2,3,4,5,6}); - }, undef); + is($o->$meth('foo', 'bar', 1 .. 6), q{1,2,3,4,5,6}, + "$meth_name - non-empty \@rest list"); + }, undef, '...and validates'); } } { - my $meth = method ($foo, $bar, @rest) { + my $meth = method (Str $foo, Int $bar, Int @rest) { return join q{,}, @rest; }; is(exception { - is($o->$meth('foo', 42), q{}); - }, undef); + is($o->$meth('foo', 42), q{}, 'empty @rest list passed through'); + }, undef, '...and validates'); is(exception { - is($o->$meth('foo', 42, 23, 13), q{23,13}); - }, undef); + is($o->$meth('foo', 42, 23, 13), q{23,13}, 'non-empty int @rest list passed through'); + }, undef, '...and validates'); -# like(exception { -# $o->$meth('foo', 42, 'moo', 13); -# }, qr/Validation failed/); + like(exception { + $o->$meth('foo', 42, 'moo', 13, 'non-empty str @rest list passed through'); + }, qr/\@rest\b.+\bValidation failed/, "...and doesn't validate"); } { - my $meth = method (@foo) { + my $meth = method (ArrayRef[Int] @foo) { return join q{,}, map { @{ $_ } } @foo; }; is(exception { - is($o->$meth([42, 23], [12], [18]), '42,23,12,18'); - }, undef); + is($o->$meth([42, 23], [12], [18]), '42,23,12,18', 'int lists passed through'); + }, undef, '...and validates'); -# like(exception { -# $o->$meth([42, 23], 12, [18]); -# }, qr/Validation failed/); + like(exception { + $o->$meth([42, 23], 12, [18]); + }, qr/Validation failed/, "int doesn't validate against int list"); } { - 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); + my $meth = method (Str $foo, Int @_rest) {}; + is(exception { $meth->($o, 'foo') }, undef, 'empty unnamed list validates'); + is(exception { $meth->($o, 'foo', 42) }, undef, '1 element of unnamed list validates'); + is(exception { $meth->($o, 'foo', 42, 23) }, undef, '2 elements of unnamed list validates'); } { eval 'my $meth = method (:$foo, :@bar) { }'; - like $@, qr/\bnamed\b.+\bbar\b.+\barray\b/; + like $@, qr/\bnamed\b.+\bbar\b.+\barray\b/, + 'arrays or hashes cannot be named'; eval 'my $meth = method ($foo, @bar, :$baz) { }'; - like $@, qr/\bbar\b.+\bbaz\b/; + like $@, qr/\bbar\b.+\bbaz\b/, + 'named parameters cannot be combined with slurpy positionals'; } diff --git a/t/foreign/MooseX-Method-Signatures/named_defaults.t b/t/foreign/MooseX-Method-Signatures/named_defaults.t index b71de88..f8d4577 100644 --- a/t/foreign/MooseX-Method-Signatures/named_defaults.t +++ b/t/foreign/MooseX-Method-Signatures/named_defaults.t @@ -1,7 +1,6 @@ #!perl use strict; use warnings FATAL => 'all'; - use Test::More; { @@ -9,7 +8,7 @@ use Test::More; use Function::Parameters qw(:strict); - method new($class:) { bless {}, $class } + method new($class:) { bless {}, $class } method bar (:$baz = 42) { $baz } } diff --git a/t/foreign/MooseX-Method-Signatures/precedence.t b/t/foreign/MooseX-Method-Signatures/precedence.t index 100c27c..d5463c0 100644 --- a/t/foreign/MooseX-Method-Signatures/precedence.t +++ b/t/foreign/MooseX-Method-Signatures/precedence.t @@ -1,5 +1,6 @@ +#!perl use strict; -use warnings; +use warnings FATAL => 'all'; use Test::More tests => 4; use Function::Parameters qw(:strict); diff --git a/t/foreign/MooseX-Method-Signatures/sigs-optional.t b/t/foreign/MooseX-Method-Signatures/sigs-optional.t index 8c27f57..44f14fe 100644 --- a/t/foreign/MooseX-Method-Signatures/sigs-optional.t +++ b/t/foreign/MooseX-Method-Signatures/sigs-optional.t @@ -5,8 +5,8 @@ use Test::More tests => 4; { package Optional; - use Function::Parameters; - method foo ($class: $arg) { + use Function::Parameters qw(:strict); + method foo ($class: $arg = undef) { $arg; } diff --git a/t/foreign/MooseX-Method-Signatures/too_many_args.t b/t/foreign/MooseX-Method-Signatures/too_many_args.t index ed881d6..c9d1a3e 100644 --- a/t/foreign/MooseX-Method-Signatures/too_many_args.t +++ b/t/foreign/MooseX-Method-Signatures/too_many_args.t @@ -8,7 +8,7 @@ use Test::Fatal; package Foo; use Function::Parameters qw(:strict); - method new($class:) { bless {}, $class } + method new($class:) { bless {}, $class } method foo ($bar) { $bar } } diff --git a/t/foreign/MooseX-Method-Signatures/type_alias.t b/t/foreign/MooseX-Method-Signatures/type_alias.t new file mode 100644 index 0000000..21b8cac --- /dev/null +++ b/t/foreign/MooseX-Method-Signatures/type_alias.t @@ -0,0 +1,31 @@ +#!perl +use strict; +use warnings FATAL => 'all'; +use Test::More + eval { require Moose; require aliased } + ? (tests => 2) + : (skip_all => "Moose, aliased required for testing types") +; +use Test::Fatal; + +use Dir::Self; +use lib __DIR__ . '/lib'; + +{ + package TestClass; + use Moose; + use Function::Parameters qw(:strict); + + use aliased 'My::Annoyingly::Long::Name::Space', 'Shortcut'; + + ::is(::exception { method alias_sig ((Shortcut) $affe) { } }, + undef, 'method with aliased type constraint compiles'); +} + +my $o = TestClass->new; +my $affe = My::Annoyingly::Long::Name::Space->new; + +is(exception { + $o->alias_sig($affe); +}, undef, 'calling method with aliased type constraint'); + diff --git a/t/foreign/MooseX-Method-Signatures/types.t b/t/foreign/MooseX-Method-Signatures/types.t new file mode 100644 index 0000000..12f007d --- /dev/null +++ b/t/foreign/MooseX-Method-Signatures/types.t @@ -0,0 +1,42 @@ +#!perl +use strict; +use warnings FATAL => 'all'; +use Test::More + eval { require Moose; require MooseX::Types } + ? (tests => 4) + : (skip_all => "Moose, MooseX::Types required for testing types") +; +use Test::Fatal; + +{ + package MyTypes; + use MooseX::Types::Moose qw/Str/; + use Moose::Util::TypeConstraints; + use MooseX::Types -declare => [qw/CustomType/]; + + BEGIN { + subtype CustomType, + as Str, + where { length($_) == 2 }; + } +} + +{ + package TestClass; + use Function::Parameters qw(:strict); + BEGIN { MyTypes->import('CustomType') }; + use MooseX::Types::Moose qw/ArrayRef/; + #use namespace::clean; + + method foo ((CustomType) $bar) { } + + method bar ((ArrayRef[CustomType]) $baz) { } +} + +my $o = bless {} => 'TestClass'; + +is(exception { $o->foo('42') }, undef); +ok(exception { $o->foo('bar') }); + +is(exception { $o->bar(['42', '23']) }, undef); +ok(exception { $o->bar(['foo', 'bar']) }); diff --git a/t/foreign/MooseX-Method-Signatures/undef_method_arg.t b/t/foreign/MooseX-Method-Signatures/undef_method_arg.t index cae6717..cdef68e 100644 --- a/t/foreign/MooseX-Method-Signatures/undef_method_arg.t +++ b/t/foreign/MooseX-Method-Signatures/undef_method_arg.t @@ -8,24 +8,24 @@ use Test::Fatal; package Foo; use Function::Parameters qw(:strict); - method new($class:) { bless {}, $class } + method new($class:) { bless {}, $class } - method m1(:$bar ) { } + method m1(:$bar ) { } method m2(:$bar = undef) { } - method m3(:$bar ) { } + method m3(:$bar ) { } - method m4( $bar ) { } - method m5( $bar = undef ) { } - method m6( $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->m1(bar => undef) }, undef, 'Explicitly pass undef to named implicit required arg'); +is(exception { $foo->m2(bar => undef) }, undef, 'Explicitly pass undef to named explicit optional arg'); +is(exception { $foo->m3(bar => undef) }, undef, 'Explicitly pass undef to named implicit required arg'); -is(exception { $foo->m4(undef) }, undef, 'Explicitly pass undef to required arg'); +is(exception { $foo->m4(undef) }, undef, 'Explicitly pass undef to implicit 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'); diff --git a/t/foreign/MooseX-Method-Signatures/undef_method_arg2.t b/t/foreign/MooseX-Method-Signatures/undef_method_arg2.t new file mode 100644 index 0000000..7378e31 --- /dev/null +++ b/t/foreign/MooseX-Method-Signatures/undef_method_arg2.t @@ -0,0 +1,107 @@ +#!perl +use strict; +use warnings FATAL => 'all'; +use Test::More + eval { + require Moose; + require Test::Deep; + } + ? (tests => 4) + : (skip_all => "Moose, Test::Deep required for testing types") +; + +# assigned to by each 'foo' method +my $captured_args; + +{ + package Named; + + use Moose; + use Function::Parameters qw(:strict); + +# use Data::Dumper; + + method foo ( + Str :$foo_a, + Maybe[Str] :$foo_b = undef) { + $captured_args = \@_; + } +} + + +{ + package Positional; + use Moose; + use Function::Parameters qw(:strict); + +# use Data::Dumper; + + method foo ( + Str $foo_a, + Maybe[Str] $foo_b = undef) { + $captured_args = \@_; + } +} + + +use Test::Deep; +#use Data::Dumper; + + + +my $positional = Positional->new; +$positional->foo('str', undef); + +cmp_deeply( + $captured_args, + [ + #noclass({}), + 'str', + undef, + ], + 'positional: explicit undef shows up in @_ correctly', +); + +$positional->foo('str'); + +cmp_deeply( + $captured_args, + [ + #noclass({}), + 'str', + ], + 'positional: omitting an argument results in no entry in @_', +); + +my $named = Named->new; +$named->foo(foo_a => 'str', foo_b => undef); + +cmp_deeply( + $captured_args, + [ + #noclass({}), + foo_a => 'str', + foo_b => undef, + ], + 'named: explicit undef shows up in @_ correctly', +); + +$named->foo(foo_a => 'str'); + +#TODO: { +# local $TODO = 'this fails... should work the same as for positional args.'; +cmp_deeply( + $captured_args, + [ + #noclass({}), + foo_a => 'str', + ], + 'named: omitting an argument results in no entry in @_', +); + +#print "### named captured args: ", Dumper($captured_args); +#} + + + + diff --git a/t/foreign/signatures/proto.t b/t/foreign/signatures/proto.t index 0f68e13..6e0f9e4 100644 --- a/t/foreign/signatures/proto.t +++ b/t/foreign/signatures/proto.t @@ -41,3 +41,5 @@ BEGIN { #} } +#eval 'sub foo ($bar) : proto { $bar }'; +#like($@, qr/proto attribute requires argument/); diff --git a/t/foreign/signatures/weird.t b/t/foreign/signatures/weird.t index 82d1093..3819a71 100644 --- a/t/foreign/signatures/weird.t +++ b/t/foreign/signatures/weird.t @@ -19,3 +19,4 @@ use Function::Parameters; is(foo(qw/affe zomtec/), '($bar, $baz) is ("affe", "zomtec")'); is($moo->(qw/korv wurst/), '($bar, $baz) is ("korv", "wurst")'); +1;