use strict;
use warnings;
+use Class::MOP::Instance;
+use Class::MOP::Method::Wrapped;
+
use Carp 'confess';
use Scalar::Util 'blessed', 'reftype', 'weaken';
use Sub::Name 'subname';
use base 'Class::MOP::Module';
-use Class::MOP::Instance;
-
# Self-introspection
sub meta { Class::MOP::Class->initialize(blessed($_[0]) || $_[0]) }
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->construct_class_instance(':package' => $package_name, @_);
+ $class->construct_class_instance('package' => $package_name, @_);
}
sub reinitialize {
(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, @_);
+ $class->construct_class_instance('package' => $package_name, @_);
}
# NOTE: (meta-circularity)
sub construct_class_instance {
my $class = shift;
my %options = @_;
- my $package_name = $options{':package'};
+ my $package_name = $options{'package'};
(defined $package_name && $package_name)
|| confess "You must pass a package name";
# NOTE:
: blessed($class))
: $class);
- $class = blessed($class) || $class;
# now create the metaclass
my $meta;
if ($class =~ /^Class::MOP::Class$/) {
no strict 'refs';
$meta = bless {
# inherited from Class::MOP::Package
- '$:package' => $package_name,
+ '$!package' => $package_name,
# NOTE:
# since the following attributes will
# listed here for reference, because they
# should not actually have a value associated
# with the slot.
- '%:namespace' => \undef,
+ '%!namespace' => \undef,
# inherited from Class::MOP::Module
- '$:version' => \undef,
- '$:authority' => \undef,
+ '$!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',
+ '%!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;
}
else {
# all these attribute readers will be bootstrapped
# away in the Class::MOP bootstrap section
-sub get_attribute_map { $_[0]->{'%:attributes'} }
-sub attribute_metaclass { $_[0]->{'$:attribute_metaclass'} }
-sub method_metaclass { $_[0]->{'$:method_metaclass'} }
-sub instance_metaclass { $_[0]->{'$:instance_metaclass'} }
+sub get_attribute_map { $_[0]->{'%!attributes'} }
+sub attribute_metaclass { $_[0]->{'$!attribute_metaclass'} }
+sub method_metaclass { $_[0]->{'$!method_metaclass'} }
+sub instance_metaclass { $_[0]->{'$!instance_metaclass'} }
# FIXME:
# this is a prime canidate for conversion to XS
sub get_method_map {
my $self = shift;
- my $map = $self->{'%:methods'};
+ my $map = $self->{'%!methods'};
my $class_name = $self->name;
my $method_metaclass = $self->method_metaclass;
(blessed($instance))
|| confess "You can only clone instances, \$self is not a blessed instance";
my $meta_instance = $class->get_meta_instance();
- my $clone = $meta_instance->clone_instance($instance);
- foreach my $key (keys %params) {
- next unless $meta_instance->is_valid_slot($key);
- $meta_instance->set_slot_value($clone, $key, $params{$key});
- }
+ my $clone = $meta_instance->clone_instance($instance);
+ foreach my $attr ($class->compute_all_applicable_attributes()) {
+ if ($params{$attr->init_arg}) {
+ $meta_instance->set_slot_value($clone, $attr->name, $params{$attr->init_arg});
+ }
+ }
return $clone;
}
sub is_mutable { 1 }
sub is_immutable { 0 }
-sub make_immutable {
- return Class::MOP::Class::Immutable->make_metaclass_immutable(@_);
+{
+ use Class::MOP::Immutable;
+
+ my $IMMUTABLE_META;
+
+ sub make_immutable {
+ my ($self) = @_;
+
+ $IMMUTABLE_META ||= Class::MOP::Immutable->new($self->meta, {
+ read_only => [qw/superclasses/],
+ cannot_call => [qw/
+ add_method
+ alias_method
+ remove_method
+ add_attribute
+ remove_attribute
+ add_package_symbol
+ remove_package_symbol
+ /],
+ memoize => {
+ class_precedence_list => 'ARRAY',
+ compute_all_applicable_attributes => 'ARRAY',
+ get_meta_instance => 'SCALAR',
+ get_method_map => 'SCALAR',
+ }
+ })->create_immutable_metaclass;
+
+ $IMMUTABLE_META->make_metaclass_immutable(@_);
+ }
}
1;