X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMouse%2FMeta%2FAttribute.pm;h=1b214469fe0e33604664e06f38bcfdf209889b5a;hb=45f2e6a79a018ba03e0103272ab2830ee2efa783;hp=3deea32240d6dfd85422c172a603bdd8186468ba;hpb=724c77c0fd7afe685c69dc1abcfc8b1a79eefae3;p=gitmo%2FMouse.git diff --git a/lib/Mouse/Meta/Attribute.pm b/lib/Mouse/Meta/Attribute.pm index 3deea32..1b21446 100644 --- a/lib/Mouse/Meta/Attribute.pm +++ b/lib/Mouse/Meta/Attribute.pm @@ -2,9 +2,10 @@ package Mouse::Meta::Attribute; use strict; use warnings; +require overload; use Carp 'confess'; -use Scalar::Util qw/blessed weaken/; +require Mouse::Util; sub new { my $class = shift; @@ -36,6 +37,7 @@ 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]->{should_coerce} } sub has_default { exists $_[0]->{default} } sub has_predicate { exists $_[0]->{predicate} } @@ -50,113 +52,119 @@ sub _create_args { $_[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 $type = $attribute->type_constraint; - my $constraint = $attribute->find_type_constraint; - my $builder = $attribute->builder; + my $name = $attribute->name; + my $default = $attribute->default; + my $type = $attribute->type_constraint; + my $constraint = $attribute->find_type_constraint; + my $builder = $attribute->builder; + my $trigger = $attribute->trigger; + my $is_weak = $attribute->is_weak_ref; + my $should_deref = $attribute->should_auto_deref; + my $should_coerce = $attribute->should_coerce; - my $trigger = $attribute->trigger; - my $before = $trigger->{before}; - my $after = $trigger->{after}; - my $around = $trigger->{around}; - - my $accessor = 'sub { - my $self = shift;'; + my $self = '$_[0]'; + my $key = $attribute->inlined_name; + my $accessor = "sub {\n"; if ($attribute->_is_metadata eq 'rw') { - $accessor .= 'if (@_) { - local $_ = $_[0];'; - - if ($before) { - $accessor .= '$before->($self, $_, $attribute);'; - } + $accessor .= 'if (scalar(@_) >= 2) {' . "\n"; - if ($around) { - $accessor .= '$around->(sub { - my $self = shift; - $_ = $_[0]; - '; - } + my $value = '$_[1]'; - if ($constraint) { - $accessor .= '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"); - }' + if ($constraint) { + if ($should_coerce) { + $accessor .= $value.' = $attribute->coerce_constraint('.$value.');'; } + $accessor .= 'local $_ = '.$value.';'; + $accessor .= ' + 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} = $_;'; + # if there's nothing left to do for the attribute we can return during + # this setter + $accessor .= 'return ' if !$is_weak && !$trigger && !$should_deref; - if ($attribute->is_weak_ref) { - $accessor .= 'Scalar::Util::weaken($self->{$key}) if ref($self->{$key});'; - } + $accessor .= $self.'->{'.$key.'} = '.$value.';' . "\n"; - if ($around) { - $accessor .= '}, $self, $_, $attribute);'; + if ($is_weak) { + $accessor .= 'Mouse::Util::weaken('.$self.'->{'.$key.'}) if ref('.$self.'->{'.$key.'});' . "\n"; } - if ($after) { - $accessor .= '$after->($self, $_, $attribute);'; + if ($trigger) { + $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 ($should_deref) { if ($attribute->type_constraint eq 'ArrayRef') { $accessor .= 'if (wantarray) { - return @{ $self->{$key} || [] }; + return @{ '.$self.'->{'.$key.'} || [] }; }'; } else { $accessor .= 'if (wantarray) { - return %{ $self->{$key} || {} }; + return %{ '.$self.'->{'.$key.'} || {} }; }'; } } - $accessor .= 'return $self->{$key}; + $accessor .= 'return '.$self.'->{'.$key.'}; }'; - return eval $accessor; + my $sub = eval $accessor; + confess $@ if $@; + return $sub; } sub generate_predicate { my $attribute = shift; - my $key = $attribute->name; + my $key = $attribute->inlined_name; - my $predicate = 'sub { exists($_[0]->{$key}) }'; + 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 $key = $attribute->inlined_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 { @@ -175,6 +183,7 @@ sub generate_handles { }'; $method_map{$local_method} = eval $method; + confess $@ if $@; } return \%method_map; @@ -189,6 +198,9 @@ sub create { %args = $self->canonicalize_args($name, %args); $self->validate_args($name, \%args); + $args{should_coerce} = delete $args{coerce} + if exists $args{coerce}; + $args{type_constraint} = delete $args{isa} if exists $args{isa}; @@ -272,14 +284,12 @@ sub validate_args { && $args->{isa} ne 'HashRef'; if ($args->{trigger}) { - if (ref($args->{trigger}) eq 'CODE') { - $args->{trigger} = { - after => $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 or HASH ref on attribute ($name)" - if ref($args->{trigger}) ne 'HASH'; + confess "Trigger must be a CODE ref on attribute ($name)" + if ref($args->{trigger}) ne 'CODE'; } return 1; @@ -291,10 +301,10 @@ sub find_type_constraint { return unless $type; - my $checker = Mouse::TypeRegistry->optimized_constraints->{$type}; + my $checker = Mouse::TypeRegistry->optimized_constraints($self->associated_class->name)->{$type}; return $checker if $checker; - return sub { blessed($_) && blessed($_) eq $type }; + return sub { Mouse::Util::blessed($_) && Mouse::Util::blessed($_) eq $type }; } sub verify_type_constraint { @@ -312,6 +322,13 @@ sub verify_type_constraint { 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 = $self->type_constraint + or return $value; + return Mouse::TypeRegistry->typecast_constraints($self->associated_class->name, $type, $value); +} + sub _canonicalize_handles { my $self = shift; my $handles = shift;