From: 大沢 和宏 Date: Wed, 3 Dec 2008 06:14:23 +0000 (+0000) Subject: more more moose way to type constraints X-Git-Tag: 0.19~136^2~58 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=61a02a3addc8542afac0bbd222610d7e050137ce;p=gitmo%2FMouse.git more more moose way to type constraints --- diff --git a/lib/Mouse/TypeRegistry.pm b/lib/Mouse/TypeRegistry.pm index 15d3479..c1f4d36 100644 --- a/lib/Mouse/TypeRegistry.pm +++ b/lib/Mouse/TypeRegistry.pm @@ -3,6 +3,7 @@ package Mouse::TypeRegistry; use strict; use warnings; +use Carp (); use Mouse::Util qw/blessed looks_like_number openhandle/; my $SUBTYPE = +{}; @@ -13,21 +14,39 @@ sub import { my %args = @_; my $caller = caller(0); - $SUBTYPE->{$caller} ||= +{}; - $COERCE->{$caller} ||= +{}; - if (defined $args{'-export'} && ref($args{'-export'}) eq 'ARRAY') { no strict 'refs'; *{"$caller\::import"} = sub { _import(@_) }; } no strict 'refs'; + *{"$caller\::as"} = \&_as; + *{"$caller\::where"} = \&_where; + *{"$caller\::message"} = \&_message; + *{"$caller\::from"} = \&_from; + *{"$caller\::via"} = \&_via; *{"$caller\::subtype"} = \&_subtype; *{"$caller\::coerce"} = \&_coerce; *{"$caller\::class_type"} = \&_class_type; *{"$caller\::role_type"} = \&_role_type; } + +sub _as ($) { + as => $_[0] +} +sub _where (&) { + where => $_[0] +} +sub _message ($) { + message => $_[0] +} + +sub _from { @_ } +sub _via (&) { + $_[0] +} + sub _import { my($class, @types) = @_; return unless exists $SUBTYPE->{$class} && exists $COERCE->{$class}; @@ -38,51 +57,67 @@ sub _import { sub _subtype { my $pkg = caller(0); - my($name, $stuff) = @_; - if (ref $stuff eq 'HASH') { - my $as = $stuff->{as}; - $stuff = optimized_constraints()->{$as}; - } - $SUBTYPE->{$pkg}->{$name} = $stuff; + my($name, %conf) = @_; + if (my $type = $SUBTYPE->{$name}) { + Carp::croak "The type constraint '$name' has already been created, cannot be created again in $pkg"; + }; + my $as = $conf{as}; + my $stuff = $conf{where} || optimized_constraints()->{$as}; + + $SUBTYPE->{$name} = $stuff; } sub _coerce { - my $pkg = caller(0); - my($name, $conf) = @_; - $COERCE->{$pkg}->{$name} = $conf; + my($name, %conf) = @_; + + Carp::croak "Cannot find type '$name', perhaps you forgot to load it." + unless optimized_constraints()->{$name}; + + my $subtypes = optimized_constraints(); + $COERCE->{$name} ||= {}; + while (my($type, $code) = each %conf) { + Carp::croak "A coercion action already exists for '$type'" + if $COERCE->{$name}->{$type}; + + Carp::croak "Could not find the type constraint ($type) to coerce from" + unless $subtypes->{$type}; + + $COERCE->{$name}->{$type} = $code; + } } sub _class_type { my $pkg = caller(0); - $SUBTYPE->{$pkg} ||= +{}; my($name, $conf) = @_; my $class = $conf->{class}; - $SUBTYPE->{$pkg}->{$name} = sub { - defined $_ && ref($_) eq $class; - }; + _subtype( + $name => where => sub { + defined $_ && ref($_) eq $class; + } + ); } sub _role_type { - my $pkg = caller(0); - $SUBTYPE->{$pkg} ||= +{}; my($name, $conf) = @_; my $role = $conf->{role}; - $SUBTYPE->{$pkg}->{$name} = sub { - return unless defined $_ && ref($_) && $_->isa('Mouse::Object'); - $_->meta->does_role($role); - }; + _subtype( + $name => where => sub { + return unless defined $_ && ref($_) && $_->isa('Mouse::Object'); + $_->meta->does_role($role); + } + ); } sub typecast_constraints { my($class, $pkg, $type, $value) = @_; - return $value unless defined $COERCE->{$pkg} && defined $COERCE->{$pkg}->{$type}; + return $value unless $COERCE->{$type}; my $optimized_constraints = optimized_constraints(); - for my $coerce_type (keys %{ $COERCE->{$pkg}->{$type} }) { + for my $coerce_type (keys %{ $COERCE->{$type} }) { local $_ = $value; if ($optimized_constraints->{$coerce_type}->()) { local $_ = $value; - return $COERCE->{$pkg}->{$type}->{$coerce_type}->(); + return $COERCE->{$type}->{$coerce_type}->(); } } @@ -124,9 +159,7 @@ sub typecast_constraints { Object => sub { blessed($_) && blessed($_) ne 'Regexp' }, }; sub optimized_constraints { - my($class, $pkg) = @_; - my $subtypes = $SUBTYPE->{$pkg} || {}; - return { %{ $subtypes }, %{ $optimized_constraints } }; + return { %{ $SUBTYPE }, %{ $optimized_constraints } }; } } diff --git a/t/501_moose_coerce_mouse.t b/t/501_moose_coerce_mouse.t index dc8edde..2865e7d 100644 --- a/t/501_moose_coerce_mouse.t +++ b/t/501_moose_coerce_mouse.t @@ -22,12 +22,12 @@ use Test::Exception; use Mouse; use Mouse::TypeRegistry; - subtype 'HeadersType' => sub { defined $_ && eval { $_->isa('Headers') } }; - coerce 'HeadersType' => +{ - HashRef => sub { + subtype 'HeadersType' => where { defined $_ && eval { $_->isa('Headers') } }; + coerce 'HeadersType' => + from 'HashRef' => via { Headers->new(%{ $_ }); }, - }; + ; has headers => ( is => 'rw', diff --git a/t/800_shikabased/001-coerce.t b/t/800_shikabased/001-coerce.t index 34c6f34..d20395d 100644 --- a/t/800_shikabased/001-coerce.t +++ b/t/800_shikabased/001-coerce.t @@ -13,12 +13,15 @@ use Test::More tests => 6; use Mouse; use Mouse::TypeRegistry; - subtype 'HeadersType' => sub { defined $_ && eval { $_->isa('Headers') } }; - coerce 'HeadersType' => +{ - HashRef => sub { - Headers->new(%{ $_ }); + subtype 'HeadersType' => as 'Object' => where { defined $_ && eval { $_->isa('Headers') } }; + coerce 'HeadersType' => + from 'ScalarRef' => via { + Headers->new(); }, - }; + from 'HashRef' => via { + Headers->new(%{ $_ }); + } + ; has headers => ( is => 'rw', diff --git a/t/800_shikabased/002-coerce_multi_class.t b/t/800_shikabased/002-coerce_multi_class.t index 915a144..5b9775b 100644 --- a/t/800_shikabased/002-coerce_multi_class.t +++ b/t/800_shikabased/002-coerce_multi_class.t @@ -1,6 +1,6 @@ use strict; use warnings; -use Test::More tests => 8; +use Test::More tests => 14; { package Response::Headers; @@ -18,12 +18,12 @@ use Test::More tests => 8; use Mouse; use Mouse::TypeRegistry; - subtype 'Headers' => sub { defined $_ && eval { $_->isa('Response::Headers') } }; - coerce 'Headers' => +{ - HashRef => sub { + subtype 'Headers' => where { defined $_ && eval { $_->isa('Response::Headers') } }; + coerce 'Headers' => + from 'HashRef' => via { Response::Headers->new(%{ $_ }); }, - }; + ; has headers => ( is => 'rw', @@ -32,17 +32,71 @@ use Test::More tests => 8; ); } -{ +eval { + package Request; + use Mouse::TypeRegistry; + + subtype 'Headers' => where { defined $_ && eval { $_->isa('Request::Headers') } }; +}; +like $@, qr/The type constraint 'Headers' has already been created, cannot be created again in Request/; + +eval { + package Request; + use Mouse::TypeRegistry; + + coerce 'TooBad' => + from 'HashRef' => via { + Request::Headers->new(%{ $_ }); + }, + ; +}; +like $@, qr/Cannot find type 'TooBad', perhaps you forgot to load it./; + +eval { + package Request; + use Mouse::TypeRegistry; + + coerce 'Headers' => + from 'HashRef' => via { + Request::Headers->new(%{ $_ }); + }, + ; +}; +like $@, qr/A coercion action already exists for 'HashRef'/; + +eval { package Request; - use Mouse; use Mouse::TypeRegistry; - subtype 'Headers' => sub { defined $_ && eval { $_->isa('Request::Headers') } }; - coerce 'Headers' => +{ - HashRef => sub { + coerce 'Headers' => + from 'HashRefa' => via { Request::Headers->new(%{ $_ }); }, - }; + ; +}; +like $@, qr/Could not find the type constraint \(HashRefa\) to coerce from/; + +eval { + package Request; + use Mouse::TypeRegistry; + + coerce 'Headers' => + from 'ArrayRef' => via { + Request::Headers->new(%{ $_ }); + }, + ; +}; +ok !$@; + +eval { + package Response; + subtype 'Headers' => where { defined $_ && eval { $_->isa('Response::Headers') } }; +}; +like $@, qr/The type constraint 'Headers' has already been created, cannot be created again in Response/; + +{ + package Request; + use Mouse; has headers => ( is => 'rw', @@ -51,21 +105,12 @@ use Test::More tests => 8; ); } -{ - package Response; - subtype 'Headers' => sub { defined $_ && eval { $_->isa('Response::Headers') } }; - coerce 'Headers' => +{ - HashRef => sub { - Response::Headers->new(%{ $_ }); - }, - }; -} my $req = Request->new(headers => { foo => 'bar' }); -isa_ok($req->headers, 'Request::Headers'); +isa_ok($req->headers, 'Response::Headers'); is($req->headers->foo, 'bar'); $req->headers({foo => 'yay'}); -isa_ok($req->headers, 'Request::Headers'); +isa_ok($req->headers, 'Response::Headers'); is($req->headers->foo, 'yay'); my $res = Response->new(headers => { foo => 'bar' }); diff --git a/t/800_shikabased/005-class_type.t b/t/800_shikabased/005-class_type.t index b47077c..d8b89cf 100644 --- a/t/800_shikabased/005-class_type.t +++ b/t/800_shikabased/005-class_type.t @@ -14,11 +14,11 @@ use Test::More tests => 4; use Mouse::TypeRegistry; class_type Headers => { class => 'Response::Headers' }; - coerce 'Headers' => +{ - HashRef => sub { + coerce 'Headers' => + from 'HashRef' => via { Response::Headers->new(%{ $_ }); }, - }; + ; has headers => ( is => 'rw', diff --git a/t/800_shikabased/006-role_type.t b/t/800_shikabased/006-role_type.t index 24165c1..fcbb55e 100644 --- a/t/800_shikabased/006-role_type.t +++ b/t/800_shikabased/006-role_type.t @@ -32,11 +32,11 @@ use Test::More tests => 5; use Mouse::TypeRegistry; role_type Headers => { role => 'Response::Headers::Role' }; - coerce 'Headers' => +{ - HashRef => sub { + coerce 'Headers' => + from 'HashRef' => via { Response::Headers->new(%{ $_ }); }, - }; + ; has headers => ( is => 'rw',