From: Yuval Kogman <nothingmuch@woobling.org>
Date: Sun, 10 Aug 2008 13:13:51 +0000 (+0000)
Subject: explicit meta instance dependencies
X-Git-Tag: 0_64_01~58
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=da5680be0c948ef5305adf43fc95b5a3380a493d;p=gitmo%2FClass-MOP.git

explicit meta instance dependencies
---

diff --git a/examples/ArrayBasedStorage.pod b/examples/ArrayBasedStorage.pod
index 43b459d..bff9baa 100644
--- a/examples/ArrayBasedStorage.pod
+++ b/examples/ArrayBasedStorage.pod
@@ -72,6 +72,8 @@ sub is_slot_initialized {
     refaddr $value eq refaddr $unbound ? 0 : 1;
 }
 
+sub is_dependent_on_superclasses { 1 }
+
 1;
 
 __END__
diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index 0266f4d..e01f5f2 100644
--- a/lib/Class/MOP/Class.pm
+++ b/lib/Class/MOP/Class.pm
@@ -401,10 +401,21 @@ sub construct_instance {
 
 sub get_meta_instance {
     my $self = shift;
-    $self->{'_meta_instance'} ||= $self->instance_metaclass->new(
+    $self->{'_meta_instance'} ||= $self->create_meta_instance();
+}
+
+sub create_meta_instance {
+    my $self = shift;
+    
+    my $instance = $self->instance_metaclass->new(
         associated_metaclass => $self,
         attributes => [ $self->compute_all_applicable_attributes() ],
     );
+
+    $self->add_meta_instance_dependencies()
+        if $instance->is_dependent_on_superclasses();
+
+    return $instance;
 }
 
 sub clone_object {
@@ -492,6 +503,7 @@ sub superclasses {
         # not potentially creating an issues
         # we don't know about
         $self->check_metaclass_compatability();
+        $self->update_meta_instance_dependencies();
     }
     @{$self->get_package_symbol($var_spec)};
 }
@@ -858,12 +870,60 @@ sub add_attribute {
     return $attribute;
 }
 
-sub invalidate_meta_instances {
+sub update_meta_instance_dependencies {
     my $self = shift;
-    
-    my @metas = ( $self, map { Class::MOP::Class->initialize($_) } $self->subclasses );
 
-    $_->invalidate_meta_instance() for @metas;
+    if ( $self->{meta_instance_dependencies} ) {
+        return $self->add_meta_instance_dependencies;
+    }
+}
+
+sub add_meta_instance_dependencies {
+    my $self = shift;
+
+    $self->remove_meta_instance_depdendencies;
+
+    my @attrs = $self->compute_all_applicable_attributes();
+
+    my %seen;
+    my @classes = grep { not $seen{$_->name}++ } map { $_->associated_class } @attrs;
+
+    foreach my $class ( @classes ) { 
+        $class->add_dependent_meta_instance($self);
+    }
+
+    $self->{meta_instance_dependencies} = \@classes;
+}
+
+sub remove_meta_instance_depdendencies {
+    my $self = shift;
+
+    if ( my $classes = delete $self->{meta_instance_dependencies} ) {
+        foreach my $class ( @$classes ) {
+            $class->remove_dependent_meta_instance($self);
+        }
+
+        return $classes;
+    }
+
+    return;
+
+}
+
+sub add_dependent_meta_instance {
+    my ( $self, $metaclass ) = @_;
+    push @{ $self->{dependent_meta_instances} }, $metaclass;
+}
+
+sub remove_dependent_meta_instance {
+    my ( $self, $metaclass ) = @_;
+    my $name = $metaclass->name;
+    @$_ = grep { $_->name ne $name } @$_ for $self->{dependent_meta_instances};
+}
+
+sub invalidate_meta_instances {
+    my $self = shift;
+    $_->invalidate_meta_instance() for $self, @{ $self->{dependent_meta_instances} };
 }
 
 sub invalidate_meta_instance {
@@ -1195,9 +1255,32 @@ but in some cases you might want to use it, so it is here.
 Clears the package cache flag to announce to the internals that we need 
 to rebuild the method map.
 
+=item B<add_meta_instance_dependencies>
+
+Registers this class as dependent on its superclasses.
+
+Only superclasses from which this class inherits attributes will be added.
+
+=item B<remove_meta_instance_depdendencies>
+
+Unregisters this class from its superclasses.
+
+=item B<update_meta_instance_dependencies>
+
+Reregisters if necessary.
+
+=item B<add_dependent_meta_instance> $metaclass
+
+Registers the class as having a meta instance dependent on this class.
+
+=item B<remove_dependent_meta_instance> $metaclass
+
+Remove the class from the list of dependent classes.
+
 =item B<invalidate_meta_instances>
 
-Clears the cached meta instance for this metaclass and all of its subclasses.
+Clears the cached meta instance for this metaclass and all of the registered
+classes with dependent meta instances.
 
 Called by C<add_attribute> and C<remove_attribute> to recalculate the attribute
 slots.
@@ -1225,6 +1308,10 @@ for more information on the instance metaclasses.
 Returns an instance of L<Class::MOP::Instance> to be used in the construction 
 of a new instance of the class. 
 
+=item B<create_meta_instance>
+
+Called by C<get_meta_instance> if necessary.
+
 =item B<new_object (%params)>
 
 This is a convience method for creating a new object of the class, and
diff --git a/lib/Class/MOP/Instance.pm b/lib/Class/MOP/Instance.pm
index cccf41c..8b70fdd 100644
--- a/lib/Class/MOP/Instance.pm
+++ b/lib/Class/MOP/Instance.pm
@@ -143,6 +143,10 @@ sub rebless_instance_structure {
     bless $instance, $metaclass->name;
 }
 
+sub is_dependent_on_superclasses {
+    return; # for meta instances that require updates on inherited slot changes
+}
+
 # inlinable operation snippets
 
 sub is_inlinable { 1 }
@@ -277,6 +281,13 @@ given to this object in C<new>.
 
 This will return true if C<$slot_name> is a valid slot name.
 
+=item B<is_dependent_on_superclasses>
+
+This method returns true when the meta instance must be recreated on any
+superclass changes.
+
+Defaults to false.
+
 =back
 
 =head2 Operations on Instance Structures
diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t
index 7e63a8e..77d7656 100644
--- a/t/010_self_introspection.t
+++ b/t/010_self_introspection.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 208;
+use Test::More tests => 220;
 use Test::Exception;
 
 BEGIN {
@@ -54,12 +54,14 @@ my @class_mop_class_methods = qw(
 
     create_anon_class is_anon_class
 
-    instance_metaclass get_meta_instance
+    instance_metaclass get_meta_instance create_meta_instance
     new_object clone_object
     construct_instance construct_class_instance clone_instance
     rebless_instance
     check_metaclass_compatability
 
+    add_meta_instance_dependencies remove_meta_instance_depdendencies update_meta_instance_dependencies
+    add_dependent_meta_instance remove_dependent_meta_instance
     invalidate_meta_instances invalidate_meta_instance
 
     attribute_metaclass method_metaclass
diff --git a/t/108_ArrayBasedStorage_test.t b/t/108_ArrayBasedStorage_test.t
index a2dc99c..3e19822 100644
--- a/t/108_ArrayBasedStorage_test.t
+++ b/t/108_ArrayBasedStorage_test.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 72;
+use Test::More tests => 73;
 use File::Spec;
 use Scalar::Util 'reftype';
 
@@ -197,4 +197,9 @@ is($baz->foo(), 'This is Bar::Baz::foo', '... Bar::Baz::foo == "This is Bar"');
 is($baz->get_bar(), 'FOO is BAR', '... Bar::Baz::bar has been initialized');
 is($baz->bling(), 'Baz::bling', '... Bar::Baz::bling has been initialized');
 
+Foo->meta->add_attribute( forgotten => is => "rw" );
+
+my $new_baz = Bar::Baz->new;
+
+cmp_ok( scalar(@$new_baz), ">", scalar(@$baz), "additional slot due to refreshed meta instance" );