'meta-spec' => { version => 2 },
resources => {
repository => {
- url => 'git://git.shadowcat.co.uk/p5sagit/Function-Parameters',
- web => 'http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit/Function-Parameters.git',
+ url => 'git://github.com/mauke/Function-Parameters',
+ web => 'https://github.com/mauke//Function-Parameters',
type => 'git',
},
},
my @bare_arms = qw(function method);
my %type_map = (
- function => {
- name => 'optional',
- default_arguments => 1,
- check_argument_count => 0,
- named_parameters => 1,
- types => 1,
- reify_type => \&_reify_type_default,
+ function => {}, # all default settings
+ function_strict => {
+ defaults => 'function',
+ strict => 1,
},
- method => {
- name => 'optional',
- default_arguments => 1,
- check_argument_count => 0,
- named_parameters => 1,
- types => 1,
- reify_type => \&_reify_type_default,
- attrs => ':method',
- shift => '$self',
- invocant => 1,
+ method => {
+ defaults => 'function',
+ attributes => ':method',
+ shift => '$self',
+ invocant => 1,
},
- classmethod => {
- name => 'optional',
- default_arguments => 1,
- check_argument_count => 0,
- named_parameters => 1,
- types => 1,
- reify_type => \&_reify_type_default,
- attributes => ':method',
- shift => '$class',
- invocant => 1,
+ method_strict => {
+ defaults => 'method',
+ strict => 1,
+ },
+ classmethod => {
+ defaults => 'method',
+ shift => '$class',
+ },
+ classmethod_strict => {
+ defaults => 'classmethod',
+ strict => 1,
},
);
-for my $k (keys %type_map) {
- $type_map{$k . '_strict'} = {
- %{$type_map{$k}},
- check_argument_count => 1,
- };
-}
our @type_reifiers = \&_reify_type_default;
my ($name, $proto_type) = @$item;
_assert_valid_identifier $name;
- unless (ref $proto_type) {
- # use '||' instead of 'or' to preserve $proto_type in the error message
- $proto_type = $type_map{$proto_type}
- || confess qq["$proto_type" doesn't look like a valid type (one of ${\join ', ', sort keys %type_map})];
- }
+ $proto_type = {defaults => $proto_type} unless ref $proto_type;
my %type = %$proto_type;
+ while (my $defaults = delete $type{defaults}) {
+ my $base = $type_map{$defaults}
+ or confess qq["$defaults" doesn't look like a valid type (one of ${\join ', ', sort keys %type_map})];
+ %type = (%$base, %type);
+ }
+
my %clean;
- $clean{name} = delete $type{name} || 'optional';
+ $clean{name} = delete $type{name} // 'optional';
$clean{name} =~ /^(?:optional|required|prohibited)\z/
or confess qq["$clean{name}" doesn't look like a valid name attribute (one of optional, required, prohibited)];
- $clean{shift} = delete $type{shift} || '';
+ $clean{shift} = delete $type{shift} // '';
_assert_valid_identifier $clean{shift}, 1 if $clean{shift};
- $clean{attrs} = join ' ', map delete $type{$_} || (), qw(attributes attrs);
+ $clean{attrs} = join ' ', map delete $type{$_} // (), qw(attributes attrs);
_assert_valid_attributes $clean{attrs} if $clean{attrs};
$clean{default_arguments} = _delete_default \%type, 'default_arguments', 1;
$clean{named_parameters} = _delete_default \%type, 'named_parameters', 1;
$clean{types} = _delete_default \%type, 'types', 1;
- $clean{check_argument_count} = _delete_default \%type, 'check_argument_count', 0;
$clean{invocant} = _delete_default \%type, 'invocant', 0;
+ $clean{check_argument_count} = _delete_default \%type, 'check_argument_count', 0;
+ $clean{check_argument_types} = _delete_default \%type, 'check_argument_types', 0;
+ $clean{check_argument_count} = $clean{check_argument_types} = 1 if delete $type{strict};
if (my $rt = delete $type{reify_type}) {
ref $rt eq 'CODE' or confess qq{"$rt" doesn't look like a type reifier};
$type->{name} eq 'required' ? FLAG_NAME_OK :
FLAG_ANON_OK | FLAG_NAME_OK
;
- $flags |= FLAG_DEFAULT_ARGS if $type->{default_arguments};
- $flags |= FLAG_CHECK_NARGS | FLAG_CHECK_TARGS if $type->{check_argument_count};
- $flags |= FLAG_INVOCANT if $type->{invocant};
- $flags |= FLAG_NAMED_PARAMS if $type->{named_parameters};
- $flags |= FLAG_TYPES_OK if $type->{types};
+ $flags |= FLAG_DEFAULT_ARGS if $type->{default_arguments};
+ $flags |= FLAG_CHECK_NARGS if $type->{check_argument_count};
+ $flags |= FLAG_CHECK_TARGS if $type->{check_argument_types};
+ $flags |= FLAG_INVOCANT if $type->{invocant};
+ $flags |= FLAG_NAMED_PARAMS if $type->{named_parameters};
+ $flags |= FLAG_TYPES_OK if $type->{types};
$^H{HINTK_FLAGS_ . $kw} = $flags;
$^H{HINTK_SHIFT_ . $kw} = $type->{shift};
$^H{HINTK_ATTRS_ . $kw} = $type->{attrs};
=over
+=item C<defaults>
+
+Valid values: One of the predefined types C<function>, C<method>,
+C<classmethod>, C<function_strict>, C<method_strict>, C<classmethod_strict>.
+This will set the defaults for all other keys from the specified type, which is
+useful if you only want to override some properties:
+
+ use Function::Parameters { defmethod => { defaults => 'method', shift => '$this' } };
+
+This example defines a keyword called C<defmethod> that works like the standard
+C<method> keyword, but the implicit object variable is called C<$this> instead
+of C<$self>.
+
+Using the string types directly is equivalent to C<defaults> with no further
+customization:
+
+ use Function::Parameters {
+ foo => 'function', # like: foo => { defaults => 'function' },
+ bar => 'function_strict', # like: bar => { defaults => 'function_strict' },
+ baz => 'method_strict', # like: baz => { defaults => 'method_strict' },
+ };
+
=item C<name>
Valid values: C<optional> (default), C<required> (all functions defined with
excess arguments. If this check fails, an exception will by thrown via
L<C<Carp::croak>|Carp>.
-Currently this flag is overloaded to also enable type checks (see
-L</Experimental feature: Types> below).
+=item C<check_argument_types>
+
+Valid values: booleans. If turned on, functions defined with this keyword will
+automatically check that the arguments they are passed pass the declared type
+constraints (if any). See L</Experimental feature: Types> below.
+
+=item C<strict>
+
+Valid values: booleans. This turns on both C<check_argument_count> and
+C<check_argument_types>.
=item C<reify_type>
The predefined type C<function> is equivalent to:
{
- name => 'optional',
- invocant => 0,
- default_arguments => 1,
- check_argument_count => 0,
+ name => 'optional',
+ default_arguments => 1,
+ strict => 0,
+ invocant => 0,
}
These are all default values, so C<function> is also equivalent to C<{}>.
C<method> is equivalent to:
{
- name => 'optional',
- shift => '$self',
- invocant => 1,
- attributes => ':method',
- default_arguments => 1,
- check_argument_count => 0,
+ defaults => 'function',
+ attributes => ':method',
+ shift => '$self',
+ invocant => 1,
}
C<classmethod> is equivalent to:
{
- name => 'optional',
- shift => '$class',
- invocant => 1,
- attributes => ':method',
- default_arguments => 1,
- check_argument_count => 0,
+ defaults => 'method',
+ shift => '$class',
}
C<function_strict>, C<method_strict>, and
C<classmethod_strict> are like C<function>, C<method>, and
-C<classmethod>, respectively, but with C<< check_argument_count => 1 >>.
+C<classmethod>, respectively, but with C<< strict => 1 >>.
=back
use Function::Parameters {
fun => {
- check_argument_count => 1,
+ defaults => 'function_strict',
},
};
use Function::Parameters {
fun => {
- check_argument_count => 1,
- default_arguments => 1,
+ strict => 1,
},
sad => {
- check_argument_count => 0,
+ strict => 0,
},
};
use Function::Parameters {
method => {
- check_argument_count => 1,
- shift => '$self',
- attributes => ':method',
+ defaults => 'method',
+ strict => 1,
},
cathod => {
- check_argument_count => 0,
- shift => '$self',
- attrs => ':method',
+ defaults => 'method',
+ strict => 0,
},
fun => 'function',
use Function::Parameters;
use Function::Parameters {
- action => { shift => '$monster', invocant => 1 },
- constructor => { shift => '$species', invocant => 1 },
- function => 'function',
+ action => { defaults => 'method', shift => '$monster' },
+ constructor => { defaults => 'method', shift => '$species' },
+ 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 }
+ ? (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 Test::More;
-use Function::Parameters qw(:strict);;
+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 }
+ ? ()
+ : (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;
use strict;
use Test::More
- eval { require Moo; 1 }
+ eval { require Moo }
? (tests => 122)
: (skip_all => "Moo required for testing parameter introspection")
;
use Function::Parameters qw(:strict);
use Function::Parameters {
- def => { check_argument_count => 1 },
+ def => { strict => 1 },
};
{
);
+{
fun => {
- check_argument_count => 1,
+ strict => 1,
reify_type => sub { $Types{ $_[0] } || $Types{Any} },
},
}
use Function::Parameters {
fun => {
- check_argument_count => 1,
+ strict => 1,
reify_type => sub {
my ($type, $package) = @_;
if ($package ne $type) {
use strict;
use Test::More
- eval { require Moose; 1 }
+ eval { require Moose }
? (tests => 49)
: (skip_all => "Moose required for testing types")
;
use strict;
use Test::More
- eval { require Moose::Util; 1 }
+ eval { require Moose::Util }
? (tests => 49)
: (skip_all => "Moose required for testing types")
;
use strict;
use Test::More
- eval { require Moose; 1 }
+ eval { require Moose }
? (tests => 49)
: (skip_all => "Moose required for testing types")
;
use Test::Fatal;
use Function::Parameters {
- def => { check_argument_count => 1 },
+ def => { strict => 1 },
};
def foo(Int $n, CodeRef $f, $x) {
use strict;
use Test::More
- eval { require MooseX::Types; 1 }
+ eval { require MooseX::Types }
? (tests => 49)
: (skip_all => "MooseX::Types required for testing types")
;
projects / p5sagit/Function-Parameters.git / commitdiff