X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMouse%2FMeta%2FAttribute.pm;h=21e98e7b40bdb1f02cd8c218b2511baf4b6044e7;hb=85ccd3e9989b341a43e4b5858348098888381c6b;hp=0d25298dbd17f084381a51b48a7d4df49ac07094;hpb=45ea86205954c36cdc0f1472b5edf519459b2b56;p=gitmo%2FMouse.git diff --git a/lib/Mouse/Meta/Attribute.pm b/lib/Mouse/Meta/Attribute.pm index 0d25298..21e98e7 100644 --- a/lib/Mouse/Meta/Attribute.pm +++ b/lib/Mouse/Meta/Attribute.pm @@ -4,34 +4,38 @@ use strict; use warnings; use Carp 'confess'; -use Scalar::Util 'blessed'; +use Mouse::Util qw/blessed weaken/; sub new { my $class = shift; my %args = @_; - $args{init_arg} = $args{name} + my $name = $args{name}; + + $args{init_arg} = $name unless exists $args{init_arg}; + $args{is} ||= ''; bless \%args, $class; } -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 should_auto_deref { $_[0]->{auto_deref} } +sub name { $_[0]->{name} } +sub associated_class { $_[0]->{associated_class} } +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 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 should_auto_deref { $_[0]->{auto_deref} } sub has_default { exists $_[0]->{default} } sub has_predicate { exists $_[0]->{predicate} } @@ -41,76 +45,91 @@ 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} +} + +sub inlined_name { + my $self = shift; + my $name = $self->name; + my $key = "'" . $name . "'"; + return $key; +} + 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 $trigger = $attribute->trigger; - my $accessor = 'sub { - my $self = shift;'; + my $self = '$_[0]'; + my $value = '$_[1]'; + my $key = $attribute->inlined_name; + my $accessor = "sub {\n"; if ($attribute->_is_metadata eq 'rw') { - $accessor .= 'if (@_) { - local $_ = $_[0];'; + $accessor .= 'if (scalar(@_) >= 2) { + '; 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->(); - };' + $accessor .= 'local $_ = ' . $value . '; + unless ($constraint->()) { + 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"); + }' . "\n" } - $accessor .= '$self->{$key} = $_;'; + $accessor .= $self . '->{'.$key.'} = '. $value .';' . "\n"; if ($attribute->is_weak_ref) { - $accessor .= 'Scalar::Util::weaken($self->{$key}) if ref($self->{$key});'; + $accessor .= 'weaken('.$self.'->{'.$key.'}) if ref('.$self.'->{'.$key.'});' . "\n"; } if ($trigger) { - $accessor .= '$trigger->($self, $_, $attribute);'; + $accessor .= '$trigger->('.$self.', '.$value.', $attribute);' . "\n"; } - $accessor .= '}'; + $accessor .= "}\n"; } else { - $accessor .= 'confess "Cannot assign a value to a read-only accessor" if @_;'; + $accessor .= 'confess "Cannot assign a value to a read-only accessor" if scalar(@_) >= 2;' . "\n"; } if ($attribute->is_lazy) { - $accessor .= '$self->{$key} = '; + $accessor .= $self.'->{'.$key.'} = '; $accessor .= $attribute->has_builder - ? '$self->$builder' - : ref($default) eq 'CODE' - ? '$default->($self)' - : '$default'; - - $accessor .= ' if !exists($self->{$key});'; + ? $self.'->$builder' + : ref($default) eq 'CODE' + ? '$default->('.$self.')' + : '$default'; + $accessor .= ' if !exists '.$self.'->{'.$key.'};' . "\n"; } if ($attribute->should_auto_deref) { if ($attribute->type_constraint eq 'ArrayRef') { $accessor .= 'if (wantarray) { - return @{ $self->{$key} || [] }; - }'; + return @{ '.$self.'->{'.$key.'} || [] }; + }' . "\n"; } else { $accessor .= 'if (wantarray) { - return %{ $self->{$key} || {} }; - }'; + return %{ '.$self.'->{'.$key.'} || {} }; + }' . "\n"; } } - $accessor .= 'return $self->{$key}; + $accessor .= 'return '.$self.'->{'.$key.'}; }'; - return eval $accessor; + my $sub = eval $accessor; + confess $@ if $@; + return $sub; } sub generate_predicate { @@ -119,16 +138,20 @@ sub generate_predicate { my $predicate = 'sub { exists($_[0]->{$key}) }'; - return eval $predicate; + my $sub = eval $predicate; + confess $@ if $@; + return $sub; } sub generate_clearer { my $attribute = shift; my $key = $attribute->name; - my $predicate = 'sub { delete($_[0]->{$key}) }'; + my $clearer = 'sub { delete($_[0]->{$key}) }'; - return eval $predicate; + my $sub = eval $clearer; + confess $@ if $@; + return $sub; } sub generate_handles { @@ -147,6 +170,7 @@ sub generate_handles { }'; $method_map{$local_method} = eval $method; + confess $@ if $@; } return \%method_map; @@ -155,34 +179,25 @@ sub generate_handles { sub create { my ($self, $class, $name, %args) = @_; - confess "You cannot have lazy attribute ($name) without specifying a default value for it" - if $args{lazy} && !exists($args{default}) && !exists($args{builder}); - - 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'; - - confess "You cannot auto-dereference without specifying a type constraint on attribute $name" - if $args{auto_deref} && !exists($args{isa}); + $args{name} = $name; + $args{associated_class} = $class; - confess "You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute $name" - if $args{auto_deref} - && $args{isa} ne 'ArrayRef' - && $args{isa} ne 'HashRef'; + %args = $self->canonicalize_args($name, %args); + $self->validate_args($name, \%args); $args{type_constraint} = delete $args{isa} if exists $args{isa}; - my $attribute = $self->new(%args, name => $name, class => $class); - my $meta = $class->meta; + my $attribute = $self->new(%args); - $meta->add_attribute($attribute); + $attribute->_create_args(\%args); + + $class->add_attribute($attribute); # 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; + $class->add_method($name => $accessor); } for my $method (qw/predicate clearer/) { @@ -190,22 +205,80 @@ sub create { if ($attribute->$predicate) { my $generator = "generate_$method"; my $coderef = $attribute->$generator; - no strict 'refs'; - *{ $class . '::' . $attribute->$method } = $coderef; + $class->add_method($attribute->$method => $coderef); } } 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}; + $class->add_method($method_name => $method_map->{$method_name}); } } return $attribute; } +sub canonicalize_args { + my $self = shift; + my $name = shift; + my %args = @_; + + if ($args{lazy_build}) { + $args{lazy} = 1; + $args{required} = 1; + $args{builder} = "_build_${name}" + if !exists($args{builder}); + if ($name =~ /^_/) { + $args{clearer} = "_clear${name}" if !exists($args{clearer}); + $args{predicate} = "_has${name}" if !exists($args{predicate}); + } + else { + $args{clearer} = "clear_${name}" if !exists($args{clearer}); + $args{predicate} = "has_${name}" if !exists($args{predicate}); + } + } + + return %args; +} + +sub validate_args { + my $self = shift; + my $name = shift; + my $args = shift; + + confess "You can not use lazy_build and default for the same attribute ($name)" + if $args->{lazy_build} && exists $args->{default}; + + confess "You cannot have lazy attribute ($name) without specifying a default value for it" + if $args->{lazy} + && !exists($args->{default}) + && !exists($args->{builder}); + + 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'; + + confess "You cannot auto-dereference without specifying a type constraint on attribute ($name)" + if $args->{auto_deref} && !exists($args->{isa}); + + confess "You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute ($name)" + if $args->{auto_deref} + && $args->{isa} ne 'ArrayRef' + && $args->{isa} ne 'HashRef'; + + if ($args->{trigger}) { + if (ref($args->{trigger}) eq 'HASH') { + Carp::carp "HASH-based form of trigger has been removed. Only the coderef form of triggers are now supported."; + } + + confess "Trigger must be a CODE ref on attribute ($name)" + if ref($args->{trigger}) ne 'CODE'; + } + + return 1; +} + sub find_type_constraint { my $self = shift; my $type = $self->type_constraint; @@ -248,6 +321,29 @@ sub _canonicalize_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 }; + } + + confess "Could not find an attribute by the name of '$name' to inherit from"; +} + 1; __END__ @@ -269,7 +365,7 @@ installed. Some error checking is done. =head2 name -> AttributeName -=head2 class -> OwnerClass +=head2 associated_class -> OwnerClass =head2 is_required -> Bool @@ -307,6 +403,10 @@ installed. Some error checking is done. =head2 has_builder -> Bool +=head2 is_lazy_build => Bool + +=head2 should_auto_deref -> Bool + Informational methods. =head2 generate_accessor -> CODE @@ -335,5 +435,25 @@ this attribute's type constraint; Checks that the given value passes this attribute's type constraint. Returns 1 on success, otherwise Ces. +=head2 canonicalize_args Name, %args -> %args + +Canonicalizes some arguments to create. In particular, C is +canonicalized into C, C, etc. + +=head2 validate_args Name, \%args -> 1 | ERROR + +Checks that the arguments to create the attribute (ie those specified by +C) are valid. + +=head2 clone_parent OwnerClass, AttributeName, %args -> Mouse::Meta::Attribute + +Creates a new attribute in OwnerClass, inheriting options from parent classes. +Accessors and helper methods are installed. Some error checking is done. + +=head2 get_parent_args OwnerClass, AttributeName -> Hash + +Returns the options that the parent class of C used for attribute +C. + =cut