Moose::Meta::Method::Constructor
Moose::Meta::Method::Accessor
- fixed issue with overload::Overloaded getting called
- on non-blessed items.
+ on non-blessed items. (RT #29269)
- added tests for this
* Moose::Coookbook::Snacks
- no longer uses package variable to keep track of
the type constraints, now uses the an instance of
Moose::Meta::TypeConstraint::Registry to do it
+ - added more sophisticated type notation parsing
+ (thanks to mugwump)
+ - added tests for this
* Moose::Meta::TypeConstraint
- some minor adjustments to make subclassing easier
t/040_type_constraints/010_misc_type_tests.t
t/040_type_constraints/011_container_type_constraint.t
t/040_type_constraints/012_container_type_coercion.t
+t/040_type_constraints/013_advanced_type_creation.t
+t/040_type_constraints/014_type_notation_parser.t
t/050_metaclasses/001_custom_attr_meta_with_roles.t
t/050_metaclasses/002_custom_attr_meta_as_role.t
t/050_metaclasses/003_moose_w_metaclass.t
Chris (perigrin) Prather
+Sam (mugwump) Vilain
+
... and many other #moose folks
=head1 COPYRIGHT AND LICENSE
has 'city' => (is => 'rw', isa => 'Str');
has 'state' => (is => 'rw', isa => 'USState');
has 'zip_code' => (is => 'rw', isa => 'USZipCode');
-
+
+ package Company;
+ use Moose;
+ use Moose::Util::TypeConstraints;
+
+ has 'name' => (is => 'rw', isa => 'Str', required => 1);
+ has 'address' => (is => 'rw', isa => 'Address');
+ has 'employees' => (is => 'rw', isa => 'ArrayRef[Employee]');
+
+ sub BUILD {
+ my ($self, $params) = @_;
+ if ($params->{employees}) {
+ foreach my $employee (@{$params->{employees}}) {
+ $employee->company($self);
+ }
+ }
+ }
+
+ after 'employees' => sub {
+ my ($self, $employees) = @_;
+ if (defined $employees) {
+ foreach my $employee (@{$employees}) {
+ $employee->company($self);
+ }
+ }
+ };
+
package Person;
use Moose;
my $self = shift;
super() . ', ' . $self->title
};
-
- package Company;
- use Moose;
-
- has 'name' => (is => 'rw', isa => 'Str', required => 1);
- has 'address' => (is => 'rw', isa => 'Address');
- has 'employees' => (is => 'rw', isa => 'ArrayRef[Employee]');
-
- sub BUILD {
- my ($self, $params) = @_;
- if ($params->{employees}) {
- foreach my $employee (@{$params->{employees}}) {
- $employee->company($self);
- }
- }
- }
-
- after 'employees' => sub {
- my ($self, $employees) = @_;
- if (defined $employees) {
- foreach my $employee (@{$employees}) {
- $employee->company($self);
- }
- }
- };
-
=head1 DESCRIPTION
duplication), since all type constraints are stored in a global registry and
always accessible to C<has>.
-With these two subtypes and some attributes, we have defined as much as we
-need for a basic B<Address> class. Next comes our B<Person> class and its
-subclass, the B<Employee> class.
-
-The B<Person> class is pretty straightforward. We do introduce another attribute
-option, the C<required> option. This option tells Moose that the attribute is
-a required parameter in the constructor, and that the attribute's accessor cannot
-accept an undefined value for the slot. The result is that the attribute
-will always have a value.
-
-In B<Person>, the C<first_name> and C<last_name> attributes are C<required>, and
-the C<middle_initial> slot has an additional C<predicate> method (which we saw
-in the previous recipe with the B<BinaryTree> class).
-
-Next, the B<Employee> class. It requires a C<title>, and maintains a
-weakened reference to a B<Company> instance (which will be defined next).
-The only new item, which we have seen before in examples, but never in
-the recipe itself, is the C<override> method modifier:
-
- override 'full_name' => sub {
- my $self = shift;
- super() . ', ' . $self->title
- };
-
-This just tells Moose that I am intentionally overriding the superclass
-C<full_name> method here, and adding the value of the C<title> slot at
-the end of the employee's full name.
-
-Next, we define a basic B<Company> class, which itself has an address.
-As we saw in earlier recipes, we can use the C<Address> type constraint that
+With these two subtypes and some attributes, we have defined
+as much as we need for a basic B<Address> class. Next, we define
+a basic B<Company> class, which itself has an address. As we saw in
+earlier recipes, we can use the C<Address> type constraint that
Moose automatically created for us:
has 'address' => (is => 'rw', isa => 'Address');
has 'name' => (is => 'rw', isa => 'Str', required => 1);
+Here we introduce another attribute option, the C<required> option.
+This option tells Moose that C<name> is a required parameter in
+the B<Company> constructor, and that the C<name> accessor cannot
+accept an undefined value for the slot. The result is that C<name>
+will always have a value.
+
The next attribute option is not actually new, but a new variant
of options we have already introduced:
has 'employees' => (is => 'rw', isa => 'ArrayRef[Employee]');
-Here we are creating a container type constraint. Container type constraints
-can be either C<ArrayRef> or C<HashRef> and have a second type which specifies
-the kind of values they contain. In this case, we are telling Moose that
-we expect an C<ArrayRef> of C<Employee> objects. This will ensure that our
-employees will all be of the correct type.
-
-It is important to note that container types B<must> be defined already,
-Moose will not create an anon-type for you as it will in other situations.
+Here, we are passing a more complex string to the C<isa> option, we
+are passing a container type constraint. Container type constraints
+can either be C<ArrayRef> or C<HashRef> with a contained type given
+inside the square brackets. This basically checks that all the values
+in the ARRAY ref are instances of the B<Employee> class.
-However, the B<Employee> object (which we will see in a moment) also maintains a
+This will ensure that our employees will all be of the correct type. However,
+the B<Employee> object (which we will see in a moment) also maintains a
reference to its associated B<Company>. In order to maintain this relationship
(and preserve the referential integrity of our objects), we need to perform some
processing of the employees over and above that of the type constraint check.
check has already happened, so we can just check for defined-ness on the
C<$employees> argument.
-At this point, our B<Company> class is complete.
+At this point, our B<Company> class is complete. Next comes our B<Person>
+class and its subclass, the previously mentioned B<Employee> class.
+
+The B<Person> class should be obvious to you at this point. It has a few
+C<required> attributes, and the C<middle_initial> slot has an additional
+C<predicate> method (which we saw in the previous recipe with the
+B<BinaryTree> class).
+
+Next, the B<Employee> class, which should also be pretty obvious at this
+point. It requires a C<title>, and maintains a weakened reference to a
+B<Company> instance. The only new item, which we have seen before in
+examples, but never in the recipe itself, is the C<override> method
+modifier:
+
+ override 'full_name' => sub {
+ my $self = shift;
+ super() . ', ' . $self->title
+ };
+
+This just tells Moose that I am intentionally overriding the superclass
+C<full_name> method here, and adding the value of the C<title> slot at
+the end of the employee's full name.
And that's about it.
}
else {
$options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_type_constraint(
- $options->{isa},
- {
+ $options->{isa} => {
parent => Moose::Util::TypeConstraints::find_type_constraint('Object'),
constraint => sub { $_[0]->isa($options->{isa}) }
}
}
else {
$options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_type_constraint(
- $options->{does},
- {
+ $options->{does} => {
parent => Moose::Util::TypeConstraints::find_type_constraint('Role'),
constraint => sub { $_[0]->does($options->{does}) }
}
sub create_type_constraint_union (@) {
my @type_constraint_names;
- if (scalar @_ == 1 && $_[0] =~ /\|/) {
- @type_constraint_names = (split /\s*\|\s*/ => $_[0]);
+ if (scalar @_ == 1 && _detect_type_constraint_union($_[0])) {
+ @type_constraint_names = _parse_type_constraint_union($_[0]);
}
else {
@type_constraint_names = @_;
sub create_container_type_constraint ($) {
my $type_constraint_name = shift;
- my ($base_type, $container_type) = ($type_constraint_name =~ /^(.*)\[(.*)\]$/);
+ my ($base_type, $container_type) = _parse_container_type_constraint($type_constraint_name);
(defined $base_type && defined $container_type)
|| confess "Could not parse type name ($type_constraint_name) correctly";
($REGISTRY->has_type_constraint($base_type))
|| confess "Could not locate the base type ($base_type)";
-
- ($REGISTRY->has_type_constraint($container_type))
- || confess "Could not locate the container type ($container_type)";
return Moose::Meta::TypeConstraint::Container->new(
name => $type_constraint_name,
parent => $REGISTRY->get_type_constraint($base_type),
- container_type => $REGISTRY->get_type_constraint($container_type),
+ container_type => find_or_create_type_constraint(
+ $container_type => {
+ parent => $REGISTRY->get_type_constraint('Object'),
+ constraint => sub { $_[0]->isa($container_type) }
+ }
+ ),
);
}
my $constraint;
- if ($type_constraint_name =~ /\|/) {
+ if (_detect_type_constraint_union($type_constraint_name)) {
$constraint = create_type_constraint_union($type_constraint_name);
}
- elsif ($type_constraint_name =~ /^.*?\[.*?\]$/) {
+ elsif (_detect_container_type_constraint($type_constraint_name)) {
$constraint = create_container_type_constraint($type_constraint_name);
}
else {
}
## --------------------------------------------------------
+## type notation parsing ...
+## --------------------------------------------------------
+
+{
+ # All I have to say is mugwump++ cause I know
+ # do not even have enough regexp-fu to be able
+ # to have written this (I can only barely
+ # understand it as it is)
+ # - SL
+
+ use re "eval";
+
+ my $valid_chars = qr{[\w:|]};
+ my $type_atom = qr{ $valid_chars+ };
+
+ my $type = qr{ $valid_chars+ (?: \[ (??{$any}) \] )? }x;
+ my $type_capture_parts = qr{ ($valid_chars+) (?: \[ ((??{$any})) \] )? }x;
+ my $type_with_parameter = qr{ $valid_chars+ \[ (??{$any}) \] }x;
+
+ my $op_union = qr{ \s+ \| \s+ }x;
+ my $union = qr{ $type (?: $op_union $type )+ }x;
+
+ our $any = qr{ $type | $union }x;
+
+ sub _parse_container_type_constraint {
+ $_[0] =~ m{ $type_capture_parts }x;
+ return ($1, $2);
+ }
+
+ sub _detect_container_type_constraint {
+ $_[0] =~ m{ ^ $type_with_parameter $ }x;
+ }
+
+ sub _parse_type_constraint_union {
+ my $given = shift;
+ my @rv;
+ while ( $given =~ m{ \G (?: $op_union )? ($type) }gcx ) {
+ push @rv => $1;
+ }
+ (pos($given) eq length($given))
+ || confess "'$given' didn't parse (parse-pos="
+ . pos($given)
+ . " and str-length="
+ . length($given)
+ . ")";
+ @rv;
+ }
+
+ sub _detect_type_constraint_union {
+ $_[0] =~ m{^ $type $op_union $type ( $op_union .* )? $}x;
+ }
+}
+
+## --------------------------------------------------------
# define some basic built-in types
## --------------------------------------------------------
BEGIN {
eval "use Regexp::Common; use Locale::US;";
plan skip_all => "Regexp::Common & Locale::US required for this test" if $@;
- plan tests => 82;
+ plan tests => 81;
}
use Test::Exception;
has 'zip_code' => (is => 'rw', isa => 'USZipCode');
__PACKAGE__->meta->make_immutable(debug => 0);
+}{
+
+ package Company;
+ use Moose;
+ use Moose::Util::TypeConstraints;
+
+ has 'name' => (is => 'rw', isa => 'Str', required => 1);
+ has 'address' => (is => 'rw', isa => 'Address');
+ has 'employees' => (is => 'rw', isa => 'ArrayRef[Employee]');
+
+ sub BUILD {
+ my ($self, $params) = @_;
+ if ($params->{employees}) {
+ foreach my $employee (@{$params->{employees}}) {
+ $employee->company($self);
+ }
+ }
+ }
+
+ sub get_employee_count { scalar @{(shift)->employees} }
+
+ after 'employees' => sub {
+ my ($self, $employees) = @_;
+ # if employees is defined, it
+ # has already been type checked
+ if (defined $employees) {
+ # make sure each gets the
+ # weak ref to the company
+ foreach my $employee (@{$employees}) {
+ $employee->company($self);
+ }
+ }
+ };
+
+ __PACKAGE__->meta->make_immutable(debug => 0);
}{
package Person;
};
__PACKAGE__->meta->make_immutable(debug => 0);
-}{
-
- package Company;
- use Moose;
-
- has 'name' => (is => 'rw', isa => 'Str', required => 1);
- has 'address' => (is => 'rw', isa => 'Address');
- has 'employees' => (is => 'rw', isa => 'ArrayRef[Employee]');
-
- sub BUILD {
- my ($self, $params) = @_;
- if ($params->{employees}) {
- foreach my $employee (@{$params->{employees}}) {
- $employee->company($self);
- }
- }
- }
-
- sub get_employee_count { scalar @{(shift)->employees} }
-
- after 'employees' => sub {
- my ($self, $employees) = @_;
- # if employees is defined, it
- # has already been type checked
- if (defined $employees) {
- # make sure each gets the
- # weak ref to the company
- foreach my $employee (@{$employees}) {
- $employee->company($self);
- }
- }
- };
-
- __PACKAGE__->meta->make_immutable(debug => 0);
}
my $ii;
Company->new(name => 'Foo', employees => [ Person->new ]),
} '... we die correctly with good args';
-dies_ok {
- Company->new(name => 'Foo', employees => [ Employee->new, Company->new ]),
-} '... we die correctly with good args';
-
lives_ok {
Company->new(name => 'Foo', employees => []),
} '... we live correctly with good args';
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 33;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Moose::Util::TypeConstraints');
+ use_ok('Moose::Meta::TypeConstraint::Container');
+}
+
+my $r = Moose::Util::TypeConstraints->get_type_constraint_registry;
+
+## Containers in unions ...
+
+# Array of Ints or Strings
+
+my $array_of_ints_or_strings = Moose::Util::TypeConstraints::create_container_type_constraint('ArrayRef[Int | Str]');
+isa_ok($array_of_ints_or_strings, 'Moose::Meta::TypeConstraint::Container');
+
+ok($array_of_ints_or_strings->check([ 1, 'two', 3 ]), '... this passed the type check');
+ok($array_of_ints_or_strings->check([ 1, 2, 3 ]), '... this passed the type check');
+ok($array_of_ints_or_strings->check([ 'one', 'two', 'three' ]), '... this passed the type check');
+
+ok(!$array_of_ints_or_strings->check([ 1, [], 'three' ]), '... this didnt pass the type check');
+
+$r->add_type_constraint($array_of_ints_or_strings);
+
+# Array of Ints or HashRef
+
+my $array_of_ints_or_hash_ref = Moose::Util::TypeConstraints::create_container_type_constraint('ArrayRef[Int | HashRef]');
+isa_ok($array_of_ints_or_hash_ref, 'Moose::Meta::TypeConstraint::Container');
+
+ok($array_of_ints_or_hash_ref->check([ 1, {}, 3 ]), '... this passed the type check');
+ok($array_of_ints_or_hash_ref->check([ 1, 2, 3 ]), '... this passed the type check');
+ok($array_of_ints_or_hash_ref->check([ {}, {}, {} ]), '... this passed the type check');
+
+ok(!$array_of_ints_or_hash_ref->check([ {}, [], 3 ]), '... this didnt pass the type check');
+
+$r->add_type_constraint($array_of_ints_or_hash_ref);
+
+# union of Arrays of Str | Int or Arrays of Int | Hash
+
+# we can't build this using the simplistic parser
+# we have, so we have to do it by hand - SL
+
+my $pure_insanity = Moose::Util::TypeConstraints::create_type_constraint_union('ArrayRef[Int | Str] | ArrayRef[Int | HashRef]');
+isa_ok($pure_insanity, 'Moose::Meta::TypeConstraint::Union');
+
+ok($pure_insanity->check([ 1, {}, 3 ]), '... this passed the type check');
+ok($pure_insanity->check([ 1, 'Str', 3 ]), '... this passed the type check');
+
+ok(!$pure_insanity->check([ 1, {}, 'foo' ]), '... this didnt pass the type check');
+ok(!$pure_insanity->check([ [], {}, 1 ]), '... this didnt pass the type check');
+
+## Nested Containers ...
+
+# Array of Ints
+
+my $array_of_ints = Moose::Util::TypeConstraints::create_container_type_constraint('ArrayRef[Int]');
+isa_ok($array_of_ints, 'Moose::Meta::TypeConstraint::Container');
+isa_ok($array_of_ints, 'Moose::Meta::TypeConstraint');
+
+ok($array_of_ints->check([ 1, 2, 3, 4 ]), '... [ 1, 2, 3, 4 ] passed successfully');
+ok(!$array_of_ints->check([qw/foo bar baz/]), '... [qw/foo bar baz/] failed successfully');
+ok(!$array_of_ints->check([ 1, 2, 3, qw/foo bar/]), '... [ 1, 2, 3, qw/foo bar/] failed successfully');
+
+ok(!$array_of_ints->check(1), '... 1 failed successfully');
+ok(!$array_of_ints->check({}), '... {} failed successfully');
+ok(!$array_of_ints->check(sub { () }), '... sub { () } failed successfully');
+
+# Array of Array of Ints
+
+my $array_of_array_of_ints = Moose::Util::TypeConstraints::create_container_type_constraint('ArrayRef[ArrayRef[Int]]');
+isa_ok($array_of_array_of_ints, 'Moose::Meta::TypeConstraint::Container');
+isa_ok($array_of_array_of_ints, 'Moose::Meta::TypeConstraint');
+
+ok($array_of_array_of_ints->check(
+ [[ 1, 2, 3 ], [ 4, 5, 6 ]]
+), '... [[ 1, 2, 3 ], [ 4, 5, 6 ]] passed successfully');
+ok(!$array_of_array_of_ints->check(
+ [[ 1, 2, 3 ], [ qw/foo bar/ ]]
+), '... [[ 1, 2, 3 ], [ qw/foo bar/ ]] failed successfully');
+
+# Array of Array of Array of Ints
+
+my $array_of_array_of_array_of_ints = Moose::Util::TypeConstraints::create_container_type_constraint('ArrayRef[ArrayRef[ArrayRef[Int]]]');
+isa_ok($array_of_array_of_array_of_ints, 'Moose::Meta::TypeConstraint::Container');
+isa_ok($array_of_array_of_array_of_ints, 'Moose::Meta::TypeConstraint');
+
+ok($array_of_array_of_array_of_ints->check(
+ [[[ 1, 2, 3 ], [ 4, 5, 6 ]], [[ 7, 8, 9 ]]]
+), '... [[[ 1, 2, 3 ], [ 4, 5, 6 ]], [[ 7, 8, 9 ]]] passed successfully');
+ok(!$array_of_array_of_array_of_ints->check(
+ [[[ 1, 2, 3 ]], [[ qw/foo bar/ ]]]
+), '... [[[ 1, 2, 3 ]], [[ qw/foo bar/ ]]] failed successfully');
+
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 26;
+
+BEGIN {
+ use_ok("Moose::Util::TypeConstraints");
+}
+
+## check the containers
+
+ok(Moose::Util::TypeConstraints::_detect_container_type_constraint($_),
+ '... this correctly detected a container (' . $_ . ')')
+ for (
+ 'ArrayRef[Foo]',
+ 'ArrayRef[Foo | Int]',
+ 'ArrayRef[ArrayRef[Int]]',
+ 'ArrayRef[ArrayRef[Int | Foo]]',
+);
+
+ok(!Moose::Util::TypeConstraints::_detect_container_type_constraint($_),
+ '... this correctly detected a non-container (' . $_ . ')')
+ for (
+ 'ArrayRef[]',
+ 'ArrayRef[Foo]Bar',
+);
+
+{
+ my %split_tests = (
+ 'ArrayRef[Foo]' => [ 'ArrayRef', 'Foo' ],
+ 'ArrayRef[Foo | Int]' => [ 'ArrayRef', 'Foo | Int' ],
+ # these will get processed with recusion,
+ # so we only need to detect it once
+ 'ArrayRef[ArrayRef[Int]]' => [ 'ArrayRef', 'ArrayRef[Int]' ],
+ 'ArrayRef[ArrayRef[Int | Foo]]' => [ 'ArrayRef', 'ArrayRef[Int | Foo]' ],
+ );
+
+ is_deeply(
+ [ Moose::Util::TypeConstraints::_parse_container_type_constraint($_) ],
+ $split_tests{$_},
+ '... this correctly split the container (' . $_ . ')'
+ ) for keys %split_tests;
+}
+
+## now for the unions
+
+ok(Moose::Util::TypeConstraints::_detect_type_constraint_union($_),
+ '... this correctly detected union (' . $_ . ')')
+ for (
+ 'Int | Str',
+ 'ArrayRef[Foo] | Int',
+ 'Int | ArrayRef[Foo]',
+ 'ArrayRef[Foo | Int] | Str',
+ 'Str | ArrayRef[Foo | Int]',
+ 'Some|Silly|Name|With|Pipes | Int',
+);
+
+ok(!Moose::Util::TypeConstraints::_detect_type_constraint_union($_),
+ '... this correctly detected a non-union (' . $_ . ')')
+ for (
+ 'Int',
+ 'ArrayRef[Foo | Int]',
+ 'Some|Silly|Name|With|Pipes',
+);
+
+{
+ my %split_tests = (
+ 'Int | Str' => [ 'Int', 'Str' ],
+ 'ArrayRef[Foo] | Int' => [ 'ArrayRef[Foo]', 'Int' ],
+ 'Int | ArrayRef[Foo]' => [ 'Int', 'ArrayRef[Foo]' ],
+ 'ArrayRef[Foo | Int] | Str' => [ 'ArrayRef[Foo | Int]', 'Str' ],
+ 'Str | ArrayRef[Foo | Int]' => [ 'Str', 'ArrayRef[Foo | Int]' ],
+ 'Some|Silly|Name|With|Pipes | Int' => [ 'Some|Silly|Name|With|Pipes', 'Int' ],
+ );
+
+ is_deeply(
+ [ Moose::Util::TypeConstraints::_parse_type_constraint_union($_) ],
+ $split_tests{$_},
+ '... this correctly split the union (' . $_ . ')'
+ ) for keys %split_tests;
+}
projects / gitmo/Moose.git / commitdiff