From: Shawn M Moore <sartak@gmail.com>
Date: Tue, 25 Nov 2008 06:04:58 +0000 (+0000)
Subject: First cut of anonymous roles!
X-Git-Tag: 0.62~20
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c9ee520d508bb6081415988e946c9ee6e78dc759;p=gitmo%2FMoose.git

First cut of anonymous roles!
---

diff --git a/Changes b/Changes
index e3a3175..2ccc252 100644
--- a/Changes
+++ b/Changes
@@ -18,6 +18,7 @@ Revision history for Perl extension Moose
     * Moose::Meta::Role
       - create method for constructing a role
         dynamically (Sartak)
+      - begin implementing anonymous roles (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 59e8c39..82adf76 100644
--- a/lib/Moose/Meta/Role.pm
+++ b/lib/Moose/Meta/Role.pm
@@ -525,6 +525,69 @@ sub create {
     return $meta;
 }
 
+# anonymous roles. most of it is copied straight out of Class::MOP::Class.
+# an intrepid hacker might find great riches if he unifies this code with that
+# code in Class::MOP::Module or Class::MOP::Package
+{
+    # NOTE:
+    # this should be sufficient, if you have a
+    # use case where it is not, write a test and
+    # I will change it.
+    my $ANON_ROLE_SERIAL = 0;
+
+    # NOTE:
+    # we need a sufficiently annoying prefix
+    # this should suffice for now, this is
+    # used in a couple of places below, so
+    # need to put it up here for now.
+    my $ANON_ROLE_PREFIX = 'Moose::Meta::Role::__ANON__::SERIAL::';
+
+    sub is_anon_role {
+        my $self = shift;
+        no warnings 'uninitialized';
+        $self->name =~ /^$ANON_ROLE_PREFIX/;
+    }
+
+    sub create_anon_role {
+        my ($role, %options) = @_;
+        my $package_name = $ANON_ROLE_PREFIX . ++$ANON_ROLE_SERIAL;
+        return $role->create($package_name, %options);
+    }
+
+    # NOTE:
+    # this will only get called for
+    # anon-roles, all other calls
+    # are assumed to occur during
+    # global destruction and so don't
+    # really need to be handled explicitly
+    sub DESTROY {
+        my $self = shift;
+
+        return if Class::MOP::in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated
+
+        no warnings 'uninitialized';
+        return unless $self->name =~ /^$ANON_ROLE_PREFIX/;
+
+        # XXX: is this necessary for us? I don't understand what it's doing
+        # -sartak
+
+        # Moose does a weird thing where it replaces the metaclass for
+        # class when fixing metaclass incompatibility. In that case,
+        # we don't want to clean out the namespace now. We can detect
+        # that because Moose will explicitly update the singleton
+        # cache in Class::MOP.
+        #my $current_meta = Class::MOP::get_metaclass_by_name($self->name);
+        #return if $current_meta ne $self;
+
+        my ($serial_id) = ($self->name =~ /^$ANON_ROLE_PREFIX(\d+)/);
+        no strict 'refs';
+        foreach my $key (keys %{$ANON_ROLE_PREFIX . $serial_id}) {
+            delete ${$ANON_ROLE_PREFIX . $serial_id}{$key};
+        }
+        delete ${'main::' . $ANON_ROLE_PREFIX}{$serial_id . '::'};
+    }
+}
+
 #####################################################################
 ## NOTE:
 ## This is Moose::Meta::Role as defined by Moose (plus the use of 
diff --git a/t/030_roles/035_anonymous_roles.t b/t/030_roles/035_anonymous_roles.t
new file mode 100644
index 0000000..911012a
--- /dev/null
+++ b/t/030_roles/035_anonymous_roles.t
@@ -0,0 +1,29 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 3;
+use Moose ();
+
+my $role = Moose::Meta::Role->create_anon_role(
+    attributes => {
+        is_worn => {
+            is => 'rw',
+            isa => 'Bool',
+        },
+    },
+    methods => {
+        remove => sub { shift->is_worn(0) },
+    },
+);
+
+my $class = Moose::Meta::Class->create('MyItem::Armor::Helmet');
+$role->apply($class);
+# XXX: Moose::Util::apply_all_roles doesn't cope with references yet
+
+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");
+