From: Yuval Kogman <nothingmuch@woobling.org>
Date: Thu, 24 Jul 2008 13:58:29 +0000 (+0000)
Subject: Moose extending Mouse test & minor fixes
X-Git-Tag: 0.19~231
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=84ef660f3af9eb7802a34ed7a8ce3cdc9c52d79f;p=gitmo%2FMouse.git

Moose extending Mouse test & minor fixes
---

diff --git a/lib/Mouse/Meta/Class.pm b/lib/Mouse/Meta/Class.pm
index 0e3c34a..9b32fc3 100644
--- a/lib/Mouse/Meta/Class.pm
+++ b/lib/Mouse/Meta/Class.pm
@@ -126,6 +126,9 @@ sub clone_instance {
 }
 
 sub make_immutable {}
+sub is_immutable { 0 }
+
+sub attribute_metaclass { "Mouse::Meta::Class" }
 
 1;
 
diff --git a/t/500_moose_extends_mouse.t b/t/500_moose_extends_mouse.t
new file mode 100644
index 0000000..bdc5770
--- /dev/null
+++ b/t/500_moose_extends_mouse.t
@@ -0,0 +1,117 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More 'no_plan';
+use Test::Exception;
+
+{
+    package Foo;
+    use Mouse;
+
+    has foo => (
+        isa => "Int",
+        is  => "rw",
+    );
+
+    package Bar;
+    use Moose;
+
+    ::lives_ok { extends qw(Foo) } "extend Mouse class with Moose";
+
+    ::lives_ok {
+        has bar => (
+            isa => "Str",
+            is  => "rw",
+        );
+    } "new attr in subclass";
+
+    package Gorch;
+    use Moose;
+
+    ::lives_ok { extends qw(Foo) } "extend Mouse class with Moose";
+
+    {
+        local our $TODO = "Moose not yet aware of Mouse meta";
+        ::lives_ok {
+            has '+foo' => (
+                default => 3,
+            );
+        } "clone and inherit attr in subclass";
+    }
+
+    package Quxx;
+    use Mouse;
+
+    has quxx => (
+        is => "rw",
+        default => "lala",
+    );
+
+    package Zork;
+    use Moose;
+
+    ::lives_ok { extends qw(Quxx) } "extend Mouse class with Moose";
+
+    has zork => (
+        is => "rw",
+        default => 42,
+    );
+}
+
+can_ok( Bar => "new" );
+
+my $bar = eval { Bar->new };
+
+ok( $bar, "got an object" );
+isa_ok( $bar, "Bar" );
+isa_ok( $bar, "Foo" );
+
+can_ok( $bar, qw(foo bar) );
+
+is( eval { $bar->foo }, undef, "no default value" );
+is( eval { $bar->bar }, undef, "no default value" );
+
+{
+    local $TODO = "Moose not yet aware of Mouse meta";
+
+
+    is_deeply(
+        [ sort map { $_->name } Bar->meta->compute_all_applicable_attributes ],
+        [ sort qw(foo bar) ],
+        "attributes",
+    );
+
+    is( eval { Gorch->new->foo }, 3, "cloned and inherited attr's default" );
+}
+
+can_ok( Zork => "new" );
+
+{
+    my $zork = eval { Zork->new };
+
+    ok( $zork, "got an object" );
+    isa_ok( $zork, "Zork" );
+    isa_ok( $zork, "Quxx" );
+
+    can_ok( $zork, qw(quxx zork) );
+
+    local $TODO = "Constructor needs to know default values of attrs from both";
+    is( eval { $bar->quxx }, "lala", "default value" );
+    is( eval { $bar->zork }, 42,     "default value" );
+}
+
+{
+    my $zork = eval { Zork->new( zork => "diff", quxx => "blah" ) };
+
+    ok( $zork, "got an object" );
+    isa_ok( $zork, "Zork" );
+    isa_ok( $zork, "Quxx" );
+
+    can_ok( $zork, qw(quxx zork) );
+
+    local $TODO = "Constructor needs to know init args of attrs from both";
+    is( eval { $bar->quxx }, "blah", "constructor param" );
+    is( eval { $bar->zork }, "diff", "constructor param" );
+}