X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=blobdiff_plain;f=lib%2FMouse%2FMeta%2FAttribute.pm;h=98dd81b1054f20c419295112de6f4c8c72fde3c6;hp=c5482aa0425eef92d7a1c35d6498ceb4b7470687;hb=cbb8105898bb0faa7eee06ef890d2ec0c131dff7;hpb=b06ce1f502945c13a52c503f1a651fe92c91c773 diff --git a/lib/Mouse/Meta/Attribute.pm b/lib/Mouse/Meta/Attribute.pm index c5482aa..98dd81b 100644 --- a/lib/Mouse/Meta/Attribute.pm +++ b/lib/Mouse/Meta/Attribute.pm @@ -4,13 +4,10 @@ use Mouse::Util qw(:meta); # enables strict and warnings use Carp (); use Mouse::Meta::TypeConstraint; -use Mouse::Meta::Method::Accessor; - sub _process_options{ my($class, $name, $args) = @_; - # XXX: for backward compatibility (with method modifiers) if($class->can('canonicalize_args') != \&canonicalize_args){ %{$args} = $class->canonicalize_args($name, %{$args}); @@ -203,7 +200,7 @@ sub canonicalize_args{ # DEPRECATED Carp::cluck("$self->canonicalize_args has been deprecated." . "Use \$self->_process_options instead.") - if _MOUSE_VERBOSE; + if Mouse::Util::_MOUSE_VERBOSE; return %args; } @@ -213,7 +210,7 @@ sub create { # DEPRECATED Carp::cluck("$self->create has been deprecated." . "Use \$meta->add_attribute and \$attr->install_accessors instead.") - if _MOUSE_VERBOSE; + if Mouse::Util::_MOUSE_VERBOSE; # noop return $self; @@ -265,7 +262,13 @@ sub clone_and_inherit_options{ my($attribute_class, @traits) = ref($self)->interpolate_class(\%args); $args{traits} = \@traits if @traits; - return $attribute_class->new($self->name, %{$self}, %args); + # do not inherit the 'handles' attribute + foreach my $name(keys %{$self}){ + if(!exists $args{$name} && $name ne 'handles'){ + $args{$name} = $self->{$name}; + } + } + return $attribute_class->new($self->name, %args); } sub clone_parent { # DEPRECATED @@ -276,7 +279,7 @@ sub clone_parent { # DEPRECATED Carp::cluck("$self->clone_parent has been deprecated." . "Use \$meta->add_attribute and \$attr->install_accessors instead.") - if _MOUSE_VERBOSE; + if Mouse::Util::_MOUSE_VERBOSE; $self->clone_and_inherited_args($class, $name, %args); } @@ -297,71 +300,66 @@ sub get_parent_args { # DEPRECATED sub get_read_method { - $_[0]->reader || $_[0]->accessor + return $_[0]->reader || $_[0]->accessor } sub get_write_method { - $_[0]->writer || $_[0]->accessor + return $_[0]->writer || $_[0]->accessor } -sub get_read_method_ref{ - my($self) = @_; +sub _get_accessor_method_ref { + my($self, $type, $generator) = @_; - $self->{_read_method_ref} ||= do{ - my $metaclass = $self->associated_class - or $self->throw_error('No asocciated class for ' . $self->name); + my $metaclass = $self->associated_class + || $self->throw_error('No asocciated class for ' . $self->name); - my $reader = $self->{reader} || $self->{accessor}; - if($reader){ - $metaclass->name->can($reader); - } - else{ - $self->accessor_metaclass->_generate_reader($self, $metaclass); - } - }; + my $accessor = $self->$type(); + if($accessor){ + return $metaclass->get_method_body($accessor); + } + else{ + return $self->accessor_metaclass->$generator($self, $metaclass); + } +} + +sub get_read_method_ref{ + my($self) = @_; + return $self->{_read_method_ref} ||= $self->_get_accessor_method_ref('get_read_method', '_generate_reader'); } sub get_write_method_ref{ my($self) = @_; + return $self->{_write_method_ref} ||= $self->_get_accessor_method_ref('get_write_method', '_generate_writer'); +} - $self->{_write_method_ref} ||= do{ - my $metaclass = $self->associated_class - or $self->throw_error('No asocciated class for ' . $self->name); +sub set_value { + my($self, $object, $value) = @_; + return $self->get_write_method_ref()->($object, $value); +} - my $reader = $self->{writer} || $self->{accessor}; - if($reader){ - $metaclass->name->can($reader); - } - else{ - $self->accessor_metaclass->_generate_writer($self, $metaclass); - } - }; +sub get_value { + my($self, $object) = @_; + return $self->get_read_method_ref()->($object); } -sub _canonicalize_handles { - my($self, $handles) = @_; +sub has_value { + my($self, $object) = @_; + my $accessor_ref = $self->{_predicate_ref} + ||= $self->_get_accessor_method_ref('predicate', '_generate_predicate'); - if (ref($handles) eq 'HASH') { - return %$handles; - } - elsif (ref($handles) eq 'ARRAY') { - return map { $_ => $_ } @$handles; - } - elsif (ref($handles) eq 'Regexp') { - my $class_or_role = ($self->{isa} || $self->{does}) - || $self->throw_error("Cannot delegate methods based on a Regexp without a type constraint (isa)"); + return $accessor_ref->($object); +} - my $meta = Mouse::Meta::Class->initialize("$class_or_role"); # "" for stringify - return map { $_ => $_ } - grep { $_ ne 'meta' && !Mouse::Object->can($_) && $_ =~ $handles } - $meta->isa('Mouse::Meta::Class') ? $meta->get_all_method_names : $meta->get_method_list; - } - else { - $self->throw_error("Unable to canonicalize the 'handles' option with $handles"); - } +sub clear_value { + my($self, $object) = @_; + my $accessor_ref = $self->{_crealer_ref} + ||= $self->_get_accessor_method_ref('clearer', '_generate_clearer'); + + return $accessor_ref->($object); } + sub associate_method{ - my ($attribute, $method) = @_; + my ($attribute, $method_name) = @_; $attribute->{associated_methods}++; return; } @@ -377,25 +375,23 @@ sub install_accessors{ my $generator = '_generate_' . $type; my $code = $accessor_class->$generator($attribute, $metaclass); $metaclass->add_method($attribute->{$type} => $code); - $attribute->associate_method($code); + $attribute->associate_method($attribute->{$type}); } } # install delegation if(exists $attribute->{handles}){ my %handles = $attribute->_canonicalize_handles($attribute->{handles}); - my $reader = $attribute->get_read_method_ref; - while(my($handle_name, $method_to_call) = each %handles){ - my $code = $accessor_class->_generate_delegation($attribute, $metaclass, - $reader, $handle_name, $method_to_call); + while(my($handle, $method_to_call) = each %handles){ + $metaclass->add_method($handle => + $attribute->_make_delegation_method( + $handle, $method_to_call)); - $metaclass->add_method($handle_name => $code); - $attribute->associate_method($code); + $attribute->associate_method($handle); } } - if($attribute->can('create') != \&create){ # backword compatibility $attribute->create($metaclass, $attribute->name, %{$attribute}); @@ -404,6 +400,41 @@ sub install_accessors{ return; } +sub delegation_metaclass() { 'Mouse::Meta::Method::Delegation' } + +sub _canonicalize_handles { + my($self, $handles) = @_; + + if (ref($handles) eq 'HASH') { + return %$handles; + } + elsif (ref($handles) eq 'ARRAY') { + return map { $_ => $_ } @$handles; + } + elsif (ref($handles) eq 'Regexp') { + my $class_or_role = ($self->{isa} || $self->{does}) + || $self->throw_error("Cannot delegate methods based on a Regexp without a type constraint (isa)"); + + my $meta = Mouse::Meta::Class->initialize("$class_or_role"); # "" for stringify + return map { $_ => $_ } + grep { !Mouse::Object->can($_) && $_ =~ $handles } + Mouse::Util::is_a_metarole($meta) + ? $meta->get_method_list + : $meta->get_all_method_names; + } + else { + $self->throw_error("Unable to canonicalize the 'handles' option with $handles"); + } +} + +sub _make_delegation_method { + my($self, $handle, $method_to_call) = @_; + my $delegator = $self->delegation_metaclass; + Mouse::Util::load_class($delegator); + + return $delegator->_generate_delegation($self, $handle, $method_to_call); +} + sub throw_error{ my $self = shift; @@ -412,7 +443,6 @@ sub throw_error{ } 1; - __END__ =head1 NAME @@ -421,7 +451,7 @@ Mouse::Meta::Attribute - The Mouse attribute metaclass =head1 VERSION -This document describes Mouse version 0.40_01 +This document describes Mouse version 0.44 =head1 METHODS @@ -529,12 +559,12 @@ is equivalent to this: =back -=head2 C<< associate_method(Method) >> +=head2 C<< associate_method(MethodName) >> Associates a method with the attribute. Typically, this is called internally when an attribute generates its accessors. -Currently the argument I is ignored in Mouse. +Currently the argument I is ignored in Mouse. =head2 C<< verify_against_type_constraint(Item) -> TRUE | ERROR >>