Implement confliction checks in roles

[gitmo/Mouse.git] / lib / Mouse / Meta / Class.pm

diff --git a/lib/Mouse/Meta/Class.pm b/lib/Mouse/Meta/Class.pm
index 4a6adec..2689f85 100644 (file)
--- a/lib/Mouse/Meta/Class.pm
+++ b/lib/Mouse/Meta/Class.pm
@@ -9,6 +9,7 @@ use Mouse::Util qw/get_linear_isa not_supported/;
 
 use base qw(Mouse::Meta::Module);
 
+sub method_metaclass(){ 'Mouse::Meta::Method' } # required for get_method()
 
 sub _new {
     my($class, %args) = @_;
@@ -209,9 +210,8 @@ sub make_immutable {
 
 sub make_mutable { not_supported }
 
-sub is_immutable { $_[0]->{is_immutable} }
-
-sub attribute_metaclass { "Mouse::Meta::Class" }
+sub is_immutable {  $_[0]->{is_immutable} }
+sub is_mutable   { !$_[0]->{is_immutable} }
 
 sub _install_modifier {
     my ( $self, $into, $type, $name, $code ) = @_;
@@ -230,9 +230,8 @@ sub _install_modifier {
 
     # replace this method itself :)
     {
-        no strict 'refs';
         no warnings 'redefine';
-        *{__PACKAGE__ . '::_install_modifier'} = sub {
+        *_install_modifier = sub {
             my ( $self, $into, $type, $name, $code ) = @_;
             $modifier->(
                 $into,
@@ -240,6 +239,8 @@ sub _install_modifier {
                 $name,
                 $code
             );
+            $self->{methods}{$name}++; # register it to the method map
+            return;
         };
     }
 
@@ -265,16 +266,12 @@ sub add_after_method_modifier {
 sub add_override_method_modifier {
     my ($self, $name, $code) = @_;
 
-    my $pkg = $self->name;
-    my $method = "${pkg}::${name}";
+    my $package = $self->name;
 
-    # Class::Method::Modifiers won't do this for us, so do it ourselves
+    my $body = $package->can($name)
+        or $self->throw_error("You cannot override '$name' because it has no super method");
 
-    my $body = $pkg->can($name)
-        or $self->throw_error("You cannot override '$method' because it has no super method");
-
-    no strict 'refs';
-    *$method = sub { $code->($pkg, $body, @_) };
+    $self->add_method($name => sub { $code->($package, $body, @_) });
 }
 
 sub does_role {
@@ -284,10 +281,11 @@ sub does_role {
         || $self->throw_error("You must supply a role name to look for");
 
     for my $class ($self->linearized_isa) {
-        my $meta = Mouse::class_of($class);
+        my $meta = Mouse::Meta::Module::class_of($class);
         next unless $meta && $meta->can('roles');
 
         for my $role (@{ $meta->roles }) {
+
             return 1 if $role->does_role($role_name);
         }
     }
@@ -310,19 +308,19 @@ sub create {
         || $class->throw_error("You must pass a HASH ref of methods")
             if exists $options{methods};
 
-    do {
+    (ref $options{roles} eq 'ARRAY')
+        || $class->throw_error("You must pass an ARRAY ref of roles")
+            if exists $options{roles};
+
+    # instantiate a module
+    {
         ( defined $package_name && $package_name )
           || $class->throw_error("You must pass a package name");
 
-        my $code = "package $package_name;";
-        $code .= "\$$package_name\:\:VERSION = '" . $options{version} . "';"
-          if exists $options{version};
-        $code .= "\$$package_name\:\:AUTHORITY = '" . $options{authority} . "';"
-          if exists $options{authority};
-
-        eval $code;
-        $class->throw_error("creation of $package_name failed : $@") if $@;
-    };
+        no strict 'refs';
+        ${ $package_name . '::VERSION'   } = $options{version}   if exists $options{version};
+        ${ $package_name . '::AUTHORITY' } = $options{authority} if exists $options{authority};
+    }
 
     my %initialize_options = %options;
     delete @initialize_options{qw(
@@ -330,6 +328,7 @@ sub create {
         superclasses
         attributes
         methods
+        roles
         version
         authority
     )};
@@ -342,6 +341,7 @@ sub create {
 
     $meta->superclasses(@{$options{superclasses}})
         if exists $options{superclasses};
+
     # NOTE:
     # process attributes first, so that they can
     # install accessors, but locally defined methods
@@ -357,17 +357,67 @@ sub create {
             $meta->add_method($method_name, $options{methods}->{$method_name});
         }
     }
+    if (exists $options{roles}){
+        Mouse::Util::apply_all_roles($package_name, @{$options{roles}});
+    }
     return $meta;
 }
 
 {
     my $ANON_CLASS_SERIAL = 0;
     my $ANON_CLASS_PREFIX = 'Mouse::Meta::Class::__ANON__::SERIAL::';
+
+    my %IMMORTAL_ANON_CLASSES;
     sub create_anon_class {
         my ( $class, %options ) = @_;
+
+        my $cache = $options{cache};
+        my $cache_key;
+
+        if($cache){ # anonymous but not mortal
+                # something like Super::Class|Super::Class::2=Role|Role::1\r
+                $cache_key = join '=' => (\r
+                    join('|', @{$options{superclasses} || []}),\r
+                    join('|', sort @{$options{roles}   || []}),\r
+                );
+                return $IMMORTAL_ANON_CLASSES{$cache_key} if exists $IMMORTAL_ANON_CLASSES{$cache_key};
+        }
         my $package_name = $ANON_CLASS_PREFIX . ++$ANON_CLASS_SERIAL;
-        return $class->create( $package_name, %options );
+        my $meta = $class->create( $package_name, anon_class_id => $ANON_CLASS_SERIAL, %options );
+
+        if($cache){
+            $IMMORTAL_ANON_CLASSES{$cache_key} = $meta;
+        }
+        else{
+            Mouse::Meta::Module::weaken_metaclass($package_name);
+        }
+        return $meta;
+    }
+
+    sub is_anon_class{
+        return exists $_[0]->{anon_class_id};
+    }
+
+
+    sub DESTROY{
+        my($self) = @_;
+
+        my $serial_id = $self->{anon_class_id};
+
+        return if !$serial_id;
+
+        my $stash = $self->namespace;
+
+        @{$self->{sperclasses}} = ();
+        %{$stash} = ();
+        Mouse::Meta::Module::remove_metaclass_by_name($self->name);
+
+        no strict 'refs';
+        delete ${$ANON_CLASS_PREFIX}{ $serial_id . '::' };
+
+        return;
     }
+
 }
 
 1;