X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FMeta%2FAttribute.pm;h=627776965677b8551e60e8cbca39e91f8ba6e2a8;hb=refs%2Ftags%2F0.66;hp=dc96d66b79c40a4c29f9f9a6670ccb8cac44a4c1;hpb=e8895723204a63333b492c0b70f0e099b8baa25d;p=gitmo%2FMoose.git diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm index dc96d66..6277769 100644 --- a/lib/Moose/Meta/Attribute.pm +++ b/lib/Moose/Meta/Attribute.pm @@ -7,7 +7,7 @@ use warnings; use Scalar::Util 'blessed', 'weaken'; use overload (); -our $VERSION = '0.59'; +our $VERSION = '0.66'; our $AUTHORITY = 'cpan:STEVAN'; use Moose::Meta::Method::Accessor; @@ -108,11 +108,24 @@ sub interpolate_class { my @traits; if (my $traits = $options{traits}) { - if ( @traits = grep { not $class->does($_) } map { - Moose::Util::resolve_metatrait_alias( Attribute => $_ ) - or - $_ - } @$traits ) { + my $i = 0; + while ($i < @$traits) { + my $trait = $traits->[$i++]; + next if ref($trait); # options to a trait we discarded + + $trait = Moose::Util::resolve_metatrait_alias(Attribute => $trait) + || $trait; + + next if $class->does($trait); + + push @traits, $trait; + + # are there options? + push @traits, $traits->[$i++] + if $traits->[$i] && ref($traits->[$i]); + } + + if (@traits) { my $anon_class = Moose::Meta::Class->create_anon_class( superclasses => [ $class ], roles => [ @traits ], @@ -132,6 +145,7 @@ my @legal_options_for_inheritance = qw( default coerce required documentation lazy handles builder type_constraint + definition_context ); sub legal_options_for_inheritance { @legal_options_for_inheritance } @@ -398,11 +412,7 @@ sub initialize_instance_slot { if ($self->should_coerce && $type_constraint->has_coercion) { $val = $type_constraint->coerce($val); } - $type_constraint->check($val) - || $self->throw_error("Attribute (" - . $self->name - . ") does not pass the type constraint because: " - . $type_constraint->get_message($val), data => $val, object => $instance); + $self->verify_against_type_constraint($val, instance => $instance); } $self->set_initial_value($instance, $val); @@ -454,11 +464,7 @@ sub _set_initial_slot_value { if ($type_constraint) { $val = $type_constraint->coerce($val) if $can_coerce; - $type_constraint->check($val) - || $self->throw_error("Attribute (" - . $slot_name - . ") does not pass the type constraint because: " - . $type_constraint->get_message($val), data => $val, object => $instance); + $self->verify_against_type_constraint($val, object => $instance); } $meta_instance->set_slot_value($instance, $slot_name, $val); }; @@ -522,10 +528,7 @@ sub get_value { my $type_constraint = $self->type_constraint; $value = $type_constraint->coerce($value) if ($self->should_coerce); - $type_constraint->check($value) - || $self->throw_error("Attribute (" . $self->name - . ") does not pass the type constraint because: " - . $type_constraint->get_message($value), type_constraint => $type_constraint, data => $value); + $self->verify_against_type_constraint($value); } $self->set_initial_value($instance, $value); } @@ -567,6 +570,13 @@ sub install_accessors { return; } +sub remove_accessors { + my $self = shift; + $self->SUPER::remove_accessors(@_); + $self->remove_delegation if $self->has_handles; + return; +} + sub install_delegation { my $self = shift; @@ -604,6 +614,15 @@ sub install_delegation { } } +sub remove_delegation { + my $self = shift; + my %handles = $self->_canonicalize_handles; + my $associated_class = $self->associated_class; + foreach my $handle (keys %handles) { + $self->associated_class->remove_method($handle); + } +} + # private methods to help delegation ... sub _canonicalize_handles { @@ -618,7 +637,7 @@ sub _canonicalize_handles { } elsif ($handle_type eq 'Regexp') { ($self->has_type_constraint) - || $self->throw_error("Cannot delegate methods based on a RegExpr without a type constraint (isa)", data => $handles); + || $self->throw_error("Cannot delegate methods based on a Regexp without a type constraint (isa)", data => $handles); return map { ($_ => $_) } grep { /$handles/ } $self->_get_delegate_method_list; } @@ -630,6 +649,9 @@ sub _canonicalize_handles { } } else { + Class::MOP::load_class($handles) + unless Class::MOP::is_class_loaded($handles); + my $role_meta = eval { $handles->meta }; if ($@) { $self->throw_error("Unable to canonicalize the 'handles' option with $handles because : $@", data => $handles, error => $@); @@ -637,7 +659,7 @@ sub _canonicalize_handles { (blessed $role_meta && $role_meta->isa('Moose::Meta::Role')) || $self->throw_error("Unable to canonicalize the 'handles' option with $handles because ->meta is not a Moose::Meta::Role", data => $handles); - + return map { $_ => $_ } ( $role_meta->get_method_list, $role_meta->get_required_method_list @@ -683,6 +705,8 @@ sub _get_delegate_method_list { } } +sub delegation_metaclass { 'Moose::Meta::Method::Delegation' } + sub _make_delegation_method { my ( $self, $handle_name, $method_to_call ) = @_; @@ -691,7 +715,7 @@ sub _make_delegation_method { $method_body = $method_to_call if 'CODE' eq ref($method_to_call); - return Moose::Meta::Method::Delegation->new( + return $self->delegation_metaclass->new( name => $handle_name, package_name => $self->associated_class->name, attribute => $self, @@ -699,6 +723,21 @@ sub _make_delegation_method { ); } +sub verify_against_type_constraint { + my $self = shift; + my $val = shift; + + return 1 if !$self->has_type_constraint; + + my $type_constraint = $self->type_constraint; + + $type_constraint->check($val) + || $self->throw_error("Attribute (" + . $self->name + . ") does not pass the type constraint because: " + . $type_constraint->get_message($val), data => $val, @_); +} + package Moose::Meta::Attribute::Custom::Moose; sub register_implementation { 'Moose::Meta::Attribute' } @@ -742,10 +781,16 @@ will behave just as L does. =item B +=item B + =item B +=item B + =item B +=item B + =item B =item B @@ -810,6 +855,11 @@ A read-only accessor for this meta-attribute's type constraint. For more information on what you can do with this, see the documentation for L. +=item B + +Verifies that the given value is valid under this attribute's type +constraint, otherwise throws an error. + =item B Returns true if this meta-attribute performs delegation. @@ -918,7 +968,7 @@ Yuval Kogman Enothingmuch@woobling.comE =head1 COPYRIGHT AND LICENSE -Copyright 2006-2008 by Infinity Interactive, Inc. +Copyright 2006-2009 by Infinity Interactive, Inc. L