From: Dave Rolsky <autarch@urth.org>
Date: Mon, 25 Aug 2008 15:27:43 +0000 (+0000)
Subject: Implemented Moose::Util::MetaRole, which lets you apply roles to any
X-Git-Tag: 0.55_04~2^2~30
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=231be3be4e3dd7aaae3cee7f04efeec6eecde236;p=gitmo%2FMoose.git

Implemented Moose::Util::MetaRole, which lets you apply roles to any
meta class, as well as the constructor & destructor classes and the
object base class.

To make this work properly, I had to make constructor & destructor
class attributes of Moose::Meta::Class, rather than just hardcoding
them.
---

diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm
index 42e842d..f733a9e 100644
--- a/lib/Moose/Meta/Class.pm
+++ b/lib/Moose/Meta/Class.pm
@@ -23,6 +23,16 @@ __PACKAGE__->meta->add_attribute('roles' => (
     default => sub { [] }
 ));
 
+__PACKAGE__->meta->add_attribute('constructor_class' => (
+    accessor => 'constructor_class',
+    default  => sub { 'Moose::Meta::Method::Constructor' }
+));
+
+__PACKAGE__->meta->add_attribute('destructor_class' => (
+    accessor => 'destructor_class',
+    default  => sub { 'Moose::Meta::Method::Destructor' }
+));
+
 sub initialize {
     my $class = shift;
     my $pkg   = shift;
@@ -424,8 +434,8 @@ sub make_immutable {
     my $self = shift;
     $self->SUPER::make_immutable
       (
-       constructor_class => 'Moose::Meta::Method::Constructor',
-       destructor_class  => 'Moose::Meta::Method::Destructor',
+       constructor_class => $self->constructor_class,
+       destructor_class  => $self->destructor_class,
        inline_destructor => 1,
        # NOTE:
        # no need to do this,
diff --git a/lib/Moose/Util/MetaRole.pm b/lib/Moose/Util/MetaRole.pm
new file mode 100644
index 0000000..d86b4aa
--- /dev/null
+++ b/lib/Moose/Util/MetaRole.pm
@@ -0,0 +1,96 @@
+package Moose::Util::MetaRole;
+
+use strict;
+use warnings;
+
+use List::MoreUtils qw( all );
+
+sub apply_metaclass_roles {
+    my %options = @_;
+
+    my $for = $options{for_class};
+
+    my $meta = _make_new_metaclass( $for, \%options );
+
+    for my $tor_class ( grep { $options{ $_ . '_roles' } }
+        qw( constructor_class destructor_class ) ) {
+
+        my $class = _make_new_class(
+            $meta->$tor_class(),
+            $options{ $tor_class . '_roles' }
+        );
+
+        $meta->$tor_class($class);
+    }
+
+    return $meta;
+}
+
+sub _make_new_metaclass {
+    my $for     = shift;
+    my $options = shift;
+
+    return $for->meta()
+        unless grep { exists $options->{ $_ . '_roles' } }
+            qw(
+            metaclass
+            attribute_metaclass
+            method_metaclass
+            instance_metaclass
+    );
+
+    my $new_metaclass
+        = _make_new_class( ref $for->meta(), $options->{metaclass_roles} );
+
+    my $old_meta = $for->meta();
+
+    Class::MOP::remove_metaclass_by_name($for);
+
+    my %classes = map {
+        $_ => _make_new_class( $old_meta->$_(), $options->{ $_ . '_roles' } )
+        } qw(
+        attribute_metaclass
+        method_metaclass
+        instance_metaclass
+    );
+
+    return $new_metaclass->reinitialize( $for, %classes );
+}
+
+sub apply_base_class_roles {
+    my %options = @_;
+
+    my $for = $options{for_class};
+
+    my $meta = $for->meta();
+
+    my $new_base = _make_new_class(
+        $for,
+        $options{roles},
+        [ $meta->superclasses() ],
+    );
+
+    $meta->superclasses($new_base)
+        if $new_base ne $meta->name();
+}
+
+sub _make_new_class {
+    my $existing_class = shift;
+    my $roles          = shift;
+    my $superclasses   = shift || [$existing_class];
+
+    return $existing_class unless $roles;
+
+    my $meta = $existing_class->meta();
+
+    return $existing_class
+        if $meta->can('does_role') && all { $meta->does_role($_) } @{$roles};
+
+    return Moose::Meta::Class->create_anon_class(
+        superclasses => $superclasses,
+        roles        => $roles,
+        cache        => 1,
+    )->name();
+}
+
+1;
diff --git a/t/050_metaclasses/015_metarole.t b/t/050_metaclasses/015_metarole.t
new file mode 100644
index 0000000..45244d1
--- /dev/null
+++ b/t/050_metaclasses/015_metarole.t
@@ -0,0 +1,267 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More 'no_plan';
+
+use Moose::Util::MetaRole;
+
+
+{
+    package My::Meta::Class;
+    use Moose;
+    extends 'Moose::Meta::Class';
+}
+
+{
+    package My::Meta::Attribute;
+    use Moose;
+    extends 'Moose::Meta::Attribute';
+}
+
+{
+    package My::Meta::Method;
+    use Moose;
+    extends 'Moose::Meta::Method';
+}
+
+{
+    package My::Meta::Instance;
+    use Moose;
+    extends 'Moose::Meta::Instance';
+}
+
+{
+    package My::Meta::MethodConstructor;
+    use Moose;
+    extends 'Moose::Meta::Method::Constructor';
+}
+
+{
+    package My::Meta::MethodDestructor;
+    use Moose;
+    extends 'Moose::Meta::Method::Destructor';
+}
+
+{
+    package Role::Foo;
+    use Moose::Role;
+    has 'foo' => ( is => 'ro', default => 10 );
+}
+
+{
+    package My::Class;
+
+    use Moose;
+}
+
+{
+    Moose::Util::MetaRole::apply_metaclass_roles(
+        for_class       => 'My::Class',
+        metaclass_roles => ['Role::Foo'],
+    );
+
+    ok( My::Class->meta()->meta()->does_role('Role::Foo'),
+        'apply Role::Foo to My::Class->meta()' );
+    is( My::Class->meta()->foo(), 10,
+        '... and call foo() on that meta object' );
+}
+
+{
+    Moose::Util::MetaRole::apply_metaclass_roles(
+        for_class                 => 'My::Class',
+        attribute_metaclass_roles => ['Role::Foo'],
+    );
+
+    ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'),
+        q{apply Role::Foo to My::Class->meta()'s attribute metaclass} );
+    ok( My::Class->meta()->meta()->does_role('Role::Foo'),
+        '... My::Class->meta() still does Role::Foo' );
+
+    My::Class->meta()->add_attribute( 'size', is => 'ro' );
+    is( My::Class->meta()->get_attribute('size')->foo(), 10,
+        '... call foo() on an attribute metaclass object' );
+}
+
+{
+    Moose::Util::MetaRole::apply_metaclass_roles(
+        for_class              => 'My::Class',
+        method_metaclass_roles => ['Role::Foo'],
+    );
+
+    ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'),
+        q{apply Role::Foo to My::Class->meta()'s method metaclass} );
+    ok( My::Class->meta()->meta()->does_role('Role::Foo'),
+        '... My::Class->meta() still does Role::Foo' );
+    ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'),
+        q{... My::Class->meta()'s attribute metaclass still does Role::Foo} );
+
+    My::Class->meta()->add_method( 'bar' => sub { 'bar' } );
+    is( My::Class->meta()->get_method('bar')->foo(), 10,
+        '... call foo() on a method metaclass object' );
+}
+
+{
+    Moose::Util::MetaRole::apply_metaclass_roles(
+        for_class              => 'My::Class',
+        instance_metaclass_roles => ['Role::Foo'],
+    );
+
+    ok( My::Class->meta()->instance_metaclass()->meta()->does_role('Role::Foo'),
+        q{apply Role::Foo to My::Class->meta()'s instance metaclass} );
+    ok( My::Class->meta()->meta()->does_role('Role::Foo'),
+        '... My::Class->meta() still does Role::Foo' );
+    ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'),
+        q{... My::Class->meta()'s attribute metaclass still does Role::Foo} );
+    ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'),
+        q{... My::Class->meta()'s method metaclass still does Role::Foo} );
+
+    is( My::Class->meta()->get_meta_instance()->foo(), 10,
+        '... call foo() on an instance metaclass object' );
+}
+
+{
+    Moose::Util::MetaRole::apply_metaclass_roles(
+        for_class               => 'My::Class',
+        constructor_class_roles => ['Role::Foo'],
+    );
+
+    ok( My::Class->meta()->constructor_class()->meta()->does_role('Role::Foo'),
+        q{apply Role::Foo to My::Class->meta()'s constructor class} );
+    ok( My::Class->meta()->meta()->does_role('Role::Foo'),
+        '... My::Class->meta() still does Role::Foo' );
+    ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'),
+        q{... My::Class->meta()'s attribute metaclass still does Role::Foo} );
+    ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'),
+        q{... My::Class->meta()'s method metaclass still does Role::Foo} );
+    ok( My::Class->meta()->instance_metaclass()->meta()->does_role('Role::Foo'),
+        q{... My::Class->meta()'s instance metaclass still does Role::Foo} );
+
+    # Actually instantiating the constructor class is too freaking hard!
+    ok( My::Class->meta()->constructor_class()->can('foo'),
+        '... constructor class has a foo method' );
+}
+
+{
+    Moose::Util::MetaRole::apply_metaclass_roles(
+        for_class              => 'My::Class',
+        destructor_class_roles => ['Role::Foo'],
+    );
+
+    ok( My::Class->meta()->destructor_class()->meta()->does_role('Role::Foo'),
+        q{apply Role::Foo to My::Class->meta()'s destructor class} );
+    ok( My::Class->meta()->meta()->does_role('Role::Foo'),
+        '... My::Class->meta() still does Role::Foo' );
+    ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'),
+        q{... My::Class->meta()'s attribute metaclass still does Role::Foo} );
+    ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'),
+        q{... My::Class->meta()'s method metaclass still does Role::Foo} );
+    ok( My::Class->meta()->instance_metaclass()->meta()->does_role('Role::Foo'),
+        q{... My::Class->meta()'s instance metaclass still does Role::Foo} );
+    ok( My::Class->meta()->constructor_class()->meta()->does_role('Role::Foo'),
+        q{... My::Class->meta()'s constructor class still does Role::Foo} );
+
+    # same problem as the constructor class
+    ok( My::Class->meta()->destructor_class()->can('foo'),
+        '... destructor class has a foo method' );
+}
+
+{
+    Moose::Util::MetaRole::apply_base_class_roles(
+        for_class => 'My::Class',
+        roles     => ['Role::Foo'],
+    );
+
+    ok( My::Class->meta()->does_role('Role::Foo'),
+        'apply Role::Foo to My::Class base class' );
+    is( My::Class->new()->foo(), 10,
+        '... call foo() on a My::Class object' );
+}
+
+{
+    package My::Class2;
+
+    use Moose;
+}
+
+{
+    Moose::Util::MetaRole::apply_metaclass_roles(
+        for_class                 => 'My::Class2',
+        metaclass_roles           => ['Role::Foo'],
+        attribute_metaclass_roles => ['Role::Foo'],
+        method_metaclass_roles    => ['Role::Foo'],
+        instance_metaclass_roles  => ['Role::Foo'],
+        constructor_class_roles   => ['Role::Foo'],
+        destructor_class_roles    => ['Role::Foo'],
+    );
+
+    ok( My::Class2->meta()->meta()->does_role('Role::Foo'),
+        'apply Role::Foo to My::Class2->meta()' );
+    is( My::Class2->meta()->foo(), 10,
+        '... and call foo() on that meta object' );
+    ok( My::Class2->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'),
+        q{apply Role::Foo to My::Class2->meta()'s attribute metaclass} );
+    My::Class2->meta()->add_attribute( 'size', is => 'ro' );
+
+    is( My::Class2->meta()->get_attribute('size')->foo(), 10,
+        '... call foo() on an attribute metaclass object' );
+
+    ok( My::Class2->meta()->method_metaclass()->meta()->does_role('Role::Foo'),
+        q{apply Role::Foo to My::Class2->meta()'s method metaclass} );
+
+    My::Class2->meta()->add_method( 'bar' => sub { 'bar' } );
+    is( My::Class2->meta()->get_method('bar')->foo(), 10,
+        '... call foo() on a method metaclass object' );
+
+    ok( My::Class2->meta()->instance_metaclass()->meta()->does_role('Role::Foo'),
+        q{apply Role::Foo to My::Class2->meta()'s instance metaclass} );
+    is( My::Class2->meta()->get_meta_instance()->foo(), 10,
+        '... call foo() on an instance metaclass object' );
+
+    ok( My::Class2->meta()->constructor_class()->meta()->does_role('Role::Foo'),
+        q{apply Role::Foo to My::Class2->meta()'s constructor class} );
+    ok( My::Class2->meta()->constructor_class()->can('foo'),
+        '... constructor class has a foo method' );
+
+    ok( My::Class2->meta()->destructor_class()->meta()->does_role('Role::Foo'),
+        q{apply Role::Foo to My::Class2->meta()'s destructor class} );
+    ok( My::Class2->meta()->destructor_class()->can('foo'),
+        '... destructor class has a foo method' );
+}
+
+
+{
+    package My::Meta;
+
+    use Moose::Exporter;
+    Moose::Exporter->setup_import_methods( also => 'Moose' );
+
+    sub init_meta {
+        shift;
+        my %p = @_;
+
+        Moose->init_meta( %p, metaclass => 'My::Meta::Class' );
+    }
+}
+
+{
+    package My::Class3;
+
+    My::Meta->import();
+}
+
+
+{
+    Moose::Util::MetaRole::apply_metaclass_roles(
+        for_class                 => 'My::Class3',
+        metaclass_roles           => ['Role::Foo'],
+    );
+
+    ok( My::Class3->meta()->meta()->does_role('Role::Foo'),
+        'apply Role::Foo to My::Class3->meta()' );
+    is( My::Class3->meta()->foo(), 10,
+        '... and call foo() on that meta object' );
+    ok( ( grep { $_ eq 'My::Meta::Class' } My::Class3->meta()->meta()->superclasses() ),
+        'apply_metaclass_roles() does not interfere with metaclass set via Moose->init_meta()' );
+}
diff --git a/t/050_metaclasses/016_metarole_w_metaclass_pm.t b/t/050_metaclasses/016_metarole_w_metaclass_pm.t
new file mode 100644
index 0000000..8b5f2a0
--- /dev/null
+++ b/t/050_metaclasses/016_metarole_w_metaclass_pm.t
@@ -0,0 +1,109 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More 'no_plan';
+
+use Moose::Util::MetaRole;
+
+BEGIN
+{
+    package My::Meta::Class;
+    use Moose;
+    extends 'Moose::Meta::Class';
+}
+
+BEGIN
+{
+    package My::Meta::Attribute;
+    use Moose;
+    extends 'Moose::Meta::Attribute';
+}
+
+BEGIN
+{
+    package My::Meta::Method;
+    use Moose;
+    extends 'Moose::Meta::Method';
+}
+
+BEGIN
+{
+    package My::Meta::Instance;
+    use Moose;
+    extends 'Moose::Meta::Instance';
+}
+
+BEGIN
+{
+    package Role::Foo;
+    use Moose::Role;
+    has 'foo' => ( is => 'ro', default => 10 );
+}
+
+{
+    package My::Class;
+
+    use metaclass 'My::Meta::Class';
+    use Moose;
+}
+
+{
+    package My::Class2;
+
+    use metaclass 'My::Meta::Class' => (
+        attribute_metaclass => 'My::Meta::Attribute',
+        method_metaclass    => 'My::Meta::Method',
+        instance_metaclass  => 'My::Meta::Instance',
+    );
+
+    use Moose;
+}
+
+{
+    Moose::Util::MetaRole::apply_metaclass_roles(
+        for_class       => 'My::Class',
+        metaclass_roles => ['Role::Foo'],
+    );
+
+    ok( My::Class->meta()->meta()->does_role('Role::Foo'),
+        'apply Role::Foo to My::Class->meta()' );
+    has_superclass( My::Class->meta(), 'My::Meta::Class',
+                    'apply_metaclass_roles works with metaclass.pm' );
+}
+
+{
+    Moose::Util::MetaRole::apply_metaclass_roles(
+        for_class                 => 'My::Class2',
+        attribute_metaclass_roles => ['Role::Foo'],
+        method_metaclass_roles    => ['Role::Foo'],
+        instance_metaclass_roles  => ['Role::Foo'],
+    );
+
+    ok( My::Class2->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'),
+        q{apply Role::Foo to My::Class2->meta()'s attribute metaclass} );
+    has_superclass( My::Class2->meta()->attribute_metaclass(), 'My::Meta::Attribute',
+                    '... and this does not interfere with attribute metaclass set via metaclass.pm' );
+    ok( My::Class2->meta()->method_metaclass()->meta()->does_role('Role::Foo'),
+        q{apply Role::Foo to My::Class2->meta()'s method metaclass} );
+    has_superclass( My::Class2->meta()->method_metaclass(), 'My::Meta::Method',
+                    '... and this does not interfere with method metaclass set via metaclass.pm' );
+    ok( My::Class2->meta()->instance_metaclass()->meta()->does_role('Role::Foo'),
+        q{apply Role::Foo to My::Class2->meta()'s instance metaclass} );
+    has_superclass( My::Class2->meta()->instance_metaclass(), 'My::Meta::Instance',
+                    '... and this does not interfere with instance metaclass set via metaclass.pm' );
+}
+
+# like isa_ok but works with a class name, not just refs
+sub has_superclass {
+    my $thing  = shift;
+    my $parent = shift;
+    my $desc   = shift;
+
+    my %supers = map { $_ => 1 } $thing->meta()->superclasses();
+
+    local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+    ok( $supers{$parent}, $desc );
+}