From: Stevan Little Date: Wed, 28 Nov 2007 22:13:29 +0000 (+0000) Subject: fixing union type constraint aliases X-Git-Tag: 0_32~5 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=8de73ff1824ee835a072b36cd603deb7037983b5;p=gitmo%2FMoose.git fixing union type constraint aliases --- diff --git a/Changes b/Changes index 9634ade..3200d20 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,16 @@ Revision history for Perl extension Moose +0.32 + * Moose::Util::TypeConstraints + - fixing how subtype aliases of unions work + they should inherit the parent's coercion + - added tests for this + + * Moose::Meta::TypeConstraint + - there is now a default constraint of sub { 1 } + instead of Moose::Util::TypeConstraints setting + this for us + 0.31 Mon. Nov. 26, 2007 * Moose::Meta::Attribute - made the +attr syntax handle extending types with diff --git a/MANIFEST b/MANIFEST index 067e78c..f4baebd 100644 --- a/MANIFEST +++ b/MANIFEST @@ -108,6 +108,7 @@ t/040_type_constraints/013_advanced_type_creation.t t/040_type_constraints/014_type_notation_parser.t t/040_type_constraints/015_enum.t t/040_type_constraints/016_subtyping_parameterized_types.t +t/040_type_constraints/017_subtyping_union_types.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 diff --git a/lib/Moose.pm b/lib/Moose.pm index ed365ce..526b67f 100644 --- a/lib/Moose.pm +++ b/lib/Moose.pm @@ -4,7 +4,7 @@ package Moose; use strict; use warnings; -our $VERSION = '0.31'; +our $VERSION = '0.32'; our $AUTHORITY = 'cpan:STEVAN'; use Scalar::Util 'blessed', 'reftype'; diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm index 5f3b8bb..9dbc1c2 100644 --- a/lib/Moose/Meta/Attribute.pm +++ b/lib/Moose/Meta/Attribute.pm @@ -75,25 +75,25 @@ sub clone_and_inherit_options { # new type is a subtype if ($options{isa}) { my $type_constraint; - if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) { - $type_constraint = $options{isa}; - } - else { - $type_constraint = Moose::Util::TypeConstraints::find_or_create_type_constraint( - $options{isa} - ); - (defined $type_constraint) - || confess "Could not find the type constraint '" . $options{isa} . "'"; - } - # NOTE: - # check here to see if the new type - # is a subtype of the old one - ($type_constraint->is_subtype_of($self->type_constraint->name)) - || confess "New type constraint setting must be a subtype of inherited one" - # iff we have a type constraint that is ... - if $self->has_type_constraint; - # then we use it :) - $actual_options{type_constraint} = $type_constraint; + if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) { + $type_constraint = $options{isa}; + } + else { + $type_constraint = Moose::Util::TypeConstraints::find_or_create_type_constraint( + $options{isa} + ); + (defined $type_constraint) + || confess "Could not find the type constraint '" . $options{isa} . "'"; + } + # NOTE: + # check here to see if the new type + # is a subtype of the old one + ($type_constraint->is_subtype_of($self->type_constraint->name)) + || confess "New type constraint setting must be a subtype of inherited one" + # iff we have a type constraint that is ... + if $self->has_type_constraint; + # then we use it :) + $actual_options{type_constraint} = $type_constraint; delete $options{isa}; } (scalar keys %options == 0) @@ -103,26 +103,25 @@ sub clone_and_inherit_options { sub _process_options { my ($class, $name, $options) = @_; - + if (exists $options->{is}) { - if ($options->{is} eq 'ro') { - $options->{reader} ||= $name; - (!exists $options->{trigger}) - || confess "Cannot have a trigger on a read-only attribute"; - } - elsif ($options->{is} eq 'rw') { - $options->{accessor} = $name; - ((reftype($options->{trigger}) || '') eq 'CODE') - || confess "Trigger must be a CODE ref" - if exists $options->{trigger}; - } - else { - confess "I do not understand this option (is => " . $options->{is} . ")" - } + if ($options->{is} eq 'ro') { + $options->{reader} ||= $name; + (!exists $options->{trigger}) + || confess "Cannot have a trigger on a read-only attribute"; + } + elsif ($options->{is} eq 'rw') { + $options->{accessor} = $name; + ((reftype($options->{trigger}) || '') eq 'CODE') + || confess "Trigger must be a CODE ref" + if exists $options->{trigger}; + } + else { + confess "I do not understand this option (is => " . $options->{is} . ")" + } } - + if (exists $options->{isa}) { - if (exists $options->{does}) { if (eval { $options->{isa}->can('does') }) { ($options->{isa}->does($options->{does})) @@ -132,53 +131,53 @@ sub _process_options { confess "Cannot have an isa option which cannot ->does()"; } } - + # allow for anon-subtypes here ... if (blessed($options->{isa}) && $options->{isa}->isa('Moose::Meta::TypeConstraint')) { - $options->{type_constraint} = $options->{isa}; - } - else { - $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_type_constraint( - $options->{isa} => { + $options->{type_constraint} = $options->{isa}; + } + else { + $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_type_constraint( + $options->{isa} => { parent => Moose::Util::TypeConstraints::find_type_constraint('Object'), constraint => sub { $_[0]->isa($options->{isa}) } } - ); - } + ); + } } elsif (exists $options->{does}) { # allow for anon-subtypes here ... if (blessed($options->{does}) && $options->{does}->isa('Moose::Meta::TypeConstraint')) { - $options->{type_constraint} = $options->{isa}; - } - else { - $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_type_constraint( - $options->{does} => { + $options->{type_constraint} = $options->{isa}; + } + else { + $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_type_constraint( + $options->{does} => { parent => Moose::Util::TypeConstraints::find_type_constraint('Role'), constraint => sub { $_[0]->does($options->{does}) } } - ); - } + ); + } } - + if (exists $options->{coerce} && $options->{coerce}) { (exists $options->{type_constraint}) || confess "You cannot have coercion without specifying a type constraint"; - confess "You cannot have a weak reference to a coerced value" - if $options->{weak_ref}; + confess "You cannot have a weak reference to a coerced value" + if $options->{weak_ref}; } - + if (exists $options->{auto_deref} && $options->{auto_deref}) { (exists $options->{type_constraint}) || confess "You cannot auto-dereference without specifying a type constraint"; ($options->{type_constraint}->is_a_type_of('ArrayRef') || - $options->{type_constraint}->is_a_type_of('HashRef')) + $options->{type_constraint}->is_a_type_of('HashRef')) || confess "You cannot auto-dereference anything other than a ArrayRef or HashRef"; } - + if (exists $options->{lazy_build} && $options->{lazy_build} == 1) { confess("You can not use lazy_build and default for the same attribute") - if exists $options->{default}; + if exists $options->{default}; $options->{lazy} = 1; $options->{required} = 1; $options->{builder} ||= "_build_${name}"; @@ -190,7 +189,7 @@ sub _process_options { $options->{predicate} ||= "has_${name}"; } } - + if (exists $options->{lazy} && $options->{lazy}) { (exists $options->{default} || exists $options->{builder} ) || confess "You cannot have lazy attribute without specifying a default value for it"; @@ -308,21 +307,21 @@ sub get_value { my ($self, $instance) = @_; if ($self->is_lazy) { - unless ($self->has_value($instance)) { - if ($self->has_default) { - my $default = $self->default($instance); - $self->set_value($instance, $default); - } - if ( $self->has_builder ){ - if(my $builder = $instance->can($self->builder)){ - $self->set_value($instance, $instance->$builder); - } else { - confess(blessed($instance)." does not support builder method '".$self->builder."' for attribute '" . $self->name . "'"); - } + unless ($self->has_value($instance)) { + if ($self->has_default) { + my $default = $self->default($instance); + $self->set_value($instance, $default); + } + if ( $self->has_builder ){ + if(my $builder = $instance->can($self->builder)){ + $self->set_value($instance, $instance->$builder); } else { - $self->set_value($instance, undef); + confess(blessed($instance)." does not support builder method '".$self->builder."' for attribute '" . $self->name . "'"); } + } else { + $self->set_value($instance, undef); } + } } if ($self->should_auto_deref) { diff --git a/lib/Moose/Meta/TypeCoercion/Union.pm b/lib/Moose/Meta/TypeCoercion/Union.pm index 31446f4..ef1d174 100644 --- a/lib/Moose/Meta/TypeCoercion/Union.pm +++ b/lib/Moose/Meta/TypeCoercion/Union.pm @@ -27,7 +27,7 @@ sub compile_type_coercion { # in the union, and check em ... foreach my $type (@{$type_constraint->type_constraints}) { # if they have a coercion first - if ($type->has_coercion) { + if ($type->has_coercion) { # then try to coerce them ... my $temp = $type->coerce($value); # and if they get something diff --git a/lib/Moose/Meta/TypeConstraint.pm b/lib/Moose/Meta/TypeConstraint.pm index b4aa0fa..e7eaf18 100644 --- a/lib/Moose/Meta/TypeConstraint.pm +++ b/lib/Moose/Meta/TypeConstraint.pm @@ -12,7 +12,7 @@ use Sub::Name 'subname'; use Carp 'confess'; use Scalar::Util 'blessed'; -our $VERSION = '0.09'; +our $VERSION = '0.10'; our $AUTHORITY = 'cpan:STEVAN'; __PACKAGE__->meta->add_attribute('name' => (reader => 'name')); @@ -21,8 +21,9 @@ __PACKAGE__->meta->add_attribute('parent' => ( predicate => 'has_parent', )); __PACKAGE__->meta->add_attribute('constraint' => ( - reader => 'constraint', - writer => '_set_constraint', + reader => 'constraint', + writer => '_set_constraint', + default => sub { sub { 1 } } )); __PACKAGE__->meta->add_attribute('message' => ( accessor => 'message', diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm index 9bef612..dbfe58d 100644 --- a/lib/Moose/Util/TypeConstraints.pm +++ b/lib/Moose/Util/TypeConstraints.pm @@ -9,7 +9,7 @@ use Scalar::Util 'blessed', 'reftype'; use B 'svref_2object'; use Sub::Exporter; -our $VERSION = '0.16'; +our $VERSION = '0.17'; our $AUTHORITY = 'cpan:STEVAN'; ## -------------------------------------------------------- @@ -245,7 +245,7 @@ sub enum ($;@) { sub _create_type_constraint ($$$;$$) { my $name = shift; my $parent = shift; - my $check = shift || sub { 1 }; + my $check = shift; my ($message, $optimized); for (@_) { @@ -266,7 +266,7 @@ sub _create_type_constraint ($$$;$$) { } $parent = find_or_create_type_constraint($parent) if defined $parent; - + my $constraint = Moose::Meta::TypeConstraint->new( name => $name || '__ANON__', package_defined_in => $pkg_defined_in, @@ -276,6 +276,21 @@ sub _create_type_constraint ($$$;$$) { ($message ? (message => $message) : ()), ($optimized ? (optimized => $optimized) : ()), ); + + # NOTE: + # if we have a type constraint union, and no + # type check, this means we are just aliasing + # the union constraint, which means we need to + # handle this differently. + # - SL + if (not(defined($check)) + && $parent->isa('Moose::Meta::TypeConstraint::Union') + && $parent->has_coercion + ){ + $constraint->coercion(Moose::Meta::TypeCoercion::Union->new( + type_constraint => $parent + )); + } $REGISTRY->add_type_constraint($constraint) if defined $name; diff --git a/t/040_type_constraints/009_union_types_and_coercions.t b/t/040_type_constraints/009_union_types_and_coercions.t index 147859b..a7d33d9 100644 --- a/t/040_type_constraints/009_union_types_and_coercions.t +++ b/t/040_type_constraints/009_union_types_and_coercions.t @@ -47,11 +47,15 @@ BEGIN { => from 'FileHandle' => via { bless $_, 'IO::File' }; + # create the alias + + subtype 'IO::StringOrFile' => as 'IO::String | IO::File'; + # attributes has 'raw_body' => ( is => 'rw', - isa => 'IO::String|IO::File', + isa => 'IO::StringOrFile', coerce => 1, default => sub { IO::String->new() }, ); diff --git a/t/040_type_constraints/017_subtyping_union_types.t b/t/040_type_constraints/017_subtyping_union_types.t new file mode 100644 index 0000000..1063379 --- /dev/null +++ b/t/040_type_constraints/017_subtyping_union_types.t @@ -0,0 +1,69 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 18; +use Test::Exception; + +BEGIN { + use_ok("Moose::Util::TypeConstraints"); +} + +lives_ok { + subtype 'MyCollections' => as 'ArrayRef | HashRef'; +} '... created the subtype special okay'; + +{ + my $t = find_type_constraint('MyCollections'); + isa_ok($t, 'Moose::Meta::TypeConstraint'); + + is($t->name, 'MyCollections', '... name is correct'); + + my $p = $t->parent; + isa_ok($p, 'Moose::Meta::TypeConstraint::Union'); + isa_ok($p, 'Moose::Meta::TypeConstraint'); + + is($p->name, 'ArrayRef | HashRef', '... parent name is correct'); + + ok($t->check([]), '... validated it correctly'); + ok($t->check({}), '... validated it correctly'); + ok(!$t->check(1), '... validated it correctly'); +} + +lives_ok { + subtype 'MyCollectionsExtended' + => as 'ArrayRef | HashRef' + => where { + if (ref($_) eq 'ARRAY') { + return if scalar(@$_) < 2; + } + elsif (ref($_) eq 'HASH') { + return if scalar(keys(%$_)) < 2; + } + 1; + }; +} '... created the subtype special okay'; + +{ + my $t = find_type_constraint('MyCollectionsExtended'); + isa_ok($t, 'Moose::Meta::TypeConstraint'); + + is($t->name, 'MyCollectionsExtended', '... name is correct'); + + my $p = $t->parent; + isa_ok($p, 'Moose::Meta::TypeConstraint::Union'); + isa_ok($p, 'Moose::Meta::TypeConstraint'); + + is($p->name, 'ArrayRef | HashRef', '... parent name is correct'); + + ok(!$t->check([]), '... validated it correctly'); + ok($t->check([1, 2]), '... validated it correctly'); + + ok(!$t->check({}), '... validated it correctly'); + ok($t->check({ one => 1, two => 2 }), '... validated it correctly'); + + ok(!$t->check(1), '... validated it correctly'); +} + +