X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FMeta%2FRole.pm;h=82adf76a178c11b69c30eb735794999471512720;hb=bf26e705ee212b31786d7d9a264830041936c3ba;hp=d9327710b351aa811b95eafc4c523b6578417f33;hpb=f5bc97e5bbde4f29f52d85ac7c03251665dfd52b;p=gitmo%2FMoose.git

diff --git a/lib/Moose/Meta/Role.pm b/lib/Moose/Meta/Role.pm
index d932771..82adf76 100644
--- a/lib/Moose/Meta/Role.pm
+++ b/lib/Moose/Meta/Role.pm
@@ -6,8 +6,9 @@ use warnings;
 use metaclass;
 
 use Scalar::Util 'blessed';
+use Carp         'confess';
 
-our $VERSION   = '0.60';
+our $VERSION   = '0.61';
 $VERSION = eval $VERSION;
 our $AUTHORITY = 'cpan:STEVAN';
 
@@ -368,7 +369,7 @@ sub has_method {
     exists $self->get_method_map->{$name} ? 1 : 0
 }
 
-# FIXME this is copypasated from Class::MOP::Class
+# FIXME this is copy-pasted from Class::MOP::Class
 # refactor to inherit from some common base
 sub wrap_method_body {
     my ( $self, %args ) = @_;
@@ -474,6 +475,119 @@ 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;
+}
+
+# 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