Moose::Meta::Role->create for dynamic role construction

diff --git a/Changes b/Changes
index 0cfe49a..e3a3175 100644 (file)
--- a/Changes
+++ b/Changes
@@ -15,6 +15,9 @@ Revision history for Perl extension Moose
       - Remove the make_immutable keyword, which has been
         deprecated since April. It breaks metaclasses that
         use Moose without no Moose (Sartak)
+    * Moose::Meta::Role
+      - create method for constructing a role
+        dynamically (Sartak)
 
 0.61 Fri November 7, 2008
     * Moose::Meta::Attribute

diff --git a/lib/Moose/Meta/Role.pm b/lib/Moose/Meta/Role.pm
index 1645921..59e8c39 100644 (file)
--- a/lib/Moose/Meta/Role.pm
+++ b/lib/Moose/Meta/Role.pm
@@ -6,6 +6,7 @@ use warnings;
 use metaclass;
 
 use Scalar::Util 'blessed';
+use Carp         'confess';
 
 our $VERSION   = '0.61';
 $VERSION = eval $VERSION;
@@ -474,6 +475,56 @@ sub combine {
     return $c;
 }
 
+sub create {
+    my ( $role, @args ) = @_;
+
+    unshift @args, 'package' if @args % 2 == 1;
+
+    my (%options) = @args;
+    my $package_name = $options{package};
+
+    (ref $options{attributes} eq 'HASH')
+        || confess "You must pass a HASH ref of attributes"
+            if exists $options{attributes};
+
+    (ref $options{methods} eq 'HASH')
+        || confess "You must pass a HASH ref of methods"
+            if exists $options{methods};
+
+    $role->SUPER::create(%options);
+
+    my (%initialize_options) = @args;
+    delete @initialize_options{qw(
+        package
+        attributes
+        methods
+        version
+        authority
+    )};
+
+    my $meta = $role->initialize( $package_name => %initialize_options );
+
+    # FIXME totally lame
+    $meta->add_method('meta' => sub {
+        $role->initialize(ref($_[0]) || $_[0]);
+    });
+
+    if (exists $options{attributes}) {
+        foreach my $attribute_name (keys %{$options{attributes}}) {
+            my $attr = $options{attributes}->{$attribute_name};
+            $meta->add_attribute($attribute_name => $attr);
+        }
+    }
+
+    if (exists $options{methods}) {
+        foreach my $method_name (keys %{$options{methods}}) {
+            $meta->add_method($method_name, $options{methods}->{$method_name});
+        }
+    }
+
+    return $meta;
+}
+
 #####################################################################
 ## NOTE:
 ## This is Moose::Meta::Role as defined by Moose (plus the use of 

diff --git a/t/030_roles/034_create_role.t b/t/030_roles/034_create_role.t
new file mode 100644 (file)
index 0000000..d57181f
--- /dev/null
+++ b/t/030_roles/034_create_role.t
@@ -0,0 +1,30 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 3;
+use Moose ();
+
+my $role = Moose::Meta::Role->create(
+    'package' => 'MyItem::Role::Equipment',
+    attributes => {
+        is_worn => {
+            is => 'rw',
+            isa => 'Bool',
+        },
+    },
+    methods => {
+        remove => sub { shift->is_worn(0) },
+    },
+);
+
+my $class = Moose::Meta::Class->create('MyItem::Armor::Helmet' =>
+    roles => ['MyItem::Role::Equipment'],
+);
+
+my $visored = $class->construct_instance(is_worn => 0);
+ok(!$visored->is_worn, "attribute, accessor was consumed");
+$visored->is_worn(1);
+ok($visored->is_worn, "accessor was consumed");
+$visored->remove;
+ok(!$visored->is_worn, "method was consumed");
+