From: gfx <gfuji@cpan.org>
Date: Mon, 19 Oct 2009 09:27:31 +0000 (+0900)
Subject: Add tests for subtyping issue
X-Git-Tag: 0.40~3
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=3d3b9c8ad9ca9293d20e12e6630f69b94684d134;p=gitmo%2FMouse.git

Add tests for subtyping issue
---

diff --git a/t/001_mouse/057_subtype_without_where.t b/t/001_mouse/057_subtype_without_where.t
new file mode 100644
index 0000000..2b6ebb4
--- /dev/null
+++ b/t/001_mouse/057_subtype_without_where.t
@@ -0,0 +1,49 @@
+#!/usr/bin/perl -w
+use Test::More tests => 4;
+use Test::Exception;
+
+use Mouse::Util::TypeConstraints;
+
+{
+    package Class;
+    sub new {
+        my $class = shift;
+        return bless { @_ }, $class;
+    }
+}
+
+subtype 'Class',
+    as 'Object',
+    where { $_->isa('Class') };
+
+subtype 'C', as 'Class'; # subtyping without "where"
+
+coerce 'C',
+    from 'Str',
+    via { Class->new(content => $_) },
+    from 'HashRef',
+    via { Class->new(content => $_->{content}) };
+
+{
+    package A;
+    use Mouse;
+
+    has foo => (
+        is => 'ro',
+        isa => 'C',
+        coerce => 1,
+        requried => 1,
+    );
+}
+
+lives_and{
+    my $a = A->new(foo => 'foobar');
+    isa_ok $a->foo, 'Class';
+    is $a->foo->{content}, 'foobar';
+};
+
+lives_and{
+    my $a = A->new(foo => { content => 42 });
+    isa_ok $a->foo, 'Class';
+    is $a->foo->{content}, 42;
+};