add associated_metaclass to Method

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

diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm
index bd51287..8667238 100644 (file)
--- a/lib/Class/MOP.pm
+++ b/lib/Class/MOP.pm
@@ -24,6 +24,10 @@ BEGIN {
         ? sub () { 0 }
         : sub () { 1 };    
 
+    *HAVE_ISAREV = defined(&mro::get_isarev)
+        ? sub () { 1 }
+        : sub () { 1 };
+
     # NOTE:
     # we may not use this yet, but once 
     # the get_code_info XS gets merged 
@@ -47,20 +51,9 @@ BEGIN {
         # - SL
         no warnings 'prototype', 'redefine';
         
-        unless (IS_RUNNING_ON_5_10()) {
-            # get this from MRO::Compat ...
-            *check_package_cache_flag = \&MRO::Compat::__get_pkg_gen_pp;
-        }
-        else {
-            # NOTE:
-            # but if we are running 5.10 
-            # there is no need to use the 
-            # Pure Perl version since we 
-            # can use the built in mro 
-            # version instead.
-            # - SL
-            *check_package_cache_flag = \&mro::get_pkg_gen; 
-        }
+        # this is either part of core or set up appropriately by MRO::Compat
+        *check_package_cache_flag = \&mro::get_pkg_gen; 
+
         # our own version of Sub::Name
         *subname       = $_PP_subname;
         # and the Sub::Identify version of the get_code_info
@@ -509,9 +502,12 @@ Class::MOP::Attribute->meta->add_attribute(
 # so that it uses the attributes meta-objects
 # to construct itself.
 Class::MOP::Attribute->meta->add_method('new' => sub {
-    my $class   = shift;
-    my $name    = shift;
-    my %options = @_;
+    my ( $class, @args ) = @_;
+
+    unshift @args, "name" if @args % 2 == 1;
+    my %options = @args;
+
+    my $name = $options{name};
 
     (defined $name && $name)
         || confess "You must provide a name for the attribute";
@@ -531,7 +527,7 @@ Class::MOP::Attribute->meta->add_method('new' => sub {
     }
 
     # return the new object
-    $class->meta->new_object(name => $name, %options);
+    $class->meta->new_object(%options);
 });
 
 Class::MOP::Attribute->meta->add_method('clone' => sub {
@@ -549,6 +545,13 @@ Class::MOP::Method->meta->add_attribute(
 );
 
 Class::MOP::Method->meta->add_attribute(
+    Class::MOP::Attribute->new('associated_metaclass' => (
+        init_arg => 'associated_metaclass',
+        reader   => { 'associated_metaclass' => \&Class::MOP::Method::associated_metaclass },
+    ))
+);
+
+Class::MOP::Method->meta->add_attribute(
     Class::MOP::Attribute->new('package_name' => (
         init_arg => 'package_name',
         reader   => { 'package_name' => \&Class::MOP::Method::package_name },
@@ -563,9 +566,12 @@ Class::MOP::Method->meta->add_attribute(
 );
 
 Class::MOP::Method->meta->add_method('wrap' => sub {
-    my $class   = shift;
-    my $code    = shift;
-    my %options = @_;
+    my ( $class, @args ) = @_;
+
+    unshift @args, 'body' if @args % 2 == 1;
+
+    my %options = @args;
+    my $code = $options{body};
 
     ('CODE' eq ref($code))
         || confess "You must supply a CODE reference to bless, not (" . ($code || 'undef') . ")";
@@ -574,7 +580,7 @@ Class::MOP::Method->meta->add_method('wrap' => sub {
         || confess "You must supply the package_name and name parameters";
 
     # return the new object
-    $class->meta->new_object(body => $code, %options);
+    $class->meta->new_object(%options);
 });
 
 Class::MOP::Method->meta->add_method('clone' => sub {
@@ -717,13 +723,40 @@ Class::MOP::Method::Constructor->meta->add_method('new' => sub {
 # included for completeness
 
 Class::MOP::Instance->meta->add_attribute(
-    Class::MOP::Attribute->new('meta')
+    Class::MOP::Attribute->new('associated_metaclass')
+);
+
+Class::MOP::Instance->meta->add_attribute(
+    Class::MOP::Attribute->new('attributes')
 );
 
 Class::MOP::Instance->meta->add_attribute(
     Class::MOP::Attribute->new('slots')
 );
 
+Class::MOP::Instance->meta->add_attribute(
+    Class::MOP::Attribute->new('slot_hash')
+);
+
+
+# we need the meta instance of the meta instance to be created now, in order
+# for the constructor to be able to use it
+Class::MOP::Instance->meta->get_meta_instance;
+
+Class::MOP::Instance->meta->add_method('new' => sub {
+    my $class   = shift;
+    my $options = $class->BUILDARGS(@_);
+
+    my $self = $class->meta->new_object(%$options);
+    
+    Scalar::Util::weaken($self->{'associated_metaclass'});
+
+    $self;
+});
+
+# pretend the add_method never happenned. it hasn't yet affected anything
+undef Class::MOP::Instance->meta->{_package_cache_flag};
+
 ## --------------------------------------------------------
 ## Now close all the Class::MOP::* classes
 
@@ -950,6 +983,11 @@ We set this constant depending on what version perl we are on, this
 allows us to take advantage of new 5.10 features and stay backwards 
 compat.
 
+=item I<HAVE_ISAREV>
+
+Whether or not C<mro> provides C<get_isarev>, a much faster way to get all the
+subclasses of a certain class.
+
 =back
 
 =head2 Utility functions