X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FClass.pm;h=bf92bf26ff6dffe5039f585322de69956c8983f5;hb=c23184fc39306590f9e481d76c199020a638bb28;hp=6902284f53ca9421eaef469399a75435886b7934;hpb=864826055ffa48aba41ba1a016c09f24b51e85c4;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 6902284..bf92bf2 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; @@ -274,7 +278,9 @@ sub get_method_map { foreach my $symbol ($self->list_all_package_symbols('CODE')) { my $code = $self->get_package_symbol('&' . $symbol); - next if exists $map->{$symbol} && $map->{$symbol}->body == $code; + next if exists $map->{$symbol} && + defined $map->{$symbol} && + $map->{$symbol}->body == $code; my $gv = svref_2object($code)->GV; next if ($gv->STASH->NAME || '') ne $class_name && @@ -336,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; } @@ -413,7 +420,7 @@ sub add_method { $method = $self->find_next_method_by_name($method_name); # die if it does not exist (defined $method) - || confess "The method '$method_name' is not found in the inherience hierarchy for this class"; + || confess "The method '$method_name' is not found in the inherience hierarchy for class " . $self->name; # and now make sure to wrap it # even if it is already wrapped # because we need a new sub ref @@ -523,8 +530,23 @@ sub get_method_list { sub find_method_by_name { my ($self, $method_name) = @_; - # FIXME - return $self->name->can($method_name); + (defined $method_name && $method_name) + || confess "You must define a method name to find"; + # keep a record of what we have seen + # here, this will handle all the + # inheritence issues because we are + # using the &class_precedence_list + my %seen_class; + my @cpl = $self->class_precedence_list(); + foreach my $class (@cpl) { + next if $seen_class{$class}; + $seen_class{$class}++; + # fetch the meta-class ... + my $meta = $self->initialize($class); + return $meta->get_method($method_name) + if $meta->has_method($method_name); + } + return; } sub compute_all_applicable_methods { @@ -707,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;