added to class_type

diff --git a/lib/Mouse/TypeRegistry.pm b/lib/Mouse/TypeRegistry.pm
index ecde30d..ff2350f 100644 (file)
--- a/lib/Mouse/TypeRegistry.pm
+++ b/lib/Mouse/TypeRegistry.pm
@@ -24,7 +24,7 @@ sub import {
     no strict 'refs';
     *{"$caller\::subtype"}     = \&_subtype;
     *{"$caller\::coerce"}      = \&_coerce;
-#    *{"$caller\::class_type"}  = \&_class_type;
+    *{"$caller\::class_type"}  = \&_class_type;
 #    *{"$caller\::role_type"}   = \&_role_type;
 }
 
@@ -52,6 +52,16 @@ sub _coerce {
     $COERCE->{$pkg}->{$name} = $conf;
 }
 
+sub _class_type {
+    my $pkg = caller(0);
+    $SUBTYPE->{$pkg} ||= +{};
+    my($name, $conf) = @_;
+    my $class = $conf->{class};
+    $SUBTYPE->{$pkg}->{$name} = sub {
+        defined $_ && ref($_) eq $class;
+    };
+}
+
 sub typecast_constraints {
     my($class, $pkg, $type, $value) = @_;
     return $value unless defined $COERCE->{$pkg} && defined $COERCE->{$pkg}->{$type};

diff --git a/t/803_class_type.t b/t/803_class_type.t
new file mode 100644 (file)
index 0000000..b47077c
--- /dev/null
+++ b/t/803_class_type.t
@@ -0,0 +1,35 @@
+use strict;
+use warnings;
+use Test::More tests => 4;
+
+{
+    package Response::Headers;
+    use Mouse;
+    has 'foo' => ( is => 'rw' );
+}
+
+{
+    package Response;
+    use Mouse;
+    use Mouse::TypeRegistry;
+
+    class_type Headers => { class => 'Response::Headers' };
+    coerce 'Headers' => +{
+        HashRef => sub {
+            Response::Headers->new(%{ $_ });
+        },
+    };
+
+    has headers => (
+        is     => 'rw',
+        isa    => 'Headers',
+        coerce => 1,
+    );
+}
+
+my $res = Response->new(headers => { foo => 'bar' });
+isa_ok($res->headers, 'Response::Headers');
+is($res->headers->foo, 'bar');
+$res->headers({foo => 'yay'});
+isa_ok($res->headers, 'Response::Headers');
+is($res->headers->foo, 'yay');