From: 大沢 和宏 Date: Wed, 3 Dec 2008 09:52:51 +0000 (+0000) Subject: added MouseX::Types, MouseX::Types::Mouse X-Git-Tag: 0.19~136^2~47 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5439cf977dec83dafef4ee1cc990e7850d308cd0;p=gitmo%2FMouse.git added MouseX::Types, MouseX::Types::Mouse --- diff --git a/lib/Mouse/TypeRegistry.pm b/lib/Mouse/TypeRegistry.pm index d468296..70f00ac 100644 --- a/lib/Mouse/TypeRegistry.pm +++ b/lib/Mouse/TypeRegistry.pm @@ -146,6 +146,7 @@ sub typecast_constraints { Object => sub { blessed($_) && blessed($_) ne 'Regexp' }, }; + sub list_all_builtin_type_constraints { keys %{ $optimized_constraints } } sub optimized_constraints { return { %{ $SUBTYPE }, %{ $optimized_constraints } }; } diff --git a/lib/MouseX/Types.pm b/lib/MouseX/Types.pm new file mode 100644 index 0000000..2af1823 --- /dev/null +++ b/lib/MouseX/Types.pm @@ -0,0 +1,129 @@ +package MouseX::Types; +use strict; +use warnings; + +require Mouse::TypeRegistry; + +sub import { + my $class = shift; + my %args = @_; + my $caller = caller(0); + + no strict 'refs'; + *{"$caller\::import"} = sub { my $pkg = caller(0); _import($caller, $pkg, @_) }; + push @{"$caller\::ISA"}, 'MouseX::Types::Base'; + + if (defined $args{'-declare'} && ref($args{'-declare'}) eq 'ARRAY') { + my $storage = $caller->type_storage($caller); + for my $name (@{ $args{'-declare'} }) { + $storage->{$name} = "$caller\::$name"; + *{"$caller\::$name"} = sub () { $caller->type_storage->{$name} }; + } + } + + return Mouse::TypeRegistry->import( callee => $caller ); +} + +sub _import { + my($type_class, $pkg, @types) = @_; + no strict 'refs'; + for my $name (@types) { + *{"$pkg\::$name"} = sub () { $type_class->type_storage->{$name} } + } +} + +{ + package MouseX::Types::Base; + my %storage; + sub type_storage { + $storage{$_[0]} ||= +{} + } +} + +1; + +=head1 NAME + +Mouse - Organise your Mouse types in libraries + +=head1 SYNOPSIS + +=head2 Library Definition + + package MyLibrary; + + # predeclare our own types + use MouseX::Types + -declare => [qw( + PositiveInt NegativeInt + ArrayRefOfPositiveInt ArrayRefOfAtLeastThreeNegativeInts + LotsOfInnerConstraints StrOrArrayRef + )]; + + # import builtin types + use MouseX::Types::Mouse 'Int'; + + # type definition. + subtype PositiveInt, + as Int, + where { $_ > 0 }, + message { "Int is not larger than 0" }; + + subtype NegativeInt, + as Int, + where { $_ < 0 }, + message { "Int is not smaller than 0" }; + + # type coercion + coerce PositiveInt, + from Int, + via { 1 }; + + # with parameterized constraints. + + subtype ArrayRefOfPositiveInt, + as ArrayRef[PositiveInt]; + + subtype ArrayRefOfAtLeastThreeNegativeInts, + as ArrayRef[NegativeInt], + where { scalar(@$_) > 2 }; + + subtype LotsOfInnerConstraints, + as ArrayRef[ArrayRef[HashRef[Int]]]; + + # with TypeConstraint Unions + + subtype StrOrArrayRef, + as Str|ArrayRef; + + 1; + +=head2 Usage + + package Foo; + use Mouse; + use MyLibrary qw( PositiveInt NegativeInt ); + + # use the exported constants as type names + has 'bar', + isa => PositiveInt, + is => 'rw'; + has 'baz', + isa => NegativeInt, + is => 'rw'; + + sub quux { + my ($self, $value); + + # test the value + print "positive\n" if is_PositiveInt($value); + print "negative\n" if is_NegativeInt($value); + + # coerce the value, NegativeInt doesn't have a coercion + # helper, since it didn't define any coercions. + $value = to_PositiveInt($value) or die "Cannot coerce"; + } + + 1; + +=cut diff --git a/lib/MouseX/Types/Mouse.pm b/lib/MouseX/Types/Mouse.pm new file mode 100644 index 0000000..65874a9 --- /dev/null +++ b/lib/MouseX/Types/Mouse.pm @@ -0,0 +1,15 @@ +package MouseX::Types::Mouse; +use strict; +use warnings; + +BEGIN { require Mouse::TypeRegistry } +use MouseX::Types; + +BEGIN { + my $builtin_type = +{ map { $_ => $_ } Mouse::TypeRegistry->list_all_builtin_type_constraints }; + sub type_storage { $builtin_type } +} + +1; + + diff --git a/t/800_shikabased/801-mousex_types.t b/t/800_shikabased/801-mousex_types.t new file mode 100644 index 0000000..e0eaca5 --- /dev/null +++ b/t/800_shikabased/801-mousex_types.t @@ -0,0 +1,118 @@ +use strict; +use warnings; +use Test::More tests => 16; + +{ + package Types; + use MouseX::Types -declare => [qw/ Headers /]; + use MouseX::Types::Mouse 'HashRef'; + + subtype Headers, where { defined $_ && eval { $_->isa('Headers1') } }; + coerce Headers, + from HashRef, via { + Headers1->new(%{ $_ }); + }, + ; +} + +{ + package Types2; + use MouseX::Types -declare => [qw/ Headers /]; + use MouseX::Types::Mouse 'HashRef'; + + subtype Headers, where { defined $_ && eval { $_->isa('Headers2') } }; + coerce Headers, + from HashRef, via { + Headers2->new(%{ $_ }); + }, + ; +} + +{ + package Headers1; + use Mouse; + has 'foo' => ( is => 'rw' ); +} + +{ + package Headers2; + use Mouse; + has 'foo' => ( is => 'rw' ); +} + +{ + package Response; + use Mouse; + BEGIN { Types->import(qw/ Headers /) } + + has headers => ( + is => 'rw', + isa => Headers, + coerce => 1, + ); +} + +{ + package Request; + use Mouse; + BEGIN { Types->import(qw/ Headers /) } + + has headers => ( + is => 'rw', + isa => Headers, + coerce => 1, + ); +} + +{ + package Response2; + use Mouse; + BEGIN { Types2->import(qw/ Headers /) } + + has headers => ( + is => 'rw', + isa => Headers, + coerce => 1, + ); +} + +{ + package Request2; + use Mouse; + BEGIN { Types2->import(qw/ Headers /) } + + has headers => ( + is => 'rw', + isa => Headers, + coerce => 1, + ); +} + +my $res = Response->new(headers => { foo => 'bar' }); +isa_ok($res->headers, 'Headers1'); +is($res->headers->foo, 'bar'); +$res->headers({foo => 'yay'}); +isa_ok($res->headers, 'Headers1'); +is($res->headers->foo, 'yay'); + +my $req = Request->new(headers => { foo => 'bar' }); +isa_ok($res->headers, 'Headers1'); +is($req->headers->foo, 'bar'); +$req->headers({foo => 'yay'}); +isa_ok($res->headers, 'Headers1'); +is($req->headers->foo, 'yay'); + +$res = Response2->new(headers => { foo => 'bar' }); +isa_ok($res->headers, 'Headers2'); +is($res->headers->foo, 'bar'); +$res->headers({foo => 'yay'}); +isa_ok($res->headers, 'Headers2'); +is($res->headers->foo, 'yay'); + +$req = Request2->new(headers => { foo => 'bar' }); +isa_ok($res->headers, 'Headers2'); +is($req->headers->foo, 'bar'); +$req->headers({foo => 'yay'}); +isa_ok($res->headers, 'Headers2'); +is($req->headers->foo, 'yay'); +