From: Jesse Luehrs <doy@tozt.net>
Date: Mon, 18 Apr 2011 00:11:28 +0000 (-0500)
Subject: unify the anon package stuff in CMOP::Package
X-Git-Tag: 2.0001~21
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=790ae571d0607d34a50edbca5f55c1a5ce4643c2;p=gitmo%2FMoose.git

unify the anon package stuff in CMOP::Package
---

diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index 8a97606..8aa4170 100644
--- a/lib/Class/MOP/Class.pm
+++ b/lib/Class/MOP/Class.pm
@@ -13,7 +13,6 @@ use Class::MOP::MiniTrait;
 use Carp         'confess';
 use Scalar::Util 'blessed', 'reftype', 'weaken';
 use Sub::Name    'subname';
-use Devel::GlobalDestruction 'in_global_destruction';
 use Try::Tiny;
 use List::MoreUtils 'all';
 
@@ -408,131 +407,75 @@ sub _remove_generated_metaobjects {
     }
 }
 
-## ANON classes
-
-{
-    # 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_CLASS_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_CLASS_PREFIX = 'Class::MOP::Class::__ANON__::SERIAL::';
-
-    sub is_anon_class {
-        my $self = shift;
-        no warnings 'uninitialized';
-        $self->name =~ /^$ANON_CLASS_PREFIX/o;
-    }
-
-    sub create_anon_class {
-        my ($class, %options) = @_;
-        $options{weaken} = 1 unless exists $options{weaken};
-        my $package_name = $ANON_CLASS_PREFIX . ++$ANON_CLASS_SERIAL;
-        return $class->create($package_name, %options);
-    }
-
-    sub DESTROY {
-        my $self = shift;
-
-        return if in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated
-
-        $self->free_anon_class
-            if $self->is_anon_class;
-    }
-
-    sub free_anon_class {
-        my $self = shift;
-        my $name = $self->name;
-
-        # 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.
-        no warnings 'uninitialized';
-        my $current_meta = Class::MOP::get_metaclass_by_name($name);
-        return if $current_meta ne $self;
-
-        my ($first_fragments, $last_fragment) = ($name =~ /^(.*)::(.*)$/);
-
-        no strict 'refs';
-        @{$name . '::ISA'} = ();
-        %{$name . '::'}    = ();
-        delete ${$first_fragments . '::'}{$last_fragment . '::'};
-
-        Class::MOP::remove_metaclass_by_name($name);
-    }
-
-}
-
 # creating classes with MOP ...
 
 sub create {
-    my ( $class, @args ) = @_;
+    my $class = shift;
+    my @args = @_;
 
     unshift @args, 'package' if @args % 2 == 1;
-
-    my (%options) = @args;
-    my $package_name = $options{package};
+    my %options = @args;
 
     (ref $options{superclasses} eq 'ARRAY')
         || confess "You must pass an ARRAY ref of superclasses"
             if exists $options{superclasses};
-            
+
     (ref $options{attributes} eq 'ARRAY')
         || confess "You must pass an ARRAY ref of attributes"
-            if exists $options{attributes};      
-            
+            if exists $options{attributes};
+
     (ref $options{methods} eq 'HASH')
         || confess "You must pass a HASH ref of methods"
-            if exists $options{methods};                  
-
-    $options{meta_name} = 'meta'
-        unless exists $options{meta_name};
-
-    my (%initialize_options) = @args;
-    delete @initialize_options{qw(
-        package
-        superclasses
-        attributes
-        methods
-        meta_name
-        version
-        authority
-    )};
-    my $meta = $class->initialize( $package_name => %initialize_options );
-
-    $meta->_instantiate_module( $options{version}, $options{authority} );
-
-    $meta->_add_meta_method($options{meta_name})
-        if defined $options{meta_name};
-
-    $meta->superclasses(@{$options{superclasses}})
-        if exists $options{superclasses};
+            if exists $options{methods};
+
+    my $package      = delete $options{package};
+    my $superclasses = delete $options{superclasses};
+    my $attributes   = delete $options{attributes};
+    my $methods      = delete $options{methods};
+    my $meta_name    = exists $options{meta_name}
+                         ? delete $options{meta_name}
+                         : 'meta';
+
+    my $meta = $class->SUPER::create($package => %options);
+
+    $meta->_add_meta_method($meta_name)
+        if defined $meta_name;
+
+    $meta->superclasses(@{$superclasses})
+        if defined $superclasses;
     # NOTE:
     # process attributes first, so that they can
     # install accessors, but locally defined methods
     # can then overwrite them. It is maybe a little odd, but
     # I think this should be the order of things.
-    if (exists $options{attributes}) {
-        foreach my $attr (@{$options{attributes}}) {
+    if (defined $attributes) {
+        foreach my $attr (@{$attributes}) {
             $meta->add_attribute($attr);
         }
     }
-    if (exists $options{methods}) {
-        foreach my $method_name (keys %{$options{methods}}) {
-            $meta->add_method($method_name, $options{methods}->{$method_name});
+    if (defined $methods) {
+        foreach my $method_name (keys %{$methods}) {
+            $meta->add_method($method_name, $methods->{$method_name});
         }
     }
     return $meta;
 }
 
+# XXX: something more intelligent here?
+sub _anon_package_prefix { 'Class::MOP::Class::__ANON__::SERIAL::' }
+
+sub create_anon_class { shift->create_anon(@_) }
+sub is_anon_class     { shift->is_anon(@_)     }
+
+sub _anon_cache_key {
+    my $class = shift;
+    my %options = @_;
+    # Makes something like Super::Class|Super::Class::2
+    return join '=' => (
+        join( '|', sort @{ $options{superclasses} || [] } ),
+    );
+}
+
 # Instance Construction & Cloning
 
 sub new_object {
@@ -2190,13 +2133,4 @@ metaclass.
 
 =back
 
-=head2 Destruction
-
-=over 4
-
-=item B<< $metaclass->free_anon_class >>
-
-This removes the metaclass from the symbol table and L<Class::MOP>'s own
-bookkeeping. This should probably only be called by L</DESTROY>.
-
 =cut
diff --git a/lib/Class/MOP/Module.pm b/lib/Class/MOP/Module.pm
index 4142dfc..0dd274d 100644
--- a/lib/Class/MOP/Module.pm
+++ b/lib/Class/MOP/Module.pm
@@ -49,9 +49,27 @@ sub identifier {
 }
 
 sub create {
-    confess "The Class::MOP::Module->create method has been made a private object method.\n";
+    my $class = shift;
+    my @args = @_;
+
+    unshift @args, 'package' if @args % 2 == 1;
+    my %options = @args;
+
+    my $package   = delete $options{package};
+    my $version   = delete $options{version};
+    my $authority = delete $options{authority};
+
+    my $meta = $class->SUPER::create($package => %options);
+
+    $meta->_instantiate_module($version, $authority);
+
+    return $meta;
 }
 
+sub _anon_package_prefix { 'Class::MOP::Module::__ANON__::SERIAL::' }
+sub _anon_cache_key      { confess "Modules are not cacheable" }
+
+
 sub _instantiate_module {
     my($self, $version, $authority) = @_;
     my $package_name = $self->name;
diff --git a/lib/Class/MOP/Package.pm b/lib/Class/MOP/Package.pm
index f24f9d2..bc5c6ca 100644
--- a/lib/Class/MOP/Package.pm
+++ b/lib/Class/MOP/Package.pm
@@ -4,8 +4,9 @@ package Class::MOP::Package;
 use strict;
 use warnings;
 
-use Scalar::Util 'blessed', 'reftype';
+use Scalar::Util 'blessed', 'reftype', 'weaken';
 use Carp         'confess';
+use Devel::GlobalDestruction 'in_global_destruction';
 use Package::Stash;
 
 use base 'Class::MOP::Object';
@@ -18,7 +19,7 @@ sub initialize {
     unshift @args, "package" if @args % 2;
 
     my %options = @args;
-    my $package_name = $options{package};
+    my $package_name = delete $options{package};
 
 
     # we hand-construct the class 
@@ -32,6 +33,9 @@ sub initialize {
         });
         Class::MOP::store_metaclass_by_name($package_name, $meta);
 
+        Class::MOP::weaken_metaclass($package_name) if $options{weaken};
+
+
         return $meta;
     }
 }
@@ -56,6 +60,99 @@ sub reinitialize {
     $class->initialize($package_name, %options); # call with first arg form for compat
 }
 
+sub create {
+    my $class = shift;
+    my @args = @_;
+
+    return $class->initialize(@args);
+}
+
+## ANON packages
+
+{
+    # 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_SERIAL = 0;
+
+    my %ANON_PACKAGE_CACHE;
+
+    # 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.
+    sub _anon_package_prefix { 'Class::MOP::Package::__ANON__::SERIAL::' }
+
+    sub is_anon {
+        my $self = shift;
+        no warnings 'uninitialized';
+        my $prefix = $self->_anon_package_prefix;
+        $self->name =~ /^$prefix/;
+    }
+
+    sub create_anon {
+        my ($class, %options) = @_;
+
+        my $cache_ok = delete $options{cache};
+
+        my $cache_key = $class->_anon_cache_key(%options);
+
+        if ($cache_ok && defined $ANON_PACKAGE_CACHE{$cache_key}) {
+            return $ANON_PACKAGE_CACHE{$cache_key};
+        }
+
+        $options{weaken} = !$cache_ok unless exists $options{weaken};
+
+        my $package_name = $class->_anon_package_prefix . ++$ANON_SERIAL;
+
+        my $meta = $class->create($package_name, %options);
+
+        if ($cache_ok) {
+            $ANON_PACKAGE_CACHE{$cache_key} = $meta;
+            weaken($ANON_PACKAGE_CACHE{$cache_key});
+        }
+
+        return $meta;
+    }
+
+    sub _anon_cache_key { confess "Packages are not cacheable" }
+
+    sub DESTROY {
+        my $self = shift;
+
+        return if in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated
+
+        $self->_free_anon
+            if $self->is_anon;
+    }
+
+    sub _free_anon {
+        my $self = shift;
+        my $name = $self->name;
+
+        # 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.
+        no warnings 'uninitialized';
+        my $current_meta = Class::MOP::get_metaclass_by_name($name);
+        return if $current_meta ne $self;
+
+        my ($first_fragments, $last_fragment) = ($name =~ /^(.*)::(.*)$/);
+
+        no strict 'refs';
+        @{$name . '::ISA'} = ();
+        %{$name . '::'}    = ();
+        delete ${$first_fragments . '::'}{$last_fragment . '::'};
+
+        Class::MOP::remove_metaclass_by_name($name);
+    }
+
+}
+
 sub _new {
     my $class = shift;
 
diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm
index 07f5e7e..b3e95e4 100644
--- a/lib/Moose/Meta/Class.pm
+++ b/lib/Moose/Meta/Class.pm
@@ -10,7 +10,7 @@ use Carp qw( confess );
 use Data::OptList;
 use List::Util qw( first );
 use List::MoreUtils qw( any all uniq first_index );
-use Scalar::Util 'weaken', 'blessed';
+use Scalar::Util 'blessed';
 
 use Moose::Meta::Method::Overridden;
 use Moose::Meta::Method::Augmented;
@@ -60,25 +60,34 @@ __PACKAGE__->meta->add_attribute('error_class' => (
 
 sub initialize {
     my $class = shift;
-    my $pkg   = shift;
-    return Class::MOP::get_metaclass_by_name($pkg)
-        || $class->SUPER::initialize($pkg,
+    my @args = @_;
+    unshift @args, 'package' if @args % 2;
+    my %opts = @args;
+    my $package = delete $opts{package};
+    return Class::MOP::get_metaclass_by_name($package)
+        || $class->SUPER::initialize($package,
                 'attribute_metaclass' => 'Moose::Meta::Attribute',
                 'method_metaclass'    => 'Moose::Meta::Method',
                 'instance_metaclass'  => 'Moose::Meta::Instance',
-                @_
+                %opts,
             );
 }
 
 sub create {
-    my ($class, $package_name, %options) = @_;
+    my $class = shift;
+    my @args = @_;
+
+    unshift @args, 'package' if @args % 2 == 1;
+    my %options = @args;
 
     (ref $options{roles} eq 'ARRAY')
         || $class->throw_error("You must pass an ARRAY ref of roles", data => $options{roles})
             if exists $options{roles};
-    my $roles = delete $options{roles};
 
-    my $new_meta = $class->SUPER::create($package_name, %options);
+    my $package = delete $options{package};
+    my $roles   = delete $options{roles};
+
+    my $new_meta = $class->SUPER::create($package, %options);
 
     if ($roles) {
         Moose::Util::apply_all_roles( $new_meta, @$roles );
@@ -87,40 +96,17 @@ sub create {
     return $new_meta;
 }
 
-my %ANON_CLASSES;
-
-sub create_anon_class {
-    my ($self, %options) = @_;
-
-    my $cache_ok = delete $options{cache};
-
-    my $cache_key
-        = _anon_cache_key( $options{superclasses}, $options{roles} );
-
-    if ($cache_ok && defined $ANON_CLASSES{$cache_key}) {
-        return $ANON_CLASSES{$cache_key};
-    }
-
-    $options{weaken} = !$cache_ok
-        unless exists $options{weaken};
-
-    my $new_class = $self->SUPER::create_anon_class(%options);
-
-    if ($cache_ok) {
-        $ANON_CLASSES{$cache_key} = $new_class;
-        weaken($ANON_CLASSES{$cache_key});
-    }
-
-    return $new_class;
-}
-
 sub _meta_method_class { 'Moose::Meta::Method::Meta' }
 
+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( '|', @{ $_[0]      || [] } ),
-        join( '|', sort @{ $_[1] || [] } ),
+        join( '|', @{ $options{superclasses} || [] } ),
+        join( '|', sort @{ $options{roles}   || [] } ),
     );
 }
 
@@ -130,8 +116,6 @@ sub reinitialize {
 
     my $meta = blessed $pkg ? $pkg : Class::MOP::class_of($pkg);
 
-    my $cache_key;
-
     my %existing_classes;
     if ($meta) {
         %existing_classes = map { $_ => $meta->$_() } qw(
@@ -143,31 +127,13 @@ sub reinitialize {
             destructor_class
             error_class
         );
-
-        $cache_key = _anon_cache_key(
-            [ $meta->superclasses ],
-            [ map { $_->name } @{ $meta->roles } ],
-        ) if $meta->is_anon_class;
     }
 
-    my $new_meta = $self->SUPER::reinitialize(
+    return $self->SUPER::reinitialize(
         $pkg,
         %existing_classes,
         @_,
     );
-
-    return $new_meta unless defined $cache_key;
-
-    my $new_cache_key = _anon_cache_key(
-        [ $meta->superclasses ],
-        [ map { $_->name } @{ $meta->roles } ],
-    );
-
-    delete $ANON_CLASSES{$cache_key};
-    $ANON_CLASSES{$new_cache_key} = $new_meta;
-    weaken($ANON_CLASSES{$new_cache_key});
-
-    return $new_meta;
 }
 
 sub add_role {
diff --git a/lib/Moose/Meta/Role.pm b/lib/Moose/Meta/Role.pm
index 28ea3cf..2ee6d1f 100644
--- a/lib/Moose/Meta/Role.pm
+++ b/lib/Moose/Meta/Role.pm
@@ -162,23 +162,15 @@ $META->add_attribute(
 # More or less copied from Moose::Meta::Class
 sub initialize {
     my $class = shift;
-    my $pkg   = shift;
-
-    if (defined(my $meta = Class::MOP::get_metaclass_by_name($pkg))) {
-        return $meta;
-    }
-
-    my %options = @_;
-
-    my $meta = $class->SUPER::initialize(
-        $pkg,
-        'attribute_metaclass' => 'Moose::Meta::Role::Attribute',
-        %options,
-    );
-
-    Class::MOP::weaken_metaclass($pkg) if $options{weaken};
-
-    return $meta;
+    my @args = @_;
+    unshift @args, 'package' if @args % 2;
+    my %opts = @args;
+    my $package = delete $opts{package};
+    return Class::MOP::get_metaclass_by_name($package)
+        || $class->SUPER::initialize($package,
+                'attribute_metaclass' => 'Moose::Meta::Role::Attribute',
+                %opts,
+            );
 }
 
 sub reinitialize {
@@ -516,9 +508,11 @@ sub _role_for_combination {
 }
 
 sub create {
-    my ( $role, $package_name, %options ) = @_;
+    my $class = shift;
+    my @args = @_;
 
-    $options{package} = $package_name;
+    unshift @args, 'package' if @args % 2 == 1;
+    my %options = @args;
 
     (ref $options{attributes} eq 'HASH')
         || confess "You must pass a HASH ref of attributes"
@@ -528,37 +522,29 @@ sub create {
         || confess "You must pass a HASH ref of methods"
             if exists $options{methods};
 
-    $options{meta_name} = 'meta'
-        unless exists $options{meta_name};
-
-    my (%initialize_options) = %options;
-    delete @initialize_options{qw(
-        package
-        attributes
-        methods
-        meta_name
-        version
-        authority
-    )};
-
-    my $meta = $role->initialize( $package_name => %initialize_options );
+    my $package      = delete $options{package};
+    my $attributes   = delete $options{attributes};
+    my $methods      = delete $options{methods};
+    my $meta_name    = exists $options{meta_name}
+                         ? delete $options{meta_name}
+                         : 'meta';
 
-    $meta->_instantiate_module( $options{version}, $options{authority} );
+    my $meta = $class->SUPER::create($package => %options);
 
-    $meta->_add_meta_method($options{meta_name})
-        if defined $options{meta_name};
+    $meta->_add_meta_method($meta_name)
+        if defined $meta_name;
 
-    if (exists $options{attributes}) {
-        foreach my $attribute_name (keys %{$options{attributes}}) {
-            my $attr = $options{attributes}->{$attribute_name};
+    if (defined $attributes) {
+        foreach my $attribute_name (keys %{$attributes}) {
+            my $attr = $attributes->{$attribute_name};
             $meta->add_attribute(
                 $attribute_name => blessed $attr ? $attr : %{$attr} );
         }
     }
 
-    if (exists $options{methods}) {
-        foreach my $method_name (keys %{$options{methods}}) {
-            $meta->add_method($method_name, $options{methods}->{$method_name});
+    if (defined $methods) {
+        foreach my $method_name (keys %{$methods}) {
+            $meta->add_method($method_name, $methods->{$method_name});
         }
     }
 
@@ -578,66 +564,19 @@ sub consumers {
     return @consumers;
 }
 
-# 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;
+# XXX: something more intelligent here?
+sub _anon_package_prefix { 'Moose::Meta::Role::__ANON__::SERIAL::' }
 
-    # 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 { shift->create_anon(@_) }
+sub is_anon_role     { shift->is_anon(@_)     }
 
-    sub create_anon_role {
-        my ($role, %options) = @_;
-        $options{weaken} = 1 unless exists $options{weaken};
-        my $package_name = $ANON_ROLE_PREFIX . ++$ANON_ROLE_SERIAL;
-        return $role->create($package_name, %options);
-    }
-
-    sub DESTROY {
-        my $self = shift;
-
-        return if in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated
-
-        $self->free_anon_role
-            if $self->is_anon_role;
-    }
-
-    sub free_anon_role {
-        my $self = shift;
-        my $name = $self->name;
-
-        my ($first_fragments, $last_fragment) = ($name =~ /^(.*)::(.*)$/);
-
-        # 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;
-
-        no strict 'refs';
-        @{$name . '::ISA'} = ();
-        %{$name . '::'}    = ();
-        delete ${$first_fragments . '::'}{$last_fragment . '::'};
-
-        Class::MOP::remove_metaclass_by_name($name);
-    }
+sub _anon_cache_key {
+    my $class = shift;
+    my %options = @_;
+    # Makes something like Role|Role::1
+    return join '=' => (
+        join( '|', sort @{ $options{roles} || [] } ),
+    );
 }
 
 #####################################################################
@@ -1012,15 +951,6 @@ This will return a L<Class::MOP::Class> instance for this class.
 
 =back
 
-=head2 Destruction
-
-=over 4
-
-=item B<< $metarole->free_anon_role >>
-
-This removes the metarole from the symbol table and L<Moose>'s own
-bookkeeping. This should probably only be called by L</DESTROY>.
-
 =head1 BUGS
 
 See L<Moose/BUGS> for details on reporting bugs.
diff --git a/t/cmop/self_introspection.t b/t/cmop/self_introspection.t
index 6192ba1..e6d00f6 100644
--- a/t/cmop/self_introspection.t
+++ b/t/cmop/self_introspection.t
@@ -26,7 +26,8 @@ isa_ok($class_mop_module_meta, 'Class::MOP::Module');
 my @class_mop_package_methods = qw(
     _new
 
-    initialize reinitialize
+    initialize reinitialize create create_anon is_anon
+    _free_anon _anon_cache_key _anon_package_prefix
 
     name
     namespace
@@ -38,6 +39,8 @@ my @class_mop_package_methods = qw(
     _package_stash
 
     get_method_map
+
+    DESTROY
 );
 
 my @class_mop_module_methods = qw(
@@ -46,6 +49,8 @@ my @class_mop_module_methods = qw(
     _instantiate_module
 
     version authority identifier create
+
+    _anon_cache_key _anon_package_prefix
 );
 
 my @class_mop_class_methods = qw(
@@ -55,7 +60,8 @@ my @class_mop_class_methods = qw(
 
     initialize reinitialize create
 
-    create_anon_class is_anon_class free_anon_class
+    create_anon_class is_anon_class
+    _anon_cache_key _anon_package_prefix
 
     instance_metaclass get_meta_instance
     _inline_create_instance
@@ -115,8 +121,6 @@ my @class_mop_class_methods = qw(
     _immutable_metaclass
     immutable_trait immutable_options
     constructor_name constructor_class destructor_class
-
-    DESTROY
 );
 
 # check the class ...