use strict;
use warnings;
+use Class::MOP::Immutable;
use Class::MOP::Instance;
use Class::MOP::Method::Wrapped;
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:
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(@_);
+{
+ # NOTE:
+ # the immutable version of a
+ # particular metaclass is
+ # really class-level data so
+ # we don't want to regenerate
+ # it any more than we need to
+ my $IMMUTABLE_METACLASS;
+ sub make_immutable {
+ my ($self) = @_;
+
+ $IMMUTABLE_METACLASS ||= Class::MOP::Immutable->new($self, {
+ 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',
+ }
+ });
+
+ $IMMUTABLE_METACLASS->make_metaclass_immutable(@_)
+ }
}
1;
=item B<get_attribute_map>
-=item B<add_attribute ($attribute_name, $attribute_meta_object)>
+=item B<add_attribute ($attribute_meta_object | $attribute_name, %attribute_spec)>
-This stores a C<$attribute_meta_object> in the B<Class::MOP::Class>
-instance associated with the given class, and associates it with
-the C<$attribute_name>. Unlike methods, attributes within the MOP
-are stored as meta-information only. They will be used later to
-construct instances from (see C<construct_instance> above).
+This stores the C<$attribute_meta_object> (or creates one from the
+C<$attribute_name> and C<%attribute_spec>) in the B<Class::MOP::Class>
+instance associated with the given class. Unlike methods, attributes
+within the MOP are stored as meta-information only. They will be used
+later to construct instances from (see C<construct_instance> above).
More details about the attribute meta-objects can be found in the
L<Class::MOP::Attribute> or the L<Class::MOP/The Attribute protocol>
section.
=head1 COPYRIGHT AND LICENSE
-Copyright 2006 by Infinity Interactive, Inc.
+Copyright 2006, 2007 by Infinity Interactive, Inc.
L<http://www.iinteractive.com>