handle caching of anon classes better, when role/class params are used

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

diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm
index b3e95e4..52c9676 100644 (file)
--- a/lib/Moose/Meta/Class.pm
+++ b/lib/Moose/Meta/Class.pm
@@ -103,11 +103,50 @@ sub _anon_package_prefix { 'Moose::Meta::Class::__ANON__::SERIAL::' }
 sub _anon_cache_key {
     my $class = shift;
     my %options = @_;
-    # Makes something like Super::Class|Super::Class::2=Role|Role::1
-    return join '=' => (
-        join( '|', @{ $options{superclasses} || [] } ),
-        join( '|', sort @{ $options{roles}   || [] } ),
+
+    my $superclass_key = join('|',
+        map { $_->[0] } @{ Data::OptList::mkopt($options{superclasses} || []) }
     );
+
+    my $roles = Data::OptList::mkopt(($options{roles} || []), {
+        moniker  => 'role',
+        val_test => sub { ref($_[0]) eq 'HASH' },
+    });
+
+    my @role_keys;
+    for my $role_spec (@$roles) {
+        my ($role, $params) = @$role_spec;
+        $params = { %$params } if $params;
+
+        my $key = blessed($role) ? $role->name : $role;
+
+        if ($params && %$params) {
+            my $alias    = delete $params->{'-alias'}
+                        || delete $params->{'alias'}
+                        || {};
+            my $excludes = delete $params->{'-excludes'}
+                        || delete $params->{'excludes'}
+                        || [];
+            $excludes = [$excludes] unless ref($excludes) eq 'ARRAY';
+
+            if (%$params) {
+                warn "Roles with parameters cannot be cached. Consider "
+                   . "applying the parameters before calling "
+                   . "create_anon_class, or using 'weaken => 0' instead";
+                return;
+            }
+
+            $key .= '<' . join('+', 'a', join('%', %$alias),
+                                    'e', join('%', @$excludes)) . '>';
+        }
+
+        push @role_keys, $key;
+    }
+
+    my $role_key = join('|', @role_keys);
+
+    # Makes something like Super::Class|Super::Class::2=Role|Role::1
+    return join('=', $superclass_key, $role_key);
 }
 
 sub reinitialize {