From: 大沢 和宏 Date: Fri, 5 Dec 2008 09:04:20 +0000 (+0000) Subject: oops, revert of revision 6879 X-Git-Tag: 0.19~136^2~30 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=2b9094e8e533f1635eae1481eef711828f521508;hp=adebd0a83f0b7b52be8834444b40eedd0ddc2d66;p=gitmo%2FMouse.git oops, revert of revision 6879 --- diff --git a/lib/Mouse/Meta/Attribute.pm b/lib/Mouse/Meta/Attribute.pm index 8f81bc0..479c43c 100644 --- a/lib/Mouse/Meta/Attribute.pm +++ b/lib/Mouse/Meta/Attribute.pm @@ -47,11 +47,6 @@ sub has_type_constraint { exists $_[0]->{type_constraint} } sub has_trigger { exists $_[0]->{trigger} } sub has_builder { exists $_[0]->{builder} } -sub find_type_constraint { $_[0]->{find_type_constraint} } -sub type_constraint_as_string { - ref($_[0]->{type_constraint}) eq 'ARRAY' ? join '|', @{ $_[0]->{type_constraint} } : $_[0]->{type_constraint} -} - sub _create_args { $_[0]->{_create_args} = $_[1] if @_ > 1; $_[0]->{_create_args} @@ -69,7 +64,7 @@ sub generate_accessor { my $name = $attribute->name; my $default = $attribute->default; - my $type = $attribute->type_constraint_as_string; + my $type = $attribute->type_constraint; my $constraint = $attribute->find_type_constraint; my $builder = $attribute->builder; my $trigger = $attribute->trigger; @@ -87,12 +82,10 @@ sub generate_accessor { my $value = '$_[1]'; if ($constraint) { - $accessor .= 'local $_ = '.$self.'->{'.$key.'} = '; if ($should_coerce) { - $accessor .= '$attribute->coerce_constraint('.$value.');'; - } else { - $accessor .= $value.';'; + $accessor .= $value.' = $attribute->coerce_constraint('.$value.');'; } + $accessor .= 'local $_ = '.$value.';'; $accessor .= ' unless ($constraint->()) { my $display = defined($_) ? overload::StrVal($_) : "undef"; @@ -104,6 +97,8 @@ sub generate_accessor { # this setter $accessor .= 'return ' if !$is_weak && !$trigger && !$should_deref; + $accessor .= $self.'->{'.$key.'} = '.$value.';' . "\n"; + if ($is_weak) { $accessor .= 'Mouse::Util::weaken('.$self.'->{'.$key.'}) if ref('.$self.'->{'.$key.'});' . "\n"; } @@ -130,8 +125,7 @@ sub generate_accessor { } if ($should_deref) { - my $type_constraint = $attribute->type_constraint; - if (!ref($type_constraint) && $type_constraint eq 'ArrayRef') { + if ($attribute->type_constraint eq 'ArrayRef') { $accessor .= 'if (wantarray) { return @{ '.$self.'->{'.$key.'} || [] }; }'; @@ -207,33 +201,8 @@ sub create { $args{should_coerce} = delete $args{coerce} if exists $args{coerce}; - if (exists $args{isa}) { - my $type_constraint = delete $args{isa}; - $type_constraint =~ s/\s//g; - my @type_constraints = split /\|/, $type_constraint; - - my $code; - my $optimized_constraints = Mouse::TypeRegistry->optimized_constraints; - if (@type_constraints == 1) { - $code = $optimized_constraints->{$type_constraints[0]} || - sub { Mouse::Util::blessed($_) && Mouse::Util::blessed($_) eq $type_constraints[0] }; - $args{type_constraint} = $type_constraints[0]; - } else { - my @code_list = map { - my $type = $_; - $optimized_constraints->{$type} || - sub { Mouse::Util::blessed($_) && Mouse::Util::blessed($_) eq $type } - } @type_constraints; - $code = sub { - for my $code (@code_list) { - return 1 if $code->(); - } - return 0; - }; - $args{type_constraint} = \@type_constraints; - } - $args{find_type_constraint} = $code; - } + $args{type_constraint} = delete $args{isa} + if exists $args{isa}; my $attribute = $self->new(%args); @@ -326,11 +295,23 @@ sub validate_args { return 1; } +sub find_type_constraint { + my $self = shift; + my $type = $self->type_constraint; + + return unless $type; + + my $checker = Mouse::TypeRegistry->optimized_constraints()->{$type}; + return $checker if $checker; + + return sub { Mouse::Util::blessed($_) && Mouse::Util::blessed($_) eq $type }; +} + sub verify_type_constraint { my $self = shift; local $_ = shift; - my $type = $self->type_constraint_as_string + my $type = $self->type_constraint or return 1; my $constraint = $self->find_type_constraint; @@ -345,7 +326,7 @@ sub coerce_constraint { my($self, $value) = @_; my $type = $self->type_constraint or return $value; - return Mouse::TypeRegistry->typecast_constraints($self->associated_class->name, $self->find_type_constraint, $type, $value); + return Mouse::TypeRegistry->typecast_constraints($self->associated_class->name, $type, $value); } sub _canonicalize_handles { diff --git a/lib/Mouse/TypeRegistry.pm b/lib/Mouse/TypeRegistry.pm index a37ce3b..c722ec1 100644 --- a/lib/Mouse/TypeRegistry.pm +++ b/lib/Mouse/TypeRegistry.pm @@ -139,21 +139,18 @@ sub _role_type { } sub typecast_constraints { - my($class, $pkg, $type_constraint, $types, $value) = @_; - my $optimized_constraints = optimized_constraints(); - - for my $type (ref($types) eq 'ARRAY' ? @{ $types } : ( $types )) { - next unless $COERCE->{$type}; + my($class, $pkg, $type, $value) = @_; + return $value unless $COERCE->{$type}; - for my $coerce_type (keys %{ $COERCE->{$type} }) { + my $optimized_constraints = optimized_constraints(); + for my $coerce_type (keys %{ $COERCE->{$type} }) { + local $_ = $value; + if ($optimized_constraints->{$coerce_type}->()) { local $_ = $value; - if ($optimized_constraints->{$coerce_type}->()) { - local $_ = $value; - local $_ = $COERCE->{$type}->{$coerce_type}->(); - return $_ if $type_constraint->(); - } + return $COERCE->{$type}->{$coerce_type}->(); } } + return $value; } diff --git a/t/800_shikabased/010-isa-or.t b/t/800_shikabased/010-isa-or.t deleted file mode 100644 index 8708ae3..0000000 --- a/t/800_shikabased/010-isa-or.t +++ /dev/null @@ -1,96 +0,0 @@ -use strict; -use warnings; -use Test::More tests => 18; - -{ - package Foo; - use Mouse; - use Mouse::TypeRegistry; - subtype Baz => where { defined($_) && $_ eq 'Baz' }; - coerce Baz => from 'ArrayRef', via { 'Baz' }; - has 'bar' => ( is => 'rw', isa => 'Str | Baz | Undef', coerce => 1 ); -} - -eval { - Foo->new( bar => +{} ); -}; -ok $@, 'not got an object'; - -eval { - isa_ok(Foo->new( bar => undef ), 'Foo'); -}; -ok !$@, 'got an object 1'; - -eval { - isa_ok(Foo->new( bar => 'foo' ), 'Foo'); - -}; -ok !$@, 'got an object 2'; - - -my $f = Foo->new; -eval { - $f->bar([]); -}; -ok !$@; -is $f->bar, 'Baz', 'bar is baz (coerce from ArrayRef)'; - -eval { - $f->bar('hoge'); -}; -ok !$@; -is $f->bar, 'hoge', 'bar is hoge'; - -eval { - $f->bar(undef); -}; -ok !$@; -is $f->bar, undef, 'bar is undef'; - - -{ - package Bar; - use Mouse; - use Mouse::TypeRegistry; - - subtype 'Type1' => where { defined($_) && $_ eq 'Name' }; - coerce 'Type1', from 'Str', via { 'Names' }; - - subtype 'Type2' => where { defined($_) && $_ eq 'Group' }; - coerce 'Type2', from 'Str', via { 'Name' }; - - has 'foo' => ( is => 'rw', isa => 'Type1|Type2', coerce => 1 ); -} - -my $foo = Bar->new( foo => 'aaa' ); -ok $foo, 'got an object 3'; -is $foo->foo, 'Name', 'foo is Name'; - - -{ - package KLASS; - sub new { bless {}, shift }; -} -{ - package Baz; - use Mouse; - use Mouse::TypeRegistry; - - subtype 'Type3' => where { defined($_) && $_ eq 'Name' }; - coerce 'Type3', from 'CodeRef', via { 'Name' }; - - has 'foo' => ( is => 'rw', isa => 'Type3|KLASS|Undef', coerce => 1 ); -} - -eval { Baz->new( foo => 'aaa' ) }; -like $@, qr/Attribute \(foo\) does not pass the type constraint because: Validation failed for 'Type3\|KLASS\|Undef' failed with value aaa/; - -my $k = Baz->new; -ok $k, 'got an object 4'; -$k->foo(sub {}); -is $k->foo, 'Name', 'foo is Name'; -$k->foo(KLASS->new); -isa_ok $k->foo, 'KLASS'; -$k->foo(undef); -is $k->foo, undef, 'foo is undef'; -