added MouseX::Types, MouseX::Types::Mouse

diff --git a/lib/Mouse/TypeRegistry.pm b/lib/Mouse/TypeRegistry.pm
index d468296..70f00ac 100644 (file)
--- 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 (file)
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 (file)
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 (file)
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');
+