# Creation
sub initialize {
- my $class = shift;
- my $package_name = shift;
- (defined $package_name && $package_name && !blessed($package_name))
+ my $class = shift;
+
+ my $package_name;
+
+ if ( @_ % 2 ) {
+ $package_name = shift;
+ } else {
+ my %options = @_;
+ $package_name = $options{package};
+ }
+
+ (defined $package_name && $package_name && !ref($package_name))
|| confess "You must pass a package name and it cannot be blessed";
+
return Class::MOP::get_metaclass_by_name($package_name)
- || $class->construct_class_instance('package' => $package_name, @_);
+ || $class->construct_class_instance(package => $package_name, @_);
}
sub reinitialize {
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
# 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';
return unless $self->name =~ /^$ANON_CLASS_PREFIX/;
my ($serial_id) = ($self->name =~ /^$ANON_CLASS_PREFIX(\d+)/);
sub create {
my ( $class, @args ) = @_;
- unshift @args, 'name' if @args % 2 == 1;
+ unshift @args, 'package' if @args % 2 == 1;
my (%options) = @args;
- my $package_name = $options{name};
+ my $package_name = $options{package};
(defined $package_name && $package_name)
|| confess "You must pass a package name";
sub get_method_map {
my $self = shift;
- if (defined $self->{'_package_cache_flag'} &&
- $self->{'_package_cache_flag'} == Class::MOP::check_package_cache_flag($self->name)) {
+ my $current = Class::MOP::check_package_cache_flag($self->name);
+
+ if (defined $self->{'_package_cache_flag'} && $self->{'_package_cache_flag'} == $current) {
return $self->{'methods'};
}
-
+
+ $self->{_package_cache_flag} = $current;
+
my $map = $self->{'methods'};
my $class_name = $self->name;
$map->{$symbol} = $method_metaclass->wrap(
$code,
- package_name => $class_name,
- name => $symbol,
+ associated_metaclass => $self,
+ package_name => $class_name,
+ name => $symbol,
);
}
sub get_meta_instance {
my $self = shift;
- # NOTE:
- # just about any fiddling with @ISA or
- # any fiddling with attributes will
- # also fiddle with the symbol table
- # and therefore invalidate the package
- # cache, in which case we should blow
- # away the meta-instance cache. Of course
- # this will invalidate it more often then
- # is probably needed, but better safe
- # then sorry.
- # - SL
- $self->{'_meta_instance'} = undef
- if defined $self->{'_package_cache_flag'} &&
- $self->{'_package_cache_flag'} == Class::MOP::check_package_cache_flag($self->name);
- $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 {
# 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)};
}
)
);
}
+
+ $method->attach_to_class($self);
+
$self->get_method_map->{$method_name} = $method;
my $full_method_name = ($self->name . '::' . $method_name);
{ sigil => '&', type => 'CODE', name => $method_name },
Class::MOP::subname($full_method_name => $body)
);
- $self->update_package_cache_flag;
+
+ $self->update_package_cache_flag; # still valid, since we just added the method to the map, and if it was invalid before that then get_method_map updated it
}
{
$self->add_package_symbol(
{ sigil => '&', type => 'CODE', name => $method_name } => $body
);
- $self->update_package_cache_flag;
}
sub has_method {
$self->remove_package_symbol(
{ sigil => '&', type => 'CODE', name => $method_name }
);
-
- $self->update_package_cache_flag;
+
+ $removed_method->detach_from_class if $removed_method;
+
+ $self->update_package_cache_flag; # still valid, since we just removed the method from the map
return $removed_method;
}
# name here so that we can properly detach
# the old attr object, and remove any
# accessors it would have generated
- $self->remove_attribute($attribute->name)
- if $self->has_attribute($attribute->name);
+ if ( $self->has_attribute($attribute->name) ) {
+ $self->remove_attribute($attribute->name);
+ } else {
+ $self->invalidate_meta_instances();
+ }
# then onto installing the new accessors
- $attribute->install_accessors();
$self->get_attribute_map->{$attribute->name} = $attribute;
+
+ # invalidate package flag here
+ my $e = do { local $@; eval { $attribute->install_accessors() }; $@ };
+ if ( $e ) {
+ $self->remove_attribute($attribute->name);
+ die $e;
+ }
+
+ return $attribute;
+}
+
+sub update_meta_instance_dependencies {
+ my $self = shift;
+
+ 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 {
+ my $self = shift;
+ undef $self->{_meta_instance};
}
sub has_attribute {
my $removed_attribute = $self->get_attribute_map->{$attribute_name};
return unless defined $removed_attribute;
delete $self->get_attribute_map->{$attribute_name};
+ $self->invalidate_meta_instances();
$removed_attribute->remove_accessors();
$removed_attribute->detach_from_class();
return $removed_attribute;
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 the registered
+classes with dependent meta instances.
+
+Called by C<add_attribute> and C<remove_attribute> to recalculate the attribute
+slots.
+
+=item B<invalidate_meta_instance>
+
+Used by C<invalidate_meta_instances>.
+
=back
=head2 Object instance construction and cloning
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