Runtime ROles

diff --git a/Changes b/Changes
index 4f5c417..1f8e02f 100644 (file)
--- a/Changes
+++ b/Changes
@@ -8,6 +8,11 @@ Revision history for Perl extension Moose
     * Moose::Cookbook
       - added a FAQ and WTF files to document frequently 
         asked questions and common problems
+        
+    * Moose::Meta::Role
+      - added basic support for runtime role composition
+        but this is still highly experimental
+        - added tests for this
 
     * Moose::Meta::TypeCoercion
       - properly capturing error when type constraint 

diff --git a/lib/Moose.pm b/lib/Moose.pm
index 1ddde47..89b9e61 100644 (file)
--- a/lib/Moose.pm
+++ b/lib/Moose.pm
@@ -207,6 +207,11 @@ use Moose::Util::TypeConstraints;
                 delete ${$class . '::'}{$name};
             }
         }
+        
+        # return a true value
+        # so that it can be used
+        # as a module end
+        1;
     }
 }
 

diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm
index 620d1c0..1d304a8 100644 (file)
--- a/lib/Moose/Meta/Attribute.pm
+++ b/lib/Moose/Meta/Attribute.pm
@@ -391,6 +391,10 @@ sub install_accessors {
             }
             else {
                 $associated_class->add_method($handle => sub {
+                    # FIXME
+                    # we should check for lack of 
+                    # a callable return value from 
+                    # the accessor here 
                     ((shift)->$accessor_name())->$method_to_call(@_);
                 });
             }

diff --git a/lib/Moose/Meta/Role.pm b/lib/Moose/Meta/Role.pm
index bfacbc4..51628ac 100644 (file)
--- a/lib/Moose/Meta/Role.pm
+++ b/lib/Moose/Meta/Role.pm
@@ -479,18 +479,38 @@ sub _apply_before_method_modifiers { (shift)->_apply_method_modifiers('before' =
 sub _apply_around_method_modifiers { (shift)->_apply_method_modifiers('around' => @_) }
 sub _apply_after_method_modifiers  { (shift)->_apply_method_modifiers('after'  => @_) }
 
+my $anon_counter = 0;
+
 sub apply {
     my ($self, $other) = @_;
     
-    ($other->isa('Moose::Meta::Class') || $other->isa('Moose::Meta::Role'))
-        || confess "You must apply a role to a metaclass, not ($other)";
+    unless ($other->isa('Moose::Meta::Class') || $other->isa('Moose::Meta::Role')) {
+    
+        # Runtime Role mixins
+            
+        # FIXME:
+        # We really should do this better, and 
+        # cache the results of our efforts so 
+        # that we don't need to repeat them.
+        
+        my $pkg_name = __PACKAGE__ . "::__RUNTIME_ROLE_ANON_CLASS__::" . $anon_counter++;
+        eval "package " . $pkg_name . "; our \$VERSION = '0.00';";
+        die $@ if $@;
+
+        my $object = $other;
+
+        $other = Moose::Meta::Class->initialize($pkg_name);
+        $other->superclasses(blessed($object));     
+        
+        bless $object => $pkg_name;
+    }
     
     $self->_check_excluded_roles($other);
     $self->_check_required_methods($other);  
 
     $self->_apply_attributes($other);         
     $self->_apply_methods($other);   
-    
+
     $self->_apply_override_method_modifiers($other);                  
     $self->_apply_before_method_modifiers($other);                  
     $self->_apply_around_method_modifiers($other);                  
@@ -499,8 +519,6 @@ sub apply {
     $other->add_role($self);
 }
 
-my $anon_counter = 0;
-
 sub combine {
     my ($class, @roles) = @_;
     

diff --git a/t/049_run_time_role_composition.t b/t/049_run_time_role_composition.t
index 83da531..818b88e 100644 (file)
--- a/t/049_run_time_role_composition.t
+++ b/t/049_run_time_role_composition.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 1;
+use Test::More tests => 20;
 
 use Scalar::Util qw(blessed);
 
@@ -18,6 +18,8 @@ Apparently it is not as simple as just making an anon class. One of
 the problems is the way that anon classes are DESTROY-ed, which is
 not very compatible with how instances are dealt with.
 
+=cut
+
 {
     package Bark;
     use Moose::Role;
@@ -51,7 +53,7 @@ ok(!$obj->can( 'talk' ), "... the role is not composed yet");
     ok(!My::Class->does('Bark'), '... the class does not do the Bark role');    
 
     isa_ok($obj, 'My::Class');
-    isnt(blessed($obj), 'My::Class', '... but it is not longer blessed into My::Class');
+    isnt(blessed($obj), 'My::Class', '... but it is no longer blessed into My::Class');
 
     ok(!My::Class->can('talk'), "... the role is not composed at the class level");
     ok($obj->can('talk'), "... the role is now composed at the object level");
@@ -62,7 +64,7 @@ ok(!$obj->can( 'talk' ), "... the role is not composed yet");
 {
     is($obj->sleep, 'nite-nite', '... the original method responds as expected');
 
-    ok(!$obj->does('Bark'), '... we do not do the Sleeper role');
+    ok(!$obj->does('Sleeper'), '... we do not do the Sleeper role');
 
     Sleeper->meta->apply($obj);
 
@@ -78,5 +80,3 @@ ok(!$obj->can( 'talk' ), "... the role is not composed yet");
     is($obj->sleep, 'snore', '... got the right return value for the newly composed method');
     is($obj->talk, 'zzz', '... got the right return value for the newly composed method');    
 }
-
-=cut