+ MouseX::NonMoose wrapper, tests

Changes

@@ -1,5 +1,9 @@
 Revision history for Perl extension MouseX::Foreign
 
+0.006 2011-10-13 10:47:07
+    - Add MouseX::NonMoose for drop-in compatibility with Any::Moose
+    - Add test files for new module
+
 0.005 2011-10-13 09:40:21
     - No code changes
     - Fix module name in README, .gitignore, xt/podspell.t and Changes (this file)

lib/MouseX/NonMoose.pm

@@ -11,7 +11,7 @@ __END__
 
 =head1 NAME
 
-MouseX::NonMoose - MouseX::Foreign plus drop-in compatiblity with Any::Moose
+MouseX::NonMoose - MouseX::Foreign plus drop-in compatibility with Any::Moose
 
 =head1 VERSION
 

lib/MouseX/NonMoose/Meta/Role/Class.pm

@@ -0,0 +1,7 @@
+package MouseX::NonMoose::Meta::Role::Class;
+use Mouse::Role;
+use Mouse::Util::MetaRole;
+
+with 'MouseX::Foreign::Meta::Role::Class';
+
+1;

lib/MouseX/NonMoose/Meta/Role/Method/Constructor.pm

@@ -0,0 +1,27 @@
+package MouseX::NonMoose::Meta::Role::Method::Constructor;
+use Mouse::Role;
+
+around _generate_constructor => sub {
+    my($next, undef, $meta, $option) = @_;
+
+    # The foreign superlcass must have the new method
+    my $foreign_buildargs  = $meta->name->can('FOREIGNBUILDARGS');
+    my $foreign_superclass = $meta->foreign_superclass;
+    my $super_new          = $foreign_superclass->can('new');
+    my $needs_buildall     = !$foreign_superclass->can('BUILDALL');
+
+    return sub {
+        my $class  = shift;
+        my $object = $foreign_buildargs
+            ? $class->$super_new($class->$foreign_buildargs(@_))
+            : $class->$super_new(                           @_ );
+        my $args = $class->BUILDARGS(@_);
+        $object->meta->_initialize_object($object, $args);
+        $object->BUILDALL($args) if $needs_buildall;
+
+        return $object;
+    };
+};
+
+no Mouse::Role;
+1;

lib/MouseX/NonMoose/Meta/Role/Method/Destructor.pm

@@ -0,0 +1,26 @@
+package MouseX::NonMoose::Meta::Role::Method::Destructor;
+use Mouse::Role;
+
+around _generate_destructor => sub {
+    my($next, undef, $meta) = @_;
+
+    my $foreign_superclass = $meta->foreign_superclass;
+
+    my $super_destroy;
+    if(!$foreign_superclass->can('DEMOLISHALL')){
+        $super_destroy = $foreign_superclass->can('DESTROY');
+    }
+
+    return sub {
+        my($self) = @_;
+        $self->DEMOLISHALL();
+
+        if(defined $super_destroy) {
+            $self->$super_destroy();
+        }
+        return;
+    };
+};
+
+no Mouse::Role;
+1;

t/91-90-with-Any-Moose/001-basic.t

@@ -0,0 +1,32 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+
+package Foo;
+
+sub new {
+    my $class = shift;
+    bless { _class => $class }, $class;
+}
+
+package Foo::Mouse;
+use Mouse;
+use Any::Moose 'X::NonMoose';
+extends 'Foo';
+
+package main;
+my $foo = Foo->new;
+my $foo_moose = Foo::Mouse->new;
+isa_ok($foo, 'Foo');
+is($foo->{_class}, 'Foo', 'Foo gets the correct class');
+isa_ok($foo_moose, 'Foo::Mouse');
+isa_ok($foo_moose, 'Foo');
+isa_ok($foo_moose, 'Mouse::Object');
+is($foo_moose->{_class}, 'Foo::Mouse', 'Foo::Mouse gets the correct class');
+my $meta = Foo::Mouse->meta;
+ok($meta->has_method('new'), 'Foo::Mouse has its own constructor');
+my $cc_meta = $meta->constructor_class->meta;
+isa_ok($cc_meta, 'Mouse::Meta::Class');
+
+done_testing;

t/91-90-with-Any-Moose/002-methods.t

@@ -0,0 +1,25 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 3;
+
+package Foo;
+
+sub new { bless {}, shift }
+sub foo { 'Foo' }
+sub bar { 'Foo' }
+sub baz { ref(shift) }
+
+package Foo::Mouse;
+use Mouse;
+use Any::Moose 'X::NonMoose';
+extends 'Foo';
+
+sub bar { 'Foo::Mouse' }
+
+package main;
+
+my $foo_moose = Foo::Mouse->new;
+is($foo_moose->foo, 'Foo', 'Foo::Mouse->foo');
+is($foo_moose->bar, 'Foo::Mouse', 'Foo::Mouse->bar');
+is($foo_moose->baz, 'Foo::Mouse', 'Foo::Mouse->baz');

t/91-90-with-Any-Moose/003-attrs.t

@@ -0,0 +1,36 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 4;
+
+package Foo;
+
+sub new {
+    my $class = shift;
+    bless { @_ }, $class;
+}
+
+sub foo {
+    my $self = shift;
+    return $self->{foo} unless @_;
+    $self->{foo} = shift;
+}
+
+package Foo::Mouse;
+use Mouse;
+use Any::Moose 'X::NonMoose';
+extends 'Foo';
+
+has bar => (
+    is => 'rw',
+);
+
+package main;
+
+my $foo_moose = Foo::Mouse->new(foo => 'FOO', bar => 'BAR');
+is($foo_moose->foo, 'FOO', 'foo set in constructor');
+is($foo_moose->bar, 'BAR', 'bar set in constructor');
+$foo_moose->foo('BAZ');
+$foo_moose->bar('QUUX');
+is($foo_moose->foo, 'BAZ', 'foo set by accessor');
+is($foo_moose->bar, 'QUUX', 'bar set by accessor');

t/91-90-with-Any-Moose/004-multi-level.t

@@ -0,0 +1,56 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 11;
+
+package Foo;
+
+sub new {
+    my $class = shift;
+    bless { foo => 'FOO' }, $class;
+}
+
+sub foo { shift->{foo} }
+
+package Foo::Mouse;
+use Mouse;
+use Any::Moose 'X::NonMoose';
+extends 'Foo';
+
+has bar => (
+    is      => 'ro',
+    default => 'BAR',
+);
+
+package Foo::Mouse::Sub;
+use Mouse;
+extends 'Foo::Mouse';
+
+has baz => (
+    is      => 'ro',
+    default => 'BAZ',
+);
+
+package main;
+my $foo_moose = Foo::Mouse->new;
+is($foo_moose->foo, 'FOO', 'Foo::Mouse::foo');
+is($foo_moose->bar, 'BAR', 'Foo::Mouse::bar');
+isnt(Foo::Mouse->meta->get_method('new'), undef,
+     'Foo::Mouse gets its own constructor');
+
+my $foo_moose_sub = Foo::Mouse::Sub->new;
+is($foo_moose_sub->foo, 'FOO', 'Foo::Mouse::Sub::foo');
+is($foo_moose_sub->bar, 'BAR', 'Foo::Mouse::Sub::bar');
+is($foo_moose_sub->baz, 'BAZ', 'Foo::Mouse::Sub::baz');
+is(Foo::Mouse::Sub->meta->get_method('new'), undef,
+   'Foo::Mouse::Sub just uses the constructor for Foo::Mouse');
+
+Foo::Mouse->meta->make_immutable;
+Foo::Mouse::Sub->meta->make_immutable;
+
+$foo_moose_sub = Foo::Mouse::Sub->new;
+is($foo_moose_sub->foo, 'FOO', 'Foo::Mouse::Sub::foo (immutable)');
+is($foo_moose_sub->bar, 'BAR', 'Foo::Mouse::Sub::bar (immutable)');
+is($foo_moose_sub->baz, 'BAZ', 'Foo::Mouse::Sub::baz (immutable)');
+isnt(Foo::Mouse::Sub->meta->get_method('new'), undef,
+     'Foo::Mouse::Sub has an inlined constructor');

t/91-90-with-Any-Moose/005-moose.t

@@ -0,0 +1,51 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 12;
+
+package Foo;
+use Mouse;
+
+has foo => (
+    is      => 'ro',
+    default => 'FOO',
+);
+
+package Foo::Sub;
+use Mouse;
+use Any::Moose 'X::NonMoose';
+extends 'Foo';
+
+package main;
+my $foo_sub = Foo::Sub->new;
+isa_ok($foo_sub, 'Foo');
+is($foo_sub->foo, 'FOO', 'inheritance works');
+ok(!Foo::Sub->meta->has_method('new'),
+   'Foo::Sub doesn\'t have its own new method');
+
+$_->meta->make_immutable for qw(Foo Foo::Sub);
+
+$foo_sub = Foo::Sub->new;
+isa_ok($foo_sub, 'Foo');
+is($foo_sub->foo, 'FOO', 'inheritance works (immutable)');
+ok(Foo::Sub->meta->has_method('new'),
+   'Foo::Sub has its own new method (immutable)');
+
+package Foo::OtherSub;
+use Mouse;
+use Any::Moose 'X::NonMoose';
+extends 'Foo';
+
+package main;
+my $foo_othersub = Foo::OtherSub->new;
+isa_ok($foo_othersub, 'Foo');
+is($foo_othersub->foo, 'FOO', 'inheritance works (immutable when extending)');
+ok(!Foo::OtherSub->meta->has_method('new'),
+   'Foo::OtherSub doesn\'t have its own new method (immutable when extending)');
+
+Foo::OtherSub->meta->make_immutable;
+$foo_othersub = Foo::OtherSub->new;
+isa_ok($foo_othersub, 'Foo');
+is($foo_othersub->foo, 'FOO', 'inheritance works (all immutable)');
+ok(Foo::OtherSub->meta->has_method('new'),
+   'Foo::OtherSub has its own new method (all immutable)');

t/91-90-with-Any-Moose/006-disable.t

@@ -0,0 +1,34 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 3;
+
+package Foo;
+
+sub new {
+    my $class = shift;
+    bless {}, $class;
+}
+
+package Foo::Mouse;
+use Mouse;
+use Any::Moose 'X::NonMoose';
+extends 'Foo';
+
+package Foo::Mouse2;
+use Mouse;
+use Any::Moose 'X::NonMoose';
+extends 'Foo';
+
+package main;
+
+ok(Foo::Mouse->meta->has_method('new'), 'Foo::Mouse has a constructor');
+my $method = Foo::Mouse->meta->get_method('new');
+Foo::Mouse->meta->make_immutable;
+isnt($method->body, Foo::Mouse->meta->get_method('new')->body,
+     'make_immutable replaced the constructor with an inlined version');
+
+my $method2 = Foo::Mouse2->meta->get_method('new');
+Foo::Mouse2->meta->make_immutable(inline_constructor => 0);
+is($method2->body, Foo::Mouse2->meta->get_method('new')->body,
+   'make_immutable doesn\'t replace the constructor if we ask it not to');

t/91-90-with-Any-Moose/010-immutable.t

@@ -0,0 +1,43 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 6;
+
+package Foo;
+
+sub new {
+    my $class = shift;
+    bless { @_ }, $class;
+}
+
+sub foo {
+    my $self = shift;
+    return $self->{foo} unless @_;
+    $self->{foo} = shift;
+}
+
+sub baz  { 'Foo' }
+sub quux { ref(shift) }
+
+package Foo::Mouse;
+use Mouse;
+use Any::Moose 'X::NonMoose';
+extends 'Foo';
+
+has bar => (
+    is => 'rw',
+);
+
+__PACKAGE__->meta->make_immutable;
+
+package main;
+
+my $foo_moose = Foo::Mouse->new(foo => 'FOO', bar => 'BAR');
+is($foo_moose->foo, 'FOO', 'foo set in constructor');
+is($foo_moose->bar, 'BAR', 'bar set in constructor');
+$foo_moose->foo('BAZ');
+$foo_moose->bar('QUUX');
+is($foo_moose->foo, 'BAZ', 'foo set by accessor');
+is($foo_moose->bar, 'QUUX', 'bar set by accessor');
+is($foo_moose->baz, 'Foo', 'baz method');
+is($foo_moose->quux, 'Foo::Mouse', 'quux method');