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=49840b3f1a9682970575e40163ca74c51680dd57;hp=4c248501b1835ca425f0adf52174db5a30231438;hb=bc69ee88207ce5c53f5c02dbd44cfabfbe6bae70;hpb=926290ac173b77f0ff0027dcbd95277c9cc2be54 diff --git a/lib/Mouse/Meta/Attribute.pm b/lib/Mouse/Meta/Attribute.pm index 4c24850..49840b3 100644 --- a/lib/Mouse/Meta/Attribute.pm +++ b/lib/Mouse/Meta/Attribute.pm @@ -1,14 +1,12 @@ package Mouse::Meta::Attribute; -use strict; -use warnings; +use Mouse::Util qw(:meta); # enables strict and warnings use Carp (); -use Mouse::Util qw(:meta); - use Mouse::Meta::TypeConstraint; use Mouse::Meta::Method::Accessor; + sub _process_options{ my($class, $name, $args) = @_; @@ -185,9 +183,6 @@ sub builder { $_[0]->{builder} } sub should_auto_deref { $_[0]->{auto_deref} } sub should_coerce { $_[0]->{coerce} } -sub get_read_method { $_[0]->{reader} || $_[0]->{accessor} } -sub get_write_method { $_[0]->{writer} || $_[0]->{accessor} } - # predicates sub has_accessor { exists $_[0]->{accessor} } @@ -205,13 +200,13 @@ sub has_builder { exists $_[0]->{builder} } sub has_read_method { exists $_[0]->{reader} || exists $_[0]->{accessor} } sub has_write_method { exists $_[0]->{writer} || exists $_[0]->{accessor} } -sub _create_args { +sub _create_args { # DEPRECATED $_[0]->{_create_args} = $_[1] if @_ > 1; $_[0]->{_create_args} } sub interpolate_class{ - my($class, $name, $args) = @_; + my($class, $args) = @_; if(my $metaclass = delete $args->{metaclass}){ $class = Mouse::Util::resolve_metaclass_alias( Attribute => $metaclass ); @@ -244,7 +239,7 @@ sub interpolate_class{ return( $class, @traits ); } -sub canonicalize_args{ +sub canonicalize_args{ # DEPRECATED my ($self, $name, %args) = @_; Carp::cluck("$self->canonicalize_args has been deprecated." @@ -298,7 +293,7 @@ sub verify_type_constraint_error { $self->throw_error("Attribute ($name) does not pass the type constraint because: " . $type->get_message($value)); } -sub coerce_constraint { ## my($self, $value) = @_; +sub coerce_constraint { # DEPRECATED my $type = $_[0]->{type_constraint} or return $_[1]; @@ -307,29 +302,16 @@ sub coerce_constraint { ## my($self, $value) = @_; return Mouse::Util::TypeConstraints->typecast_constraints($_[0]->associated_class->name, $type, $_[1]); } -sub _canonicalize_handles { - my $self = shift; - my $handles = shift; - - if (ref($handles) eq 'HASH') { - return %$handles; - } - elsif (ref($handles) eq 'ARRAY') { - return map { $_ => $_ } @$handles; - } - else { - $self->throw_error("Unable to canonicalize the 'handles' option with $handles"); - } -} - sub clone_and_inherit_options{ - my $self = shift; - my $name = shift; + my($self, %args) = @_; + + my($attribute_class, @traits) = ref($self)->interpolate_class(\%args); - return ref($self)->new($name, %{$self}, (@_ == 1) ? %{$_[0]} : @_); + $args{traits} = \@traits if @traits; + return $attribute_class->new($self->name, %{$self}, %args); } -sub clone_parent { +sub clone_parent { # DEPRECATED my $self = shift; my $class = shift; my $name = shift; @@ -342,7 +324,7 @@ sub clone_parent { $self->clone_and_inherited_args($class, $name, %args); } -sub get_parent_args { +sub get_parent_args { # DEPRECATED my $self = shift; my $class = shift; my $name = shift; @@ -356,27 +338,101 @@ sub get_parent_args { $self->throw_error("Could not find an attribute by the name of '$name' to inherit from"); } + +sub get_read_method { # DEPRECATED + $_[0]->{reader} || $_[0]->{accessor} +} +sub get_write_method { # DEPRECATED + $_[0]->{writer} || $_[0]->{accessor} +} + +sub get_read_method_ref{ + my($self) = @_; + + $self->{_read_method_ref} ||= do{ + my $metaclass = $self->associated_class + or $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); + } + }; +} + +sub get_write_method_ref{ + my($self) = @_; + + $self->{_write_method_ref} ||= do{ + my $metaclass = $self->associated_class + or $self->throw_error('No asocciated class for ' . $self->name); + + my $reader = $self->{writer} || $self->{accessor}; + if($reader){ + $metaclass->name->can($reader); + } + else{ + $self->accessor_metaclass->_generate_writer($self, $metaclass); + } + }; +} + +sub _canonicalize_handles { + my($self, $handles) = @_; + + if (ref($handles) eq 'HASH') { + return %$handles; + } + elsif (ref($handles) eq 'ARRAY') { + return map { $_ => $_ } @$handles; + } + else { + $self->throw_error("Unable to canonicalize the 'handles' option with $handles"); + } +} + + sub associate_method{ my ($attribute, $method) = @_; $attribute->{associated_methods}++; return; } +sub accessor_metaclass(){ 'Mouse::Meta::Method::Accessor' } + sub install_accessors{ my($attribute) = @_; - my $metaclass = $attribute->{associated_class}; + my $metaclass = $attribute->{associated_class}; + my $accessor_class = $attribute->accessor_metaclass; - foreach my $type(qw(accessor reader writer predicate clearer handles)){ + foreach my $type(qw(accessor reader writer predicate clearer)){ if(exists $attribute->{$type}){ - my $installer = '_install_' . $type; + my $generator = '_generate_' . $type; + my $code = $accessor_class->$generator($attribute, $metaclass); + $metaclass->add_method($attribute->{$type} => $code); + $attribute->associate_method($code); + } + } - Mouse::Meta::Method::Accessor->$installer($attribute, $attribute->{$type}, $metaclass); + # install delegation + if(exists $attribute->{handles}){ + my %handles = $attribute->_canonicalize_handles($attribute->{handles}); + my $reader = $attribute->get_read_method_ref; - $attribute->{associated_methods}++; + while(my($handle_name, $method_to_call) = each %handles){ + my $code = $accessor_class->_generate_delegation($attribute, $metaclass, + $reader, $handle_name, $method_to_call); + + $metaclass->add_method($handle_name => $code); + $attribute->associate_method($code); } } + if($attribute->can('create') != \&create){ # backword compatibility $attribute->create($metaclass, $attribute->name, %{$attribute}); @@ -523,6 +579,15 @@ on success, otherwise Ces. Creates a new attribute in the owner class, inheriting options from parent classes. Accessors and helper methods are installed. Some error checking is done. +=head2 C<< get_read_method_ref >> + +=head2 C<< get_write_method_ref >> + +Returns the subroutine reference of a method suitable for reading or +writing the attribute's value in the associated class. These methods +always return a subroutine reference, regardless of whether or not the +attribute is read- or write-only. + =head1 SEE ALSO L