X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FClass.pm;h=f5e9f8d14079bf7156e831eaa06671e57aedb9be;hb=8203616d0be984d3ca70ee863e75ee3784f894e5;hp=425364b9c31b85408430033dc0abda50b10dc976;hpb=b957569597dbe40bba405c79b34fa4eb5e7c2087;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 425364b..f5e9f8d 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -4,18 +4,20 @@ package Class::MOP::Class; use strict; use warnings; +use Class::MOP::Immutable; +use Class::MOP::Instance; +use Class::MOP::Method::Wrapped; + use Carp 'confess'; use Scalar::Util 'blessed', 'reftype', 'weaken'; use Sub::Name 'subname'; use B 'svref_2object'; -our $VERSION = '0.20'; +our $VERSION = '0.21'; our $AUTHORITY = 'cpan:STEVAN'; use base 'Class::MOP::Module'; -use Class::MOP::Instance; - # Self-introspection sub meta { Class::MOP::Class->initialize(blessed($_[0]) || $_[0]) } @@ -27,7 +29,7 @@ sub initialize { 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 { @@ -36,7 +38,7 @@ 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) @@ -48,7 +50,7 @@ sub reinitialize { 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: @@ -69,14 +71,13 @@ sub construct_class_instance { : 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 @@ -86,17 +87,18 @@ sub construct_class_instance { # 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 { @@ -173,6 +175,7 @@ sub check_metaclass_compatability { sub is_anon_class { my $self = shift; + no warnings 'uninitialized'; $self->name =~ /^$ANON_CLASS_PREFIX/ ? 1 : 0; } @@ -190,6 +193,7 @@ sub check_metaclass_compatability { # really need to be handled explicitly sub DESTROY { my $self = shift; + no warnings 'uninitialized'; return unless $self->name =~ /^$ANON_CLASS_PREFIX/; my ($serial_id) = ($self->name =~ /^$ANON_CLASS_PREFIX(\d+)/); no strict 'refs'; @@ -257,16 +261,16 @@ sub create { # 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; @@ -338,11 +342,12 @@ sub clone_instance { (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; } @@ -724,8 +729,38 @@ sub find_attribute_by_name { 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; @@ -1193,13 +1228,13 @@ their own. See L for more details. =item B -=item B +=item B -This stores a C<$attribute_meta_object> in the B -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 above). +This stores the C<$attribute_meta_object> (or creates one from the +C<$attribute_name> and C<%attribute_spec>) in the B +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 above). More details about the attribute meta-objects can be found in the L or the L section.