From: Dave Rolsky <autarch@urth.org>
Date: Mon, 28 Jul 2008 01:56:31 +0000 (+0000)
Subject: First stab at applying traits to a metaclass via:
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f3d297ad09726cef0c12c43ae85dbcc0cf7251a2;p=gitmo%2FMoose.git

First stab at applying traits to a metaclass via:

 use Moose -traits => [ 'Foo' ]

So far it is tested for applying a single trait to a metaclass (and it
actually works).
---

diff --git a/lib/Moose.pm b/lib/Moose.pm
index ecc8801..27e204e 100644
--- a/lib/Moose.pm
+++ b/lib/Moose.pm
@@ -10,6 +10,7 @@ our $AUTHORITY = 'cpan:STEVAN';
 use Scalar::Util 'blessed';
 use Carp         'confess', 'croak', 'cluck';
 
+use List::MoreUtils qw( first_index );
 use Sub::Exporter;
 
 use Class::MOP;
@@ -190,6 +191,20 @@ use Moose::Util ();
         }
     );
 
+    sub _strip_traits {
+        my $at = shift;
+
+        my $idx = first_index { $_ eq '-traits' } @{ $at };
+
+        return unless $idx && $#{ $at } >= $idx + 1;
+
+        my $traits = $at->[ $idx + 1 ];
+
+        splice @{ $at }, $idx, 2;
+
+        return $traits;
+    }
+
     # 1 extra level because it's called by import so there's a layer of indirection
     sub _get_caller{
         my $offset = 1;
@@ -201,7 +216,20 @@ use Moose::Util ();
                     : caller($offset);
     }
 
+    sub _apply_meta_traits {
+        my ( $class, $traits ) = @_;
+
+        return
+            unless $traits && @{ $traits };
+
+        for my $trait ( @{ $traits } ) {
+            $trait->meta()->apply_to_metaclass_instance( $class->meta() );
+        }
+    }
+
     sub import {
+        my $traits = _strip_traits(\@_);
+
         $CALLER = _get_caller(@_);
 
         # this works because both pragmas set $^H (see perldoc perlvar)
@@ -217,6 +245,8 @@ use Moose::Util ();
 
         init_meta( $CALLER, 'Moose::Object' );
 
+        _apply_meta_traits( $CALLER, $traits );
+
         goto $exporter;
     }
     
diff --git a/lib/Moose/Meta/Role.pm b/lib/Moose/Meta/Role.pm
index 6129dc7..f63e218 100644
--- a/lib/Moose/Meta/Role.pm
+++ b/lib/Moose/Meta/Role.pm
@@ -390,6 +390,16 @@ sub apply {
     }  
 }
 
+sub apply_to_metaclass_instance {
+    my ($self, $meta, @args) = @_;
+
+    $meta->isa('Moose::Meta::Class')
+        || confess "You must pass in a Moose::Meta::Class instance";
+
+    require Moose::Meta::Role::Application::ToMetaclassInstance;
+    return Moose::Meta::Role::Application::ToMetaclassInstance->new(@args)->apply($self, $meta);
+}
+
 sub combine {
     my ($class, @role_specs) = @_;
     
@@ -560,6 +570,8 @@ probably not that much really).
 
 =item B<apply>
 
+=item B<apply_to_metaclass_instance>
+
 =item B<combine>
 
 =back
diff --git a/lib/Moose/Meta/Role/Application/ToMetaclassInstance.pm b/lib/Moose/Meta/Role/Application/ToMetaclassInstance.pm
new file mode 100644
index 0000000..0abe3e1
--- /dev/null
+++ b/lib/Moose/Meta/Role/Application/ToMetaclassInstance.pm
@@ -0,0 +1,79 @@
+package Moose::Meta::Role::Application::ToMetaclassInstance;
+
+use strict;
+use warnings;
+use metaclass;
+
+use Scalar::Util 'blessed';
+
+our $VERSION   = '0.55';
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Moose::Meta::Role::Application::ToClass';
+
+__PACKAGE__->meta->add_attribute('rebless_params' => (
+    reader  => 'rebless_params',
+    default => sub { {} }
+));
+
+my %ANON_CLASSES;
+
+sub apply {
+    my ($self, $role, $meta) = @_;
+
+    my $class = (blessed $meta)->create_anon_class(
+        superclasses => [ blessed($meta) ]
+    );
+
+    $self->SUPER::apply($role, $class);
+
+    $class->rebless_instance($meta, %{$self->rebless_params});
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Moose::Meta::Role::Application::ToInstance - Compose a role into an instance
+
+=head1 DESCRIPTION
+
+=head2 METHODS
+
+=over 4
+
+=item B<new>
+
+=item B<meta>
+
+=item B<apply>
+
+=item B<rebless_params>
+
+=back
+
+=head1 BUGS
+
+All complex software has bugs lurking in it, and this module is no
+exception. If you find a bug please either email me, or add the bug
+to cpan-RT.
+
+=head1 AUTHOR
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006-2008 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
diff --git a/t/050_metaclasses/012_metaclass_traits.t b/t/050_metaclasses/012_metaclass_traits.t
new file mode 100644
index 0000000..505ffbe
--- /dev/null
+++ b/t/050_metaclasses/012_metaclass_traits.t
@@ -0,0 +1,54 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 6;
+
+{
+    package My::SimpleTrait;
+
+    use Moose::Role;
+
+    sub simple { return 5 }
+}
+
+{
+    package Foo;
+
+    use Moose -traits => [ 'My::SimpleTrait' ];
+}
+
+can_ok( Foo->meta(), 'simple' );
+is( Foo->meta()->simple(), 5,
+    'Foo->meta()->simple() returns expected value' );
+
+{
+    package My::SimpleTrait2;
+
+    use Moose::Role;
+
+    # This needs to happen at begin time so it happens before we apply
+    # traits to Bar
+    BEGIN {
+        has 'attr' =>
+            ( is      => 'ro',
+              default => 'something',
+            );
+    }
+
+    sub simple { return 5 }
+}
+
+{
+    package Bar;
+
+    use Moose -traits => [ 'My::SimpleTrait2' ];
+}
+
+can_ok( Bar->meta(), 'simple' );
+is( Bar->meta()->simple(), 5,
+    'Bar->meta()->simple() returns expected value' );
+can_ok( Bar->meta(), 'attr' );
+is( Bar->meta()->attr(), 'something',
+    'Bar->meta()->attr() returns expected value' );