bump version to 0.86

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

diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index f67bedf..a0333ba 100644 (file)
--- a/lib/Class/MOP/Class.pm
+++ b/lib/Class/MOP/Class.pm
@@ -12,9 +12,10 @@ use Class::MOP::Class::Immutable::Class::MOP::Class;
 
 use Carp         'confess';
 use Scalar::Util 'blessed', 'weaken';
-use Sub::Name ();
+use Sub::Name 'subname';
+use Devel::GlobalDestruction 'in_global_destruction';
 
-our $VERSION   = '0.83';
+our $VERSION   = '0.86';
 $VERSION = eval $VERSION;
 our $AUTHORITY = 'cpan:STEVAN';
 
@@ -247,7 +248,7 @@ sub _check_metaclass_compatibility {
     sub DESTROY {
         my $self = shift;
 
-        return if Devel::GlobalDestruction::in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated
+        return if 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/;
@@ -516,11 +517,16 @@ sub superclasses {
         # we don't know about
 
         $self->_check_metaclass_compatibility();
-        $self->update_meta_instance_dependencies();
+        $self->_superclasses_updated();
     }
     @{$self->get_package_symbol($var_spec)};
 }
 
+sub _superclasses_updated {
+    my $self = shift;
+    $self->update_meta_instance_dependencies();
+}
+
 sub subclasses {
     my $self = shift;
     my $super_class = $self->name;
@@ -528,6 +534,16 @@ sub subclasses {
     return @{ $super_class->mro::get_isarev() };
 }
 
+sub direct_subclasses {
+    my $self = shift;
+    my $super_class = $self->name;
+
+    return grep {
+        grep {
+            $_ eq $super_class
+        } Class::MOP::Class->initialize($_)->superclasses
+    } $self->subclasses;
+}
 
 sub linearized_isa {
     return @{ mro::get_linear_isa( (shift)->name ) };
@@ -603,15 +619,18 @@ sub add_method {
 
     $method->attach_to_class($self);
 
-    # This used to call get_method_map, which meant we would build all
-    # the method objects for the class just because we added one
-    # method. This is hackier, but quicker too.
-    $self->{methods}{$method_name} = $method;
-    
-    my $full_method_name = ($self->name . '::' . $method_name);    
+    $self->get_method_map->{$method_name} = $method;
+
+    my ( $current_package, $current_name ) = Class::MOP::get_code_info($body);
+
+    if ( $current_name eq '__ANON__' ) {
+        my $full_method_name = ($self->name . '::' . $method_name);
+        subname($full_method_name => $body);
+    }
+
     $self->add_package_symbol(
-        { sigil => '&', type => 'CODE', name => $method_name }, 
-        Sub::Name::subname($full_method_name => $body)
+        { sigil => '&', type => 'CODE', name => $method_name },
+        $body,
     );
 }
 
@@ -648,7 +667,7 @@ sub add_method {
             || confess "You must pass in a method name";
         my $method = $fetch_and_prepare_method->($self, $method_name);
         $method->add_before_modifier(
-            Sub::Name::subname(':before' => $method_modifier)
+            subname(':before' => $method_modifier)
         );
     }
 
@@ -658,7 +677,7 @@ sub add_method {
             || confess "You must pass in a method name";
         my $method = $fetch_and_prepare_method->($self, $method_name);
         $method->add_after_modifier(
-            Sub::Name::subname(':after' => $method_modifier)
+            subname(':after' => $method_modifier)
         );
     }
 
@@ -668,7 +687,7 @@ sub add_method {
             || confess "You must pass in a method name";
         my $method = $fetch_and_prepare_method->($self, $method_name);
         $method->add_around_modifier(
-            Sub::Name::subname(':around' => $method_modifier)
+            subname(':around' => $method_modifier)
         );
     }
 
@@ -697,7 +716,7 @@ sub has_method {
     (defined $method_name && $method_name)
         || confess "You must define a method name";
 
-    exists $self->{methods}{$method_name} || exists $self->get_method_map->{$method_name};
+    exists $self->get_method_map->{$method_name};
 }
 
 sub get_method {
@@ -705,7 +724,7 @@ sub get_method {
     (defined $method_name && $method_name)
         || confess "You must define a method name";
 
-    return $self->{methods}{$method_name} || $self->get_method_map->{$method_name};
+    return $self->get_method_map->{$method_name};
 }
 
 sub remove_method {
@@ -826,6 +845,11 @@ sub add_attribute {
     } else {
         $self->invalidate_meta_instances();
     }
+    
+    # get our count of previously inserted attributes and
+    # increment by one so this attribute knows its order
+    my $order = (scalar keys %{$self->get_attribute_map}) - 1; 
+    $attribute->_set_insertion_order($order + 1);
 
     # then onto installing the new accessors
     $self->get_attribute_map->{$attribute->name} = $attribute;
@@ -1138,11 +1162,7 @@ sub _inline_constructor {
 
     my $name = $args{constructor_name};
 
-    #if ( my $existing = $self->name->can($args{constructor_name}) ) {
-    #    if ( refaddr($existing) == refaddr(\&Moose::Object::new) ) {
-
-    unless ( $args{replace_constructor}
-        or !$self->has_method($name) ) {
+    if ( $self->has_method($name) && !$args{replace_constructor} ) {
         my $class = $self->name;
         warn "Not inlining a constructor for $class since it defines"
             . " its own constructor.\n"
@@ -1177,6 +1197,13 @@ sub _inline_destructor {
         || confess "The 'inline_destructor' option is present, but "
         . "no destructor class was specified";
 
+    if ( $self->has_method('DESTROY') ) {
+        my $class = $self->name;
+        warn "Not inlining a destructor for $class since it defines"
+            . " its own destructor.\n";
+        return;
+    }
+
     my $destructor_class = $args{destructor_class};
 
     Class::MOP::load_class($destructor_class);
@@ -1448,7 +1475,13 @@ duplicates removed.
 
 =item B<< $metaclass->subclasses >>
 
-This returns a list of subclasses for this class.
+This returns a list of all subclasses for this class, even indirect
+subclasses.
+
+=item B<< $metaclass->direct_subclasses >>
+
+This returns a list of immediate subclasses for this class, which does not
+include indirect subclasses.
 
 =back
 
@@ -1580,7 +1613,10 @@ attributes which are defined in terms of "regular" Perl 5 methods.
 
 This will return a L<Class::MOP::Attribute> for the specified
 C<$attribute_name>. If the class does not have the specified
-attribute, it returns C<undef>
+attribute, it returns C<undef>.  
+
+NOTE that get_attribute does not search superclasses, for 
+that you need to use C<find_attribute_by_name>.
 
 =item B<< $metaclass->has_attribute($attribute_name) >>