_new for Class::MOP::Class

[gitmo/Class-MOP.git] / lib / Class / MOP / Class.pm

diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index 79c07b4..fa2c920 100644 (file)
--- a/lib/Class/MOP/Class.pm
+++ b/lib/Class/MOP/Class.pm
@@ -82,40 +82,7 @@ sub construct_class_instance {
     my $meta;
     if ($class eq 'Class::MOP::Class') {
         no strict 'refs';
-        $meta = bless {
-            # inherited from Class::MOP::Package
-            'package'             => $package_name,
-
-            # NOTE:
-            # since the following attributes will
-            # actually be loaded from the symbol
-            # table, and actually bypass the instance
-            # entirely, we can just leave these things
-            # listed here for reference, because they
-            # should not actually have a value associated
-            # with the slot.
-            'namespace'           => \undef,
-            # inherited from Class::MOP::Module
-            'version'             => \undef,
-            'authority'           => \undef,
-            # defined in Class::MOP::Class
-            'superclasses'        => \undef,
-
-            'methods'             => {},
-            'attributes'          => {},
-            'attribute_metaclass' => $options{'attribute_metaclass'} || 'Class::MOP::Attribute',
-            'method_metaclass'    => $options{'method_metaclass'}    || 'Class::MOP::Method',
-            'instance_metaclass'  => $options{'instance_metaclass'}  || 'Class::MOP::Instance',
-            
-            ## uber-private variables
-            # NOTE:
-            # this starts out as undef so that 
-            # we can tell the first time the 
-            # methods are fetched
-            # - SL
-            '_package_cache_flag'       => undef,  
-            '_meta_instance'            => undef,          
-        } => $class;
+        $meta = $class->_new(%options)
     }
     else {
         # NOTE:
@@ -138,6 +105,35 @@ sub construct_class_instance {
     $meta;
 }
 
+sub _new {
+    my ( $class, %options ) = @_;
+    bless {
+        # inherited from Class::MOP::Package
+        'package'             => $options{package},
+
+        # NOTE:
+        # since the following attributes will
+        # actually be loaded from the symbol
+        # table, and actually bypass the instance
+        # entirely, we can just leave these things
+        # listed here for reference, because they
+        # should not actually have a value associated
+        # with the slot.
+        'namespace'           => \undef,
+        # inherited from Class::MOP::Module
+        'version'             => \undef,
+        'authority'           => \undef,
+        # defined in Class::MOP::Class
+        'superclasses'        => \undef,
+
+        'methods'             => {},
+        'attributes'          => {},
+        'attribute_metaclass' => $options{'attribute_metaclass'} || 'Class::MOP::Attribute',
+        'method_metaclass'    => $options{'method_metaclass'}    || 'Class::MOP::Method',
+        'instance_metaclass'  => $options{'instance_metaclass'}  || 'Class::MOP::Instance',
+    }, $class;
+}
+
 sub reset_package_cache_flag  { (shift)->{'_package_cache_flag'} = undef } 
 sub update_package_cache_flag {
     my $self = shift;
@@ -213,15 +209,6 @@ sub check_metaclass_compatability {
         return $class->create($package_name, %options);
     }
 
-    BEGIN {
-        local $@;
-        eval {
-            require Devel::GlobalDestruction;
-            Devel::GlobalDestruction->import("in_global_destruction");
-            1;
-        } or *in_global_destruction = sub () { '' };
-    }
-
     # NOTE:
     # this will only get called for
     # anon-classes, all other calls
@@ -231,7 +218,7 @@ sub check_metaclass_compatability {
     sub DESTROY {
         my $self = shift;
 
-        return if in_global_destruction; # it'll happen soon anyway and this just makes things more complicated
+        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_CLASS_PREFIX/;