From: 大沢 和宏 Date: Fri, 5 Dec 2008 09:02:13 +0000 (+0000) Subject: support of isa or ( isa => ' Str | Undef ') X-Git-Tag: 0.19~136^2~31 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=adebd0a83f0b7b52be8834444b40eedd0ddc2d66;p=gitmo%2FMouse.git support of isa or ( isa => ' Str | Undef ') --- diff --git a/lib/Mouse/Meta/Attribute.pm b/lib/Mouse/Meta/Attribute.pm index 479c43c..8f81bc0 100644 --- a/lib/Mouse/Meta/Attribute.pm +++ b/lib/Mouse/Meta/Attribute.pm @@ -47,6 +47,11 @@ 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} @@ -64,7 +69,7 @@ sub generate_accessor { my $name = $attribute->name; my $default = $attribute->default; - my $type = $attribute->type_constraint; + my $type = $attribute->type_constraint_as_string; my $constraint = $attribute->find_type_constraint; my $builder = $attribute->builder; my $trigger = $attribute->trigger; @@ -82,10 +87,12 @@ sub generate_accessor { my $value = '$_[1]'; if ($constraint) { + $accessor .= 'local $_ = '.$self.'->{'.$key.'} = '; if ($should_coerce) { - $accessor .= $value.' = $attribute->coerce_constraint('.$value.');'; + $accessor .= '$attribute->coerce_constraint('.$value.');'; + } else { + $accessor .= $value.';'; } - $accessor .= 'local $_ = '.$value.';'; $accessor .= ' unless ($constraint->()) { my $display = defined($_) ? overload::StrVal($_) : "undef"; @@ -97,8 +104,6 @@ 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"; } @@ -125,7 +130,8 @@ sub generate_accessor { } if ($should_deref) { - if ($attribute->type_constraint eq 'ArrayRef') { + my $type_constraint = $attribute->type_constraint; + if (!ref($type_constraint) && $type_constraint eq 'ArrayRef') { $accessor .= 'if (wantarray) { return @{ '.$self.'->{'.$key.'} || [] }; }'; @@ -201,8 +207,33 @@ sub create { $args{should_coerce} = delete $args{coerce} if exists $args{coerce}; - $args{type_constraint} = delete $args{isa} - if exists $args{isa}; + 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; + } my $attribute = $self->new(%args); @@ -295,23 +326,11 @@ 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 + my $type = $self->type_constraint_as_string or return 1; my $constraint = $self->find_type_constraint; @@ -326,7 +345,7 @@ 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); + return Mouse::TypeRegistry->typecast_constraints($self->associated_class->name, $self->find_type_constraint, $type, $value); } sub _canonicalize_handles { diff --git a/lib/Mouse/TypeRegistry.pm b/lib/Mouse/TypeRegistry.pm index c722ec1..a37ce3b 100644 --- a/lib/Mouse/TypeRegistry.pm +++ b/lib/Mouse/TypeRegistry.pm @@ -139,18 +139,21 @@ sub _role_type { } sub typecast_constraints { - my($class, $pkg, $type, $value) = @_; - return $value unless $COERCE->{$type}; - + my($class, $pkg, $type_constraint, $types, $value) = @_; my $optimized_constraints = optimized_constraints(); - for my $coerce_type (keys %{ $COERCE->{$type} }) { - local $_ = $value; - if ($optimized_constraints->{$coerce_type}->()) { + + for my $type (ref($types) eq 'ARRAY' ? @{ $types } : ( $types )) { + next unless $COERCE->{$type}; + + for my $coerce_type (keys %{ $COERCE->{$type} }) { local $_ = $value; - return $COERCE->{$type}->{$coerce_type}->(); + if ($optimized_constraints->{$coerce_type}->()) { + local $_ = $value; + local $_ = $COERCE->{$type}->{$coerce_type}->(); + return $_ if $type_constraint->(); + } } } - return $value; } diff --git a/t/800_shikabased/010-isa-or.t b/t/800_shikabased/010-isa-or.t new file mode 100644 index 0000000..8708ae3 --- /dev/null +++ b/t/800_shikabased/010-isa-or.t @@ -0,0 +1,96 @@ +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'; +