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 {
--- /dev/null
+#!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__
--- /dev/null
+#!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__
+
--- /dev/null
+#!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__
+
--- /dev/null
+#!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__
{
+ 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);
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;
#{
# 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();
--- /dev/null
+#!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 $@, '';
--- /dev/null
+#!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;
+}
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;
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);
}
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;
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];
}
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
}
}
#!perl
-package Foo;
use warnings FATAL => 'all';
use strict;
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/;
--- /dev/null
+package Foo;
+
+use strict;
+use warnings;
+
+use Function::Parameters;
+
+method echo($msg) {
+ return $msg
+}
+
+print Foo->echo(42);
use warnings FATAL => 'all';
use Test::More;
+#use Test::Exception;
{
package Stuff;
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};
}
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};
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];
+
}
--- /dev/null
+#!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;
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;
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' ,
);
{
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] ); }
# 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);
$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"/;
+
}
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;
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';
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();
--- /dev/null
+#!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');
+}
+
#!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] };
like($warnings, qr/^Subroutine meth1 redefined at .*?\bRedefined.pm line 9\b/,
"Redefined method warning");
}
+
+done_testing;
method example2 { 2 }
}
1;
+
+
--- /dev/null
+package My::Annoyingly::Long::Name::Space;
+use Moose;
+1;
#!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';
}
#!perl
use strict;
use warnings FATAL => 'all';
-
use Test::More;
{
use Function::Parameters qw(:strict);
- method new($class:) { bless {}, $class }
+ method new($class:) { bless {}, $class }
method bar (:$baz = 42) { $baz }
}
+#!perl
use strict;
-use warnings;
+use warnings FATAL => 'all';
use Test::More tests => 4;
use Function::Parameters qw(:strict);
{
package Optional;
- use Function::Parameters;
- method foo ($class: $arg) {
+ use Function::Parameters qw(:strict);
+ method foo ($class: $arg = undef) {
$arg;
}
package Foo;
use Function::Parameters qw(:strict);
- method new($class:) { bless {}, $class }
+ method new($class:) { bless {}, $class }
method foo ($bar) { $bar }
}
--- /dev/null
+#!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');
+
--- /dev/null
+#!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']) });
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');
--- /dev/null
+#!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);
+#}
+
+
+
+
#}
}
+#eval 'sub foo ($bar) : proto { $bar }';
+#like($@, qr/proto attribute requires argument/);
is(foo(qw/affe zomtec/), '($bar, $baz) is ("affe", "zomtec")');
is($moo->(qw/korv wurst/), '($bar, $baz) is ("korv", "wurst")');
+1;
projects / p5sagit/Function-Parameters.git / commitdiff