|| $class->construct_class_instance(package => $package_name, @_);
}
-sub reinitialize {
- my $class = shift;
- my $package_name = shift;
- (defined $package_name && $package_name && !blessed($package_name))
- || confess "You must pass a package name and it cannot be blessed";
- Class::MOP::remove_metaclass_by_name($package_name);
- $class->construct_class_instance('package' => $package_name, @_);
-}
-
# NOTE: (meta-circularity)
# this is a special form of &construct_instance
# (see below), which is used to construct class
# normal &construct_instance.
sub construct_class_instance {
my $class = shift;
- my %options = @_;
- my $package_name = $options{'package'};
+ my $options = @_ == 1 ? $_[0] : {@_};
+ my $package_name = $options->{package};
(defined $package_name && $package_name)
|| confess "You must pass a package name";
# NOTE:
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:
# it is safe to use meta here because
# class will always be a subclass of
# Class::MOP::Class, which defines meta
- $meta = $class->meta->construct_instance(%options)
+ $meta = $class->meta->construct_instance($options)
}
# and check the metaclass compatibility
$meta;
}
+sub _new {
+ my $class = shift;
+ my $options = @_ == 1 ? $_[0] : {@_};
+
+ 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;
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
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/;
my $current = Class::MOP::check_package_cache_flag($self->name);
if (defined $self->{'_package_cache_flag'} && $self->{'_package_cache_flag'} == $current) {
- return $self->{'methods'};
+ return $self->{'methods'} ||= {};
}
$self->{_package_cache_flag} = $current;
- my $map = $self->{'methods'};
+ my $map = $self->{'methods'} ||= {};
my $class_name = $self->name;
my $method_metaclass = $self->method_metaclass;
}
sub construct_instance {
- my ($class, %params) = @_;
+ my $class = shift;
+ my $params = @_ == 1 ? $_[0] : {@_};
my $meta_instance = $class->get_meta_instance();
my $instance = $meta_instance->create_instance();
foreach my $attr ($class->compute_all_applicable_attributes()) {
- $attr->initialize_instance_slot($meta_instance, $instance, \%params);
+ $attr->initialize_instance_slot($meta_instance, $instance, $params);
}
# NOTE:
# this will only work for a HASH instance type
return;
}
+# check if we can reinitialize
+sub is_pristine {
+ my $self = shift;
+
+ # if any local attr is defined
+ return if $self->get_attribute_list;
+
+ # or any non-declared methods
+ if ( my @methods = values %{ $self->get_method_map } ) {
+ my $metaclass = $self->method_metaclass;
+ foreach my $method ( @methods ) {
+ return if $method->isa("Class::MOP::Method::Generated");
+ # FIXME do we need to enforce this too? return unless $method->isa($metaclass);
+ }
+ }
+
+ return 1;
+}
+
## Class closing
sub is_mutable { 1 }
This initializes and returns returns a B<Class::MOP::Class> object
for a given a C<$package_name>.
-=item B<reinitialize ($package_name, %options)>
-
-This removes the old metaclass, and creates a new one in it's place.
-Do B<not> use this unless you really know what you are doing, it could
-very easily make a very large mess of your program.
-
=item B<construct_class_instance (%options)>
This will construct an instance of B<Class::MOP::Class>, it is
This returns true if the class has been made immutable.
+=item B<is_pristine>
+
+Checks whether the class has any data that will be lost if C<reinitialize> is
+called.
+
=back
=head2 Inheritance Relationships
projects / gitmo/Class-MOP.git / blobdiff