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=f16d2f797abbfe3303518272068c4d494a12bafa;hpb=a05f85c1308adbbb4b60b1db95103ee2e279e1ea;p=gitmo%2FMoose.git diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm index f16d2f7..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.57'; +our $VERSION = '0.66'; our $AUTHORITY = 'cpan:STEVAN'; use Moose::Meta::Method::Accessor; @@ -61,7 +61,7 @@ sub does { Moose::Util::resolve_metatrait_alias(Attribute => $role_name) }; return 0 if !defined($name); # failed to load class - return Moose::Object::does($self, $name); + return $self->Moose::Object::does($name); } sub throw_error { @@ -70,7 +70,8 @@ sub throw_error { unshift @_, "message" if @_ % 2 == 1; unshift @_, attr => $self if ref $self; unshift @_, $class; - goto $class->can("throw_error"); # to avoid incrementing depth by 1 + my $handler = $class->can("throw_error"); # to avoid incrementing depth by 1 + goto $handler; } sub new { @@ -107,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 ], @@ -131,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 } @@ -397,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); @@ -453,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); }; @@ -521,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) - || c$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); } @@ -566,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; @@ -576,8 +587,6 @@ sub install_delegation { # to delagate to, see that method for details my %handles = $self->_canonicalize_handles; - # find the accessor method for this attribute - my $accessor = $self->_get_delegate_accessor; # install the delegation ... my $associated_class = $self->associated_class; @@ -599,24 +608,23 @@ sub install_delegation { #cluck("Not delegating method '$handle' because it is a core method") and next if $class_name->isa("Moose::Object") and $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle); - my $method = $self->_make_delegation_method($accessor, $handle, $method_to_call); + my $method = $self->_make_delegation_method($handle, $method_to_call); $self->associated_class->add_method($method->name, $method); } } -# private methods to help delegation ... - -sub _get_delegate_accessor { +sub remove_delegation { my $self = shift; - # find the accessor method for this attribute - my $accessor = $self->get_read_method_ref; - # then unpack it if we need too ... - $accessor = $accessor->body if blessed $accessor; - # return the accessor - return $accessor; + 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 { my $self = shift; my $handles = $self->handles; @@ -629,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; } @@ -641,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 => $@); @@ -648,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 @@ -694,48 +705,39 @@ sub _get_delegate_method_list { } } +sub delegation_metaclass { 'Moose::Meta::Method::Delegation' } + sub _make_delegation_method { - my ( $self, $accessor, $handle_name, $method_to_call ) = @_; + my ( $self, $handle_name, $method_to_call ) = @_; my $method_body; - if ( 'CODE' eq ref($method_to_call) ) { - $method_body = $method_to_call; - } - else { + $method_body = $method_to_call + if 'CODE' eq ref($method_to_call); - # NOTE: - # we used to do a goto here, but the - # goto didn't handle failure correctly - # (it just returned nothing), so I took - # that out. However, the more I thought - # about it, the less I liked it doing - # the goto, and I prefered the act of - # delegation being actually represented - # in the stack trace. - # - SL - $method_body = sub { - my $instance = shift; - my $proxy = $instance->$accessor(); - ( defined $proxy ) - || $self->throw_error( - "Cannot delegate $handle_name to $method_to_call because " - . "the value of " - . $self->name - . " is not defined", method_name => $method_to_call, - object => $instance ); - $proxy->$method_to_call(@_); - }; - } - - return Moose::Meta::Method::Delegation->new( - name => $handle_name, - package_name => $self->associated_class->name, - attribute => $self, - body => $method_body, + return $self->delegation_metaclass->new( + name => $handle_name, + package_name => $self->associated_class->name, + attribute => $self, + delegate_to_method => $method_to_call, ); } +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' } @@ -779,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 @@ -847,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. @@ -955,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