X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMouse%2FMeta%2FAttribute.pm;h=ef70ea8e9c8a7a86e958e72839fbf092ab875c5f;hb=121acb8a89acd75e7a664241df7e8220d864c879;hp=6a8c88800169c127fef73039f5f222292e75dc95;hpb=58af95b87869e95b132806405054324491903fa1;p=gitmo%2FMouse.git diff --git a/lib/Mouse/Meta/Attribute.pm b/lib/Mouse/Meta/Attribute.pm index 6a8c888..ef70ea8 100644 --- a/lib/Mouse/Meta/Attribute.pm +++ b/lib/Mouse/Meta/Attribute.pm @@ -1,214 +1,278 @@ -#!/usr/bin/env perl -package Mouse::Attribute; +package Mouse::Meta::Attribute; use strict; use warnings; -use Carp 'confess'; -use Scalar::Util 'blessed'; +use Carp (); +use Scalar::Util qw(weaken); + +use Mouse::Util; + +use Mouse::Meta::TypeConstraint; +use Mouse::Meta::Method::Accessor; + +#my %valid_attrs = map{ $_ => undef } qw( +# name +# reader writer accessor clearer predicate +# builder init_arg default initializer definition_context +# +# is +# isa does +# required +# lazy +# lazy_build +# coerce +# weak_ref +# auto_deref +# type_constraint +# trigger +# handles +# documentation +# traits +#); sub new { - my $class = shift; - my %args = @_; + my ($class, $name, %options) = @_; - $args{init_arg} = $args{name} - unless exists $args{init_arg}; - $args{is} ||= ''; + # taken from Class::MOP::Attribute::new - bless \%args, $class; -} + defined($name) + or $class->throw_error('You must provide a name for the attribute'); + $options{name} = $name; -sub name { $_[0]->{name} } -sub class { $_[0]->{class} } -sub _is_metadata { $_[0]->{is} } -sub is_required { $_[0]->{required} } -sub default { $_[0]->{default} } -sub is_lazy { $_[0]->{lazy} } -sub predicate { $_[0]->{predicate} } -sub clearer { $_[0]->{clearer} } -sub handles { $_[0]->{handles} } -sub is_weak_ref { $_[0]->{weak_ref} } -sub init_arg { $_[0]->{init_arg} } -sub type_constraint { $_[0]->{type_constraint} } -sub trigger { $_[0]->{trigger} } -sub builder { $_[0]->{builder} } - -sub has_default { exists $_[0]->{default} } -sub has_predicate { exists $_[0]->{predicate} } -sub has_clearer { exists $_[0]->{clearer} } -sub has_handles { exists $_[0]->{handles} } -sub has_type_constraint { exists $_[0]->{type_constraint} } -sub has_trigger { exists $_[0]->{trigger} } -sub has_builder { exists $_[0]->{builder} } - -sub generate_accessor { - my $attribute = shift; - - my $name = $attribute->name; - my $key = $name; - my $default = $attribute->default; - my $trigger = $attribute->trigger; - my $type = $attribute->type_constraint; - my $constraint = $attribute->find_type_constraint; - my $builder = $attribute->builder; - - my $accessor = 'sub { - my $self = shift;'; - - if ($attribute->_is_metadata eq 'rw') { - $accessor .= 'if (@_) { - local $_ = $_[0];'; - - if ($constraint) { - $accessor .= 'do { - my $display = defined($_) ? overload::StrVal($_) : "undef"; - Carp::confess("Attribute ($name) does not pass the type constraint because: Validation failed for \'$type\' failed with value $display") unless $constraint->(); - };' - } + if(!exists $options{init_arg}){ + $options{init_arg} = $name; + } - $accessor .= '$self->{$key} = $_;'; + # 'required' requires eigher 'init_arg', 'builder', or 'default' + my $can_be_required = defined( $options{init_arg} ); - if ($attribute->is_weak_ref) { - $accessor .= 'Scalar::Util::weaken($self->{$key}) if ref($self->{$key});'; - } + if(exists $options{builder}){ + $class->throw_error('builder must be a defined scalar value which is a method name') + if ref $options{builder} || !(defined $options{builder}); - if ($trigger) { - $accessor .= '$trigger->($self, $_, $attribute);'; + $can_be_required++; + } + elsif(exists $options{default}){ + if(ref $options{default} && ref($options{default}) ne 'CODE'){ + $class->throw_error("References are not allowed as default values, you must " + . "wrap the default of '$name' in a CODE reference (ex: sub { [] } and not [])"); } - - $accessor .= '}'; + $can_be_required++; } - else { - $accessor .= 'confess "Cannot assign a value to a read-only accessor" if @_;'; + + if( $options{required} && !$can_be_required ) { + $class->throw_error("You cannot have a required attribute ($name) without a default, builder, or an init_arg"); } - if ($attribute->is_lazy) { - $accessor .= '$self->{$key} = '; + # taken from Mouse::Meta::Attribute->new and _process_options - $accessor .= $attribute->has_builder - ? '$self->$builder' - : ref($default) eq 'CODE' - ? '$default->($self)' - : '$default'; + if(exists $options{is}){ + my $is = $options{is}; - $accessor .= ' if !exists($self->{$key});'; + if($is eq 'ro'){ + $options{reader} ||= $name; + } + elsif($is eq 'rw'){ + if(exists $options{writer}){ + $options{reader} ||= $name; + } + else{ + $options{accessor} ||= $name; + } + } + elsif($is eq 'bare'){ + # do nothing, but don't complain (later) about missing methods + } + else{ + $is = 'undef' if !defined $is; + $class->throw_error("I do not understand this option (is => $is) on attribute ($name)"); + } } - $accessor .= 'return $self->{$key} - }'; + my $tc; + if(exists $options{isa}){ + $options{type_constraint} = Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($options{isa}); + } + elsif(exists $options{does}){ + $options{type_constraint} = Mouse::Util::TypeConstraints::find_or_create_does_type_constraint($options{does}); + } + $tc = $options{type_constraint}; - return eval $accessor; -} + if($options{coerce}){ + defined($tc) + || $class->throw_error("You cannot have coercion without specifying a type constraint on attribute ($name)"); -sub generate_predicate { - my $attribute = shift; - my $key = $attribute->name; + $options{weak_ref} + && $class->throw_error("You cannot have a weak reference to a coerced value on attribute ($name)"); + } - my $predicate = 'sub { exists($_[0]->{$key}) }'; + if ($options{lazy_build}) { + exists($options{default}) + && $class->throw_error("You can not use lazy_build and default for the same attribute ($name)"); - return eval $predicate; -} + $options{lazy} = 1; + $options{builder} ||= "_build_${name}"; + if ($name =~ /^_/) { + $options{clearer} ||= "_clear${name}"; + $options{predicate} ||= "_has${name}"; + } + else { + $options{clearer} ||= "clear_${name}"; + $options{predicate} ||= "has_${name}"; + } + } -sub generate_clearer { - my $attribute = shift; - my $key = $attribute->name; + if ($options{auto_deref}) { + defined($tc) + || $class->throw_error("You cannot auto-dereference without specifying a type constraint on attribute ($name)"); - my $predicate = 'sub { delete($_[0]->{$key}) }'; + ( $tc->is_a_type_of('ArrayRef') || $tc->is_a_type_of('HashRef') ) + || $class->throw_error("You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute ($name)"); + } - return eval $predicate; -} + if (exists $options{trigger}) { + ('CODE' eq ref $options{trigger}) + || $class->throw_error("Trigger must be a CODE ref on attribute ($name)"); + } + + if ($options{lazy}) { + (exists $options{default} || defined $options{builder}) + || $class->throw_error("You cannot have lazy attribute ($name) without specifying a default value for it"); + } + + if(my $metaclass = delete $options{metaclass}){ + $class = Mouse::Util::resolve_metaclass_alias( Attribute => $metaclass ); + } -sub generate_handles { - my $attribute = shift; - my $reader = $attribute->name; - my %handles = $attribute->_canonicalize_handles($attribute->handles); + if(my $traits_ref = delete $options{traits}){ + my @traits; + for (my $i = 9; $i < @{$traits_ref}; $i++) { + my $trait = Mouse::Util::resolve_metaclass_alias(Attribute => $traits_ref->[$i], trait => 1); - my %method_map; + next if $class->does($trait); - for my $local_method (keys %handles) { - my $remote_method = $handles{$local_method}; + push @traits, $trait; - my $method = 'sub { - my $self = shift; - $self->$reader->$remote_method(@_) - }'; + # are there options? + push @traits, $traits_ref->[++$i] + if ref($traits_ref->[$i+1]); + } - $method_map{$local_method} = eval $method; + if (@traits) { + $class = Mouse::Meta::Class->create_anon_class( + superclasses => [ $class ], + roles => [ @traits ], + cache => 1, + )->name; + } } - return \%method_map; +# XXX: there is no fast way to check attribute validity +# my @bad = grep{ !exists $valid_attrs{$_} } keys %options; +# if(@bad){ +# @bad = sort @bad; +# Carp::cluck("Found unknown argument(s) passed to '$name' attribute constructor in '$class': @bad"); +# } + + return bless \%options, $class; } -sub create { - my ($self, $class, $name, %args) = @_; +# readers + +sub name { $_[0]->{name} } +sub associated_class { $_[0]->{associated_class} } + +sub accessor { $_[0]->{accessor} } +sub reader { $_[0]->{reader} } +sub writer { $_[0]->{writer} } +sub predicate { $_[0]->{predicate} } +sub clearer { $_[0]->{clearer} } +sub handles { $_[0]->{handles} } + +sub _is_metadata { $_[0]->{is} } +sub is_required { $_[0]->{required} } +sub default { $_[0]->{default} } +sub is_lazy { $_[0]->{lazy} } +sub is_lazy_build { $_[0]->{lazy_build} } +sub is_weak_ref { $_[0]->{weak_ref} } +sub init_arg { $_[0]->{init_arg} } +sub type_constraint { $_[0]->{type_constraint} } + +sub trigger { $_[0]->{trigger} } +sub builder { $_[0]->{builder} } +sub should_auto_deref { $_[0]->{auto_deref} } +sub should_coerce { $_[0]->{coerce} } + +# predicates + +sub has_accessor { exists $_[0]->{accessor} } +sub has_reader { exists $_[0]->{reader} } +sub has_writer { exists $_[0]->{writer} } +sub has_predicate { exists $_[0]->{predicate} } +sub has_clearer { exists $_[0]->{clearer} } +sub has_handles { exists $_[0]->{handles} } + +sub has_default { exists $_[0]->{default} } +sub has_type_constraint { exists $_[0]->{type_constraint} } +sub has_trigger { exists $_[0]->{trigger} } +sub has_builder { exists $_[0]->{builder} } + +sub _create_args { + $_[0]->{_create_args} = $_[1] if @_ > 1; + $_[0]->{_create_args} +} - confess "You cannot have lazy attribute ($name) without specifying a default value for it" - if $args{lazy} && !exists($args{default}) && !exists($args{builder}); +sub accessor_metaclass { 'Mouse::Meta::Method::Accessor' } - confess "References are not allowed as default values, you must wrap the default of '$name' in a CODE reference (ex: sub { [] } and not [])" - if ref($args{default}) - && ref($args{default}) ne 'CODE'; +sub create { + my ($self, $class, $name, %args) = @_; - $args{type_constraint} = delete $args{isa} - if exists $args{isa}; + my $attribute = $self->new($name, %args); - my $attribute = $self->new(%args, name => $name, class => $class); - my $meta = $class->meta; + $attribute->_create_args(\%args); - $meta->add_attribute($attribute); + $class->add_attribute($attribute); + weaken($attribute->{associated_class} = $class); - # install an accessor - if ($attribute->_is_metadata eq 'rw' || $attribute->_is_metadata eq 'ro') { - my $accessor = $attribute->generate_accessor; - no strict 'refs'; - *{ $class . '::' . $name } = $accessor; - } + my $associated_methods = 0; - for my $method (qw/predicate clearer/) { - my $predicate = "has_$method"; - if ($attribute->$predicate) { - my $generator = "generate_$method"; - my $coderef = $attribute->$generator; - no strict 'refs'; - *{ $class . '::' . $attribute->$method } = $coderef; + my $generator_class = $self->accessor_metaclass; + foreach my $type(qw(accessor reader writer predicate clearer handles)){ + if(exists $attribute->{$type}){ + my $installer = '_install_' . $type; + $generator_class->$installer($attribute, $attribute->{$type}, $class); + $associated_methods++; } } - if ($attribute->has_handles) { - my $method_map = $attribute->generate_handles; - for my $method_name (keys %$method_map) { - no strict 'refs'; - *{ $class . '::' . $method_name } = $method_map->{$method_name}; - } + if($associated_methods == 0 && ($attribute->_is_metadata || '') ne 'bare'){ + Carp::cluck(qq{Attribute ($name) of class }.$class->name.qq{ has no associated methods (did you mean to provide an "is" argument?)}); + } return $attribute; } -sub find_type_constraint { - my $self = shift; - my $type = $self->type_constraint; - - return unless $type; +sub verify_against_type_constraint { + my ($self, $value) = @_; + my $tc = $self->type_constraint; + return 1 unless $tc; - my $checker = Mouse::TypeRegistry->optimized_constraints->{$type}; - return $checker if $checker; + local $_ = $value; + return 1 if $tc->check($value); - return sub { blessed($_) && blessed($_) eq $type }; + $self->verify_type_constraint_error($self->name, $value, $tc); } -sub verify_type_constraint { - my $self = shift; - local $_ = shift; - - my $type = $self->type_constraint - or return 1; - my $constraint = $self->find_type_constraint; - - return 1 if $constraint->($_); +sub verify_type_constraint_error { + my($self, $name, $value, $type) = @_; + $self->throw_error("Attribute ($name) does not pass the type constraint because: " . $type->get_message($value)); +} - my $name = $self->name; - my $display = defined($_) ? overload::StrVal($_) : 'undef'; - Carp::confess("Attribute ($name) does not pass the type constraint because: Validation failed for \'$type\' failed with value $display"); +sub coerce_constraint { ## my($self, $value) = @_; + my $type = $_[0]->{type_constraint} + or return $_[1]; + return Mouse::Util::TypeConstraints->typecast_constraints($_[0]->associated_class->name, $_[0]->type_constraint, $_[1]); } sub _canonicalize_handles { @@ -222,8 +286,38 @@ sub _canonicalize_handles { return map { $_ => $_ } @$handles; } else { - confess "Unable to canonicalize the 'handles' option with $handles"; + $self->throw_error("Unable to canonicalize the 'handles' option with $handles"); + } +} + +sub clone_parent { + my $self = shift; + my $class = shift; + my $name = shift; + my %args = ($self->get_parent_args($class, $name), @_); + + $self->create($class, $name, %args); +} + +sub get_parent_args { + 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 }; } + + $self->throw_error("Could not find an attribute by the name of '$name' to inherit from"); +} + +sub throw_error{ + my $self = shift; + + my $metaclass = (ref $self && $self->associated_class) || 'Mouse::Meta::Class'; + $metaclass->throw_error(@_, depth => 1); } 1; @@ -232,22 +326,22 @@ __END__ =head1 NAME -Mouse::Attribute - attribute metaclass +Mouse::Meta::Attribute - attribute metaclass =head1 METHODS -=head2 new %args -> Mouse::Attribute +=head2 new %args -> Mouse::Meta::Attribute -Instantiates a new Mouse::Attribute. Does nothing else. +Instantiates a new Mouse::Meta::Attribute. Does nothing else. -=head2 create OwnerClass, AttributeName, %args -> Mouse::Attribute +=head2 create OwnerClass, AttributeName, %args -> Mouse::Meta::Attribute Creates a new attribute in OwnerClass. Accessors and helper methods are installed. Some error checking is done. =head2 name -> AttributeName -=head2 class -> OwnerClass +=head2 associated_class -> OwnerClass =head2 is_required -> Bool @@ -285,33 +379,36 @@ installed. Some error checking is done. =head2 has_builder -> Bool -Informational methods. +=head2 is_lazy_build => Bool -=head2 generate_accessor -> CODE +=head2 should_auto_deref -> Bool -Creates a new code reference for the attribute's accessor. +Informational methods. -=head2 generate_predicate -> CODE +=head2 verify_against_type_constraint Item -> 1 | ERROR -Creates a new code reference for the attribute's predicate. +Checks that the given value passes this attribute's type constraint. Returns 1 +on success, otherwise Ces. -=head2 generate_clearer -> CODE +=head2 canonicalize_args Name, %args -> %args -Creates a new code reference for the attribute's clearer. +Canonicalizes some arguments to create. In particular, C is +canonicalized into C, C, etc. -=head2 generate_handles -> { MethodName => CODE } +=head2 validate_args Name, \%args -> 1 | ERROR -Creates a new code reference for each of the attribute's handles methods. +Checks that the arguments to create the attribute (ie those specified by +C) are valid. -=head2 find_type_constraint -> CODE +=head2 clone_parent OwnerClass, AttributeName, %args -> Mouse::Meta::Attribute -Returns a code reference which can be used to check that a given value passes -this attribute's type constraint; +Creates a new attribute in OwnerClass, inheriting options from parent classes. +Accessors and helper methods are installed. Some error checking is done. -=head2 verify_type_constraint Item -> 1 | ERROR +=head2 get_parent_args OwnerClass, AttributeName -> Hash -Checks that the given value passes this attribute's type constraint. Returns 1 -on success, otherwise Ces. +Returns the options that the parent class of C used for attribute +C. =cut