X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FMeta%2FAttribute.pm;h=23324b2bfb9c33c264e7b00b8cff725cec3041c1;hb=6361ccf5f1b303625c83d93a3099ce51b5a74c95;hp=5f3b8bb30348162bb2ff3d223fbde29a0a9329e7;hpb=f3c4e20e4056cb645da9fc64f0a248579caa70f3;p=gitmo%2FMoose.git diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm index 5f3b8bb..23324b2 100644 --- a/lib/Moose/Meta/Attribute.pm +++ b/lib/Moose/Meta/Attribute.pm @@ -6,9 +6,10 @@ use warnings; use Scalar::Util 'blessed', 'weaken', 'reftype'; use Carp 'confess'; +use Sub::Name 'subname'; use overload (); -our $VERSION = '0.15'; +our $VERSION = '0.16'; our $AUTHORITY = 'cpan:STEVAN'; use Moose::Meta::Method::Accessor; @@ -75,25 +76,25 @@ sub clone_and_inherit_options { # new type is a subtype if ($options{isa}) { my $type_constraint; - if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) { - $type_constraint = $options{isa}; - } - else { - $type_constraint = Moose::Util::TypeConstraints::find_or_create_type_constraint( - $options{isa} - ); - (defined $type_constraint) - || confess "Could not find the type constraint '" . $options{isa} . "'"; - } - # NOTE: - # check here to see if the new type - # is a subtype of the old one - ($type_constraint->is_subtype_of($self->type_constraint->name)) - || confess "New type constraint setting must be a subtype of inherited one" - # iff we have a type constraint that is ... - if $self->has_type_constraint; - # then we use it :) - $actual_options{type_constraint} = $type_constraint; + if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) { + $type_constraint = $options{isa}; + } + else { + $type_constraint = Moose::Util::TypeConstraints::find_or_create_type_constraint( + $options{isa} + ); + (defined $type_constraint) + || confess "Could not find the type constraint '" . $options{isa} . "'"; + } + # NOTE: + # check here to see if the new type + # is a subtype of the old one + ($type_constraint->is_subtype_of($self->type_constraint->name)) + || confess "New type constraint setting must be a subtype of inherited one" + # iff we have a type constraint that is ... + if $self->has_type_constraint; + # then we use it :) + $actual_options{type_constraint} = $type_constraint; delete $options{isa}; } (scalar keys %options == 0) @@ -103,26 +104,25 @@ sub clone_and_inherit_options { sub _process_options { my ($class, $name, $options) = @_; - + if (exists $options->{is}) { - if ($options->{is} eq 'ro') { - $options->{reader} ||= $name; - (!exists $options->{trigger}) - || confess "Cannot have a trigger on a read-only attribute"; - } - elsif ($options->{is} eq 'rw') { - $options->{accessor} = $name; - ((reftype($options->{trigger}) || '') eq 'CODE') - || confess "Trigger must be a CODE ref" - if exists $options->{trigger}; - } - else { - confess "I do not understand this option (is => " . $options->{is} . ")" - } + if ($options->{is} eq 'ro') { + $options->{reader} ||= $name; + (!exists $options->{trigger}) + || confess "Cannot have a trigger on a read-only attribute"; + } + elsif ($options->{is} eq 'rw') { + $options->{accessor} = $name; + ((reftype($options->{trigger}) || '') eq 'CODE') + || confess "Trigger must be a CODE ref" + if exists $options->{trigger}; + } + else { + confess "I do not understand this option (is => " . $options->{is} . ")" + } } - + if (exists $options->{isa}) { - if (exists $options->{does}) { if (eval { $options->{isa}->can('does') }) { ($options->{isa}->does($options->{does})) @@ -132,65 +132,66 @@ sub _process_options { confess "Cannot have an isa option which cannot ->does()"; } } - + # allow for anon-subtypes here ... if (blessed($options->{isa}) && $options->{isa}->isa('Moose::Meta::TypeConstraint')) { - $options->{type_constraint} = $options->{isa}; - } - else { - $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_type_constraint( - $options->{isa} => { + $options->{type_constraint} = $options->{isa}; + } + else { + $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_type_constraint( + $options->{isa} => { parent => Moose::Util::TypeConstraints::find_type_constraint('Object'), constraint => sub { $_[0]->isa($options->{isa}) } } - ); - } + ); + } } elsif (exists $options->{does}) { # allow for anon-subtypes here ... if (blessed($options->{does}) && $options->{does}->isa('Moose::Meta::TypeConstraint')) { - $options->{type_constraint} = $options->{isa}; - } - else { - $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_type_constraint( - $options->{does} => { + $options->{type_constraint} = $options->{isa}; + } + else { + $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_type_constraint( + $options->{does} => { parent => Moose::Util::TypeConstraints::find_type_constraint('Role'), constraint => sub { $_[0]->does($options->{does}) } } - ); - } + ); + } } - + if (exists $options->{coerce} && $options->{coerce}) { (exists $options->{type_constraint}) || confess "You cannot have coercion without specifying a type constraint"; - confess "You cannot have a weak reference to a coerced value" - if $options->{weak_ref}; + confess "You cannot have a weak reference to a coerced value" + if $options->{weak_ref}; } - + if (exists $options->{auto_deref} && $options->{auto_deref}) { (exists $options->{type_constraint}) || confess "You cannot auto-dereference without specifying a type constraint"; ($options->{type_constraint}->is_a_type_of('ArrayRef') || - $options->{type_constraint}->is_a_type_of('HashRef')) + $options->{type_constraint}->is_a_type_of('HashRef')) || confess "You cannot auto-dereference anything other than a ArrayRef or HashRef"; } - + if (exists $options->{lazy_build} && $options->{lazy_build} == 1) { confess("You can not use lazy_build and default for the same attribute") - if exists $options->{default}; - $options->{lazy} = 1; - $options->{required} = 1; - $options->{builder} ||= "_build_${name}"; - if($name =~ /^_/){ + if exists $options->{default}; + $options->{lazy} = 1; + $options->{required} = 1; + $options->{builder} ||= "_build_${name}"; + if ($name =~ /^_/) { $options->{clearer} ||= "_clear${name}"; $options->{predicate} ||= "_has${name}"; - } else { + } + else { $options->{clearer} ||= "clear_${name}"; $options->{predicate} ||= "has_${name}"; } } - + if (exists $options->{lazy} && $options->{lazy}) { (exists $options->{default} || exists $options->{builder} ) || confess "You cannot have lazy attribute without specifying a default value for it"; @@ -207,7 +208,7 @@ sub initialize_instance_slot { my $value_is_set; if (exists $params->{$init_arg}) { $val = $params->{$init_arg}; - $value_is_set = 1; + $value_is_set = 1; } else { # skip it if it's lazy @@ -221,11 +222,13 @@ sub initialize_instance_slot { if ($self->has_default) { $val = $self->default($instance); $value_is_set = 1; - } elsif ($self->has_builder) { - if(my $builder = $instance->can($self->builder)){ + } + elsif ($self->has_builder) { + if (my $builder = $instance->can($self->builder)){ $val = $instance->$builder; $value_is_set = 1; - } else { + } + else { confess(blessed($instance)." does not support builder method '".$self->builder."' for attribute '" . $self->name . "'"); } } @@ -245,16 +248,14 @@ sub initialize_instance_slot { $type_constraint->name . ") with '" . (defined $val - ? (blessed($val) && overload::Overloaded($val) - ? overload::StrVal($val) - : $val) + ? overload::StrVal($val) : 'undef') . "'"; } $meta_instance->set_slot_value($instance, $self->name, $val); $meta_instance->weaken_slot_value($instance, $self->name) - if ref $val && $self->is_weak_ref; + if ref $val && $self->is_weak_ref; } ## Slot management @@ -281,11 +282,7 @@ sub set_value { . $type_constraint->name . ") with " . (defined($value) - ? ("'" . - (blessed($value) && overload::Overloaded($value) - ? overload::StrVal($value) - : $value) - . "'") + ? ("'" . overload::StrVal($value) . "'") : "undef") if defined($value); } @@ -308,21 +305,28 @@ sub get_value { my ($self, $instance) = @_; if ($self->is_lazy) { - unless ($self->has_value($instance)) { - if ($self->has_default) { - my $default = $self->default($instance); - $self->set_value($instance, $default); - } - if ( $self->has_builder ){ - if(my $builder = $instance->can($self->builder)){ - $self->set_value($instance, $instance->$builder); - } else { - confess(blessed($instance)." does not support builder method '".$self->builder."' for attribute '" . $self->name . "'"); - } - } else { - $self->set_value($instance, undef); + unless ($self->has_value($instance)) { + if ($self->has_default) { + my $default = $self->default($instance); + $self->set_value($instance, $default); + } + if ( $self->has_builder ){ + if (my $builder = $instance->can($self->builder)){ + $self->set_value($instance, $instance->$builder); + } + else { + confess(blessed($instance) + . " does not support builder method '" + . $self->builder + . "' for attribute '" + . $self->name + . "'"); } + } + else { + $self->set_value($instance, undef); } + } } if ($self->should_auto_deref) { @@ -376,6 +380,8 @@ sub install_accessors { my $associated_class = $self->associated_class; foreach my $handle (keys %handles) { my $method_to_call = $handles{$handle}; + my $class_name = $associated_class->name; + my $name = "${class_name}::${handle}"; (!$associated_class->has_method($handle)) || confess "You cannot overwrite a locally defined method ($handle) with a delegation"; @@ -385,20 +391,19 @@ sub install_accessors { # any of these methods, as they will # override the ones in your class, which # is almost certainly not what you want. - next if $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle); + + # FIXME warn when $handle was explicitly specified, but not if the source is a regex or something + #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); if ((reftype($method_to_call) || '') eq 'CODE') { - $associated_class->add_method($handle => $method_to_call); + $associated_class->add_method($handle => subname $name, $method_to_call); } else { - $associated_class->add_method($handle => sub { - # FIXME - # we should check for lack of - # a callable return value from - # the accessor here + $associated_class->add_method($handle => subname $name, sub { my $proxy = (shift)->$accessor(); @_ = ($proxy, @_); - goto &{ $proxy->can($method_to_call) }; + goto &{ $proxy->can($method_to_call) || return }; }); } } @@ -542,7 +547,7 @@ value fails to pass, the set operation dies with a L. Any coercion to convert values is done before checking the type constraint. To check a value against a type constraint before setting it, fetch the -attribute instance using L, +attribute instance using L, fetch the type_constraint from the attribute using L and call L. See L for an example. @@ -671,7 +676,7 @@ Yuval Kogman Enothingmuch@woobling.comE =head1 COPYRIGHT AND LICENSE -Copyright 2006, 2007 by Infinity Interactive, Inc. +Copyright 2006-2008 by Infinity Interactive, Inc. L