From: nperez <nperez@cpan.org>
Date: Thu, 13 Aug 2009 20:46:27 +0000 (-0500)
Subject: move some anonymous class functionality further up the food chain and split out how... 
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=refs%2Fheads%2Fabandoned%2Frefactor_anonymous_classes;p=gitmo%2FClass-MOP.git

move some anonymous class functionality further up the food chain and split out how anonymous class names are derived
---

diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm
index 5a16bff..3c9494f 100644
--- a/lib/Class/MOP.pm
+++ b/lib/Class/MOP.pm
@@ -207,6 +207,18 @@ Class::MOP::Package->meta->add_attribute(
 );
 
 Class::MOP::Package->meta->add_attribute(
+    Class::MOP::Attribute->new('anonymous' => (
+        reader   => {
+            # NOTE:
+            # we just alias the original method
+            # rather than re-produce it here
+            'is_anonymous' => \&Class::MOP::Package::is_anonymous
+        },
+        default => 0,
+    ))
+);
+
+Class::MOP::Package->meta->add_attribute(
     Class::MOP::Attribute->new('namespace' => (
         reader => {
             # NOTE:
diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index 6f1dd31..8807726 100644
--- a/lib/Class/MOP/Class.pm
+++ b/lib/Class/MOP/Class.pm
@@ -115,7 +115,8 @@ sub _new {
 
     return bless {
         # inherited from Class::MOP::Package
-        'package' => $options->{package},
+        'package'   => $options->{package},
+        'anonymous' => $options->{anonymous},
 
         # NOTE:
         # since the following attributes will
@@ -214,65 +215,23 @@ sub _check_metaclass_compatibility {
     }
 }
 
-## ANON classes
+# Anonymous 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) = @_;
-        my $package_name = $ANON_CLASS_PREFIX . ++$ANON_CLASS_SERIAL;
-        return $class->create($package_name, %options);
-    }
+sub is_anon_class {
+    return shift->is_anonymous;
+}
 
-    # NOTE:
-    # this will only get called for
-    # anon-classes, 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 in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated
-
-        no warnings 'uninitialized';
-        my $name = $self->name;
-        return unless $name =~ /^$ANON_CLASS_PREFIX/o;
-        # 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($name);
-        return if $current_meta ne $self;
-
-        my ($serial_id) = ($name =~ /^$ANON_CLASS_PREFIX(\d+)/o);
-        no strict 'refs';
-        @{$name . '::ISA'} = ();
-        %{$name . '::'}    = ();
-        delete ${$ANON_CLASS_PREFIX}{$serial_id . '::'};
-
-        Class::MOP::remove_metaclass_by_name($name);
-    }
+sub anonymous_package_prefix { 'Class::MOP::Class::__ANON__::SERIAL' }
 
+sub create_anon_class {
+    my ($class, %options) = @_;
+    my $package_name = sprintf (
+        '%s::%s', 
+        Class::MOP::Class->anonymous_package_prefix(), 
+        Class::MOP::Class->anonymous_package_postfix()
+    );
+    $options{anonymous} = 1;
+    return $class->create($package_name, %options);
 }
 
 # creating classes with MOP ...
diff --git a/lib/Class/MOP/Package.pm b/lib/Class/MOP/Package.pm
index 5da609f..d21a495 100644
--- a/lib/Class/MOP/Package.pm
+++ b/lib/Class/MOP/Package.pm
@@ -7,6 +7,7 @@ use warnings;
 use Scalar::Util 'blessed', 'reftype';
 use Carp         'confess';
 use Sub::Name    'subname';
+use Devel::GlobalDestruction 'in_global_destruction';
 
 our $VERSION   = '0.91';
 $VERSION = eval $VERSION;
@@ -24,7 +25,6 @@ sub initialize {
     my %options = @args;
     my $package_name = $options{package};
 
-
     # we hand-construct the class 
     # until we can bootstrap it
     if ( my $meta = Class::MOP::get_metaclass_by_name($package_name) ) {
@@ -64,9 +64,11 @@ sub _new {
         if $class ne __PACKAGE__;
 
     my $params = @_ == 1 ? $_[0] : {@_};
+    $params->{anonymous} = 0 unless defined $params->{anonymous};
 
     return bless {
         package   => $params->{package},
+        anonymous => $params->{anonymous},
 
         # NOTE:
         # because of issues with the Perl API
@@ -81,6 +83,42 @@ sub _new {
     } => $class;
 }
 
+# Anonymous Packages
+
+my $ANON_PACKAGE_SERIAL = 0;
+sub anonymous_package_postfix { ++$ANON_PACKAGE_SERIAL }
+sub anonymous_package_prefix { undef }
+
+# NOTE:
+# this will only get called for
+# anon-packages, 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 in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated
+
+    my $name = $self->name;
+    return unless $self->is_anonymous; 
+    # 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($name);
+    return if $current_meta ne $self;
+    my $prefix = $self->anonymous_package_prefix . '::';
+    my ($postfix) = ($name =~ /^$prefix(.+)/o);
+    no strict 'refs';
+    @{$name . '::ISA'} = ();
+    %{$name . '::'}    = ();
+    delete ${$prefix}{$postfix . '::'};
+
+    Class::MOP::remove_metaclass_by_name($name);
+}
+
 # Attributes
 
 # NOTE:
@@ -103,6 +141,7 @@ sub method_metaclass         { $_[0]->{'method_metaclass'}            }
 sub wrapped_method_metaclass { $_[0]->{'wrapped_method_metaclass'}    }
 
 sub _method_map              { $_[0]->{'methods'}                     }
+sub is_anonymous             { $_[0]->{'anonymous'}                   }
 
 # utility methods
 
diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t
index bcc6335..a95dfa2 100644
--- a/t/010_self_introspection.t
+++ b/t/010_self_introspection.t
@@ -1,7 +1,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 300;
+use Test::More tests => 310;
 use Test::Exception;
 
 use Class::MOP;
@@ -42,6 +42,12 @@ my @class_mop_package_methods = qw(
     get_method_list get_method_map
 
     _deconstruct_variable_name
+
+    anonymous_package_prefix anonymous_package_postfix
+
+    is_anonymous
+    
+    DESTROY
 );
 
 my @class_mop_module_methods = qw(
@@ -98,8 +104,10 @@ my @class_mop_class_methods = qw(
 
     _immutable_metaclass
     immutable_trait constructor_name constructor_class destructor_class
+    
+    anonymous_package_prefix
+
 
-    DESTROY
 );
 
 # check the class ...
@@ -164,6 +172,7 @@ my @class_mop_package_attributes = (
     'methods',
     'method_metaclass',
     'wrapped_method_metaclass',
+    'anonymous',
 );
 
 my @class_mop_module_attributes = (