From: 大沢 和宏 <yappo@shibuya.pl>
Date: Fri, 5 Dec 2008 11:27:34 +0000 (+0000)
Subject: support MouseX::Types's  isa or ( isa => Str | Undef )
X-Git-Tag: 0.19~136^2~28
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=6da1e93610cfec750bed324e9bea74965e37f96e;p=gitmo%2FMouse.git

support MouseX::Types's  isa or ( isa => Str | Undef )
---

diff --git a/lib/MouseX/Types.pm b/lib/MouseX/Types.pm
index ada0e75..1522292 100644
--- a/lib/MouseX/Types.pm
+++ b/lib/MouseX/Types.pm
@@ -3,6 +3,7 @@ use strict;
 use warnings;
 
 require Mouse::TypeRegistry;
+use MouseX::Types::TypeDecorator;
 
 sub import {
     my $class  = shift;
@@ -16,8 +17,8 @@ sub import {
     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} };
+            my $obj = $storage->{$name} = "$caller\::$name";
+            *{"$caller\::$name"} = sub () { $obj };
         }
     }
 
@@ -28,7 +29,10 @@ sub _import {
     my($type_class, $pkg, @types) = @_;
     no strict 'refs';
     for my $name (@types) {
-        *{"$pkg\::$name"} = sub () { $type_class->type_storage->{$name} }
+        my $obj = $type_class->type_storage->{$name};
+        $obj = $type_class->type_storage->{$name} = MouseX::Types::TypeDecorator->new($obj)
+            unless ref($obj);
+        *{"$pkg\::$name"} = sub () { $obj };
     }
 }
 
diff --git a/lib/MouseX/Types/TypeDecorator.pm b/lib/MouseX/Types/TypeDecorator.pm
new file mode 100644
index 0000000..244f88c
--- /dev/null
+++ b/lib/MouseX/Types/TypeDecorator.pm
@@ -0,0 +1,41 @@
+package MouseX::Types::TypeDecorator;
+
+use strict;
+use warnings;
+
+use Mouse::Util 'blessed';
+
+use overload(
+    '""' => sub { ${ $_[0] } },
+    '|' => sub {
+        
+        ## It's kind of ugly that we need to know about Union Types, but this
+        ## is needed for syntax compatibility.  Maybe someday we'll all just do
+        ## Or[Str,Str,Int]
+        
+        my @tc = grep {blessed $_} @_;
+        use Data::Dumper;
+        my $ret;
+        if (ref($_[0])) {
+            $ret = ${ $_[0] };
+        } else {
+            $ret = $_[0];
+        }
+        $ret .= '|';
+        if (ref($_[1])) {
+            $ret .= ${ $_[1] };
+        } else {
+            $ret .= $_[1];
+        }
+        $ret;
+    },
+    fallback => 1,
+    
+);
+
+sub new {
+    my $type = $_[1];
+    bless \$type, $_[0];
+}
+
+1;
diff --git a/t/800_shikabased/802-mousex_types-isa-or.t b/t/800_shikabased/802-mousex_types-isa-or.t
new file mode 100644
index 0000000..bd20f3a
--- /dev/null
+++ b/t/800_shikabased/802-mousex_types-isa-or.t
@@ -0,0 +1,77 @@
+use strict;
+use warnings;
+use Test::More tests => 13;
+
+{
+    package Types;
+    use strict;
+    use warnings;
+    use MouseX::Types -declare => [qw/ Baz Type1 Type2 /];
+    use MouseX::Types::Mouse qw( ArrayRef );
+
+    subtype Baz, where { defined($_) && $_ eq 'Baz' };
+    coerce Baz, from ArrayRef, via { 'Baz' };
+
+    subtype Type1, where { defined($_) && $_ eq 'Name' };
+    coerce Type1, from 'Str', via { 'Names' };
+
+    subtype Type2, where { defined($_) && $_ eq 'Group' };
+    coerce Type2, from 'Str', via { 'Name' };
+
+}
+
+{   
+    package Foo;
+    use Mouse;
+    use MouseX::Types::Mouse qw( Str Undef );
+    BEGIN { Types->import(qw( Baz Type1 )) }
+    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;
+    BEGIN { Types->import(qw( Type1 Type2 )) }
+    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';