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=54fc2b57bd4e6e8e2596f366f7ae2e0c939f4970;hp=a9345af208b856a36d90b1cd6d4d78d1bc24642c;hb=HEAD;hpb=c2168931940aa681120ba25c60658fe33c42cc1d diff --git a/lib/Mouse/Meta/Attribute.pm b/lib/Mouse/Meta/Attribute.pm index a9345af..54fc2b5 100644 --- a/lib/Mouse/Meta/Attribute.pm +++ b/lib/Mouse/Meta/Attribute.pm @@ -16,6 +16,7 @@ my %valid_options = map { $_ => undef } ( 'does', 'handles', 'init_arg', + 'insertion_order', 'is', 'isa', 'lazy', @@ -33,11 +34,11 @@ my %valid_options = map { $_ => undef } ( # internally used 'associated_class', 'associated_methods', + '__METACLASS__', # Moose defines, but Mouse doesn't #'definition_context', #'initializer', - #'insertion_order', # special case for AttributeHelpers 'provides', @@ -52,11 +53,6 @@ sub new { my $args = $class->Mouse::Object::BUILDARGS(@_); - # XXX: for backward compatibility (with method modifiers) - if($class->can('canonicalize_args') != \&canonicalize_args){ - %{$args} = $class->canonicalize_args($name, %{$args}); - } - $class->_process_options($name, $args); $args->{name} = $name; @@ -84,21 +80,28 @@ sub new { } my $self = bless $args, $class; - - # extra attributes if($class ne __PACKAGE__){ $class->meta->_initialize_object($self, $args); } - return $self; } -sub has_read_method { $_[0]->has_reader || $_[0]->has_accessor } -sub has_write_method { $_[0]->has_writer || $_[0]->has_accessor } +sub has_read_method { $_[0]->has_reader || $_[0]->has_accessor } +sub has_write_method { $_[0]->has_writer || $_[0]->has_accessor } + +sub get_read_method { $_[0]->reader || $_[0]->accessor } +sub get_write_method { $_[0]->writer || $_[0]->accessor } -sub _create_args { # DEPRECATED - $_[0]->{_create_args} = $_[1] if @_ > 1; - $_[0]->{_create_args} +sub get_read_method_ref{ + my($self) = @_; + return $self->{_mouse_cache_read_method_ref} + ||= $self->_get_accessor_method_ref('get_read_method', '_generate_reader'); +} + +sub get_write_method_ref{ + my($self) = @_; + return $self->{_mouse_cache_write_method_ref} + ||= $self->_get_accessor_method_ref('get_write_method', '_generate_writer'); } sub interpolate_class{ @@ -135,40 +138,6 @@ sub interpolate_class{ return( $class, @traits ); } -sub canonicalize_args{ # DEPRECATED - my ($self, $name, %args) = @_; - - Carp::cluck("$self->canonicalize_args has been deprecated." - . "Use \$self->_process_options instead."); - - return %args; -} - -sub create { # DEPRECATED - my ($self, $class, $name, %args) = @_; - - Carp::cluck("$self->create has been deprecated." - . "Use \$meta->add_attribute and \$attr->install_accessors instead."); - - # noop - return $self; -} - -sub _coerce_and_verify { - my($self, $value, $instance) = @_; - - my $type_constraint = $self->{type_constraint}; - return $value if !defined $type_constraint; - - if ($self->should_coerce && $type_constraint->has_coercion) { - $value = $type_constraint->coerce($value); - } - - $self->verify_against_type_constraint($value); - - return $value; -} - sub verify_against_type_constraint { my ($self, $value) = @_; @@ -189,64 +158,45 @@ sub _throw_type_constraint_error { ); } +sub illegal_options_for_inheritance { + return qw(reader writer accessor clearer predicate); +} + sub clone_and_inherit_options{ my $self = shift; my $args = $self->Mouse::Object::BUILDARGS(@_); - my($attribute_class, @traits) = ref($self)->interpolate_class($args); + foreach my $illegal($self->illegal_options_for_inheritance) { + if(exists $args->{$illegal} and exists $self->{$illegal}) { + $self->throw_error("Illegal inherited option: $illegal"); + } + } - $args->{traits} = \@traits if @traits; - # do not inherit the 'handles' attribute foreach my $name(keys %{$self}){ - if(!exists $args->{$name} && $name ne 'handles'){ - $args->{$name} = $self->{$name}; + if(!exists $args->{$name}){ + $args->{$name} = $self->{$name}; # inherit from self } } + my($attribute_class, @traits) = ref($self)->interpolate_class($args); + $args->{traits} = \@traits if @traits; + # remove temporary caches foreach my $attr(keys %{$args}){ - if($attr =~ /\A _/xms){ + if($attr =~ /\A _mouse_cache_/xms){ delete $args->{$attr}; } } - return $attribute_class->new($self->name, $args); -} - -sub clone_parent { # DEPRECATED - my $self = shift; - my $class = shift; - my $name = shift; - my %args = ($self->get_parent_args($class, $name), @_); - - Carp::cluck("$self->clone_parent has been deprecated." - . "Use \$meta->add_attribute and \$attr->install_accessors instead."); - - $self->clone_and_inherited_args($class, $name, %args); -} - -sub get_parent_args { # DEPRECATED - my $self = shift; - my $class = shift; - my $name = shift; - - for my $super ($class->linearized_isa) { - my $super_attr = $super->can("meta") && $super->meta->get_attribute($name) - or next; - return %{ $super_attr->_create_args }; + # remove default if lazy_build => 1 + if($args->{lazy_build}) { + delete $args->{default}; } - $self->throw_error("Could not find an attribute by the name of '$name' to inherit from"); + return $attribute_class->new($self->name, $args); } -sub get_read_method { - return $_[0]->reader || $_[0]->accessor -} -sub get_write_method { - return $_[0]->writer || $_[0]->accessor -} - sub _get_accessor_method_ref { my($self, $type, $generator) = @_; @@ -262,16 +212,6 @@ sub _get_accessor_method_ref { } } -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'); -} - sub set_value { my($self, $object, $value) = @_; return $self->get_write_method_ref()->($object, $value); @@ -284,7 +224,7 @@ sub get_value { sub has_value { my($self, $object) = @_; - my $accessor_ref = $self->{_predicate_ref} + my $accessor_ref = $self->{_mouse_cache_predicate_ref} ||= $self->_get_accessor_method_ref('predicate', '_generate_predicate'); return $accessor_ref->($object); @@ -292,15 +232,15 @@ sub has_value { sub clear_value { my($self, $object) = @_; - my $accessor_ref = $self->{_crealer_ref} + my $accessor_ref = $self->{_mouse_cache_crealer_ref} ||= $self->_get_accessor_method_ref('clearer', '_generate_clearer'); return $accessor_ref->($object); } - sub associate_method{ - my ($attribute, $method_name) = @_; + #my($attribute, $method_name) = @_; + my($attribute) = @_; $attribute->{associated_methods}++; return; } @@ -315,16 +255,28 @@ sub install_accessors{ if(exists $attribute->{$type}){ my $generator = '_generate_' . $type; my $code = $accessor_class->$generator($attribute, $metaclass); - $metaclass->add_method($attribute->{$type} => $code); - $attribute->associate_method($attribute->{$type}); + my $name = $attribute->{$type}; +# TODO: do something for compatibility +# if( $metaclass->name->can($name) ) { +# my $t = $metaclass->has_method($name) ? 'method' : 'function'; +# Carp::cluck("You are overwriting a locally defined $t" +# . " ($name) with an accessor"); +# } + $metaclass->add_method($name => $code); + $attribute->associate_method($name); } } # install delegation if(exists $attribute->{handles}){ - my %handles = $attribute->_canonicalize_handles($attribute->{handles}); - + my %handles = $attribute->_canonicalize_handles(); while(my($handle, $method_to_call) = each %handles){ + next if Mouse::Object->can($handle); + + if($metaclass->has_method($handle)) { + $attribute->throw_error("You cannot overwrite a locally defined method ($handle) with a delegation"); + } + $metaclass->add_method($handle => $attribute->_make_delegation_method( $handle, $method_to_call)); @@ -333,59 +285,61 @@ sub install_accessors{ } } - if($attribute->can('create') != \&create){ - # backword compatibility - $attribute->create($metaclass, $attribute->name, %{$attribute}); - } - return; } -sub delegation_metaclass() { 'Mouse::Meta::Method::Delegation' } +sub delegation_metaclass() { ## no critic + 'Mouse::Meta::Method::Delegation' +} sub _canonicalize_handles { - my($self, $handles) = @_; + my($self) = @_; + my $handles = $self->{handles}; - if (ref($handles) eq 'HASH') { + my $handle_type = ref $handles; + if ($handle_type eq 'HASH') { return %$handles; } - elsif (ref($handles) eq 'ARRAY') { + elsif ($handle_type eq 'ARRAY') { return map { $_ => $_ } @$handles; } - elsif ( ref($handles) eq 'CODE' ) { - my $class_or_role = ( $self->{isa} || $self->{does} ) - || $self->throw_error( "Cannot find delegate metaclass for attribute " . $self->name ); - return $handles->( $self, Mouse::Meta::Class->initialize("$class_or_role")); - } - 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 + elsif ($handle_type eq 'Regexp') { + my $meta = $self->_find_delegate_metaclass(); return map { $_ => $_ } - grep { !Mouse::Object->can($_) && $_ =~ $handles } + grep { /$handles/ } Mouse::Util::is_a_metarole($meta) ? $meta->get_method_list : $meta->get_all_method_names; } + elsif ($handle_type eq 'CODE') { + return $handles->( $self, $self->_find_delegate_metaclass() ); + } else { $self->throw_error("Unable to canonicalize the 'handles' option with $handles"); } } +sub _find_delegate_metaclass { + my($self) = @_; + my $meta; + if($self->{isa}) { + $meta = Mouse::Meta::Class->initialize("$self->{isa}"); + } + elsif($self->{does}) { + $meta = Mouse::Util::get_metaclass_by_name("$self->{does}"); + } + defined($meta) or $self->throw_error( + "Cannot find delegate metaclass for attribute " . $self->name); + return $meta; +} + + sub _make_delegation_method { my($self, $handle, $method_to_call) = @_; return Mouse::Util::load_class($self->delegation_metaclass) ->_generate_delegation($self, $handle, $method_to_call); } -sub throw_error{ - my $self = shift; - - my $metaclass = (ref $self && $self->associated_class) || 'Mouse::Meta::Class'; - $metaclass->throw_error(@_, depth => 1); -} - 1; __END__ @@ -395,7 +349,12 @@ Mouse::Meta::Attribute - The Mouse attribute metaclass =head1 VERSION -This document describes Mouse version 0.50_04 +This document describes Mouse version 0.95 + +=head1 DESCRIPTION + +This is a meta object protocol for Mouse attributes, +which is a subset of Moose::Meta::Attribute. =head1 METHODS