X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FClass.pm;h=e3b6e55c8cfa844efdc5b0350b846af11e0aaef9;hb=097eeb20923df544ba145c1e61bc773d7df5857a;hp=657b2c48a80cda56c8ec4e3036110b88b6404711;hpb=5d10c516c73e34da6e350bc567aaf8c272428c9b;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 657b2c4..e3b6e55 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -11,7 +11,7 @@ use Class::MOP::Method::Wrapped; use Carp 'confess'; use Scalar::Util 'blessed', 'weaken'; -our $VERSION = '0.76'; +our $VERSION = '0.77_01'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; @@ -103,7 +103,7 @@ sub _new { bless { # inherited from Class::MOP::Package - 'package' => $options->{package}, + 'package' => $options->{package}, # NOTE: # since the following attributes will @@ -113,18 +113,25 @@ sub _new { # 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, + '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', + 'attribute_metaclass' => $options->{'attribute_metaclass'} + || 'Class::MOP::Attribute', + 'method_metaclass' => $options->{'method_metaclass'} + || 'Class::MOP::Method', + 'wrapped_method_metaclass' => $options->{'wrapped_method_metaclass'} + || 'Class::MOP::Method::Wrapped', + 'instance_metaclass' => $options->{'instance_metaclass'} + || 'Class::MOP::Instance', }, $class; } @@ -150,28 +157,29 @@ sub check_metaclass_compatibility { my @class_list = $self->linearized_isa; shift @class_list; # shift off $self->name - foreach my $class_name (@class_list) { - my $meta = Class::MOP::get_metaclass_by_name($class_name) || next; + foreach my $superclass_name (@class_list) { + my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name) || next; # NOTE: # we need to deal with the possibility # of class immutability here, and then # get the name of the class appropriately - my $meta_type = ($meta->is_immutable - ? $meta->get_mutable_metaclass_name() - : ref($meta)); + my $super_meta_type + = $super_meta->is_immutable + ? $super_meta->get_mutable_metaclass_name() + : ref($super_meta); - ($self->isa($meta_type)) + ($self->isa($super_meta_type)) || confess $self->name . "->meta => (" . (ref($self)) . ")" . " is not compatible with the " . - $class_name . "->meta => (" . ($meta_type) . ")"; + $superclass_name . "->meta => (" . ($super_meta_type) . ")"; # NOTE: # we also need to check that instance metaclasses # are compatibile in the same the class. - ($self->instance_metaclass->isa($meta->instance_metaclass)) + ($self->instance_metaclass->isa($super_meta->instance_metaclass)) || confess $self->name . "->meta->instance_metaclass => (" . ($self->instance_metaclass) . ")" . " is not compatible with the " . - $class_name . "->meta->instance_metaclass => (" . ($meta->instance_metaclass) . ")"; + $superclass_name . "->meta->instance_metaclass => (" . ($super_meta->instance_metaclass) . ")"; } } @@ -306,61 +314,11 @@ 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_method_map { - my $self = shift; - - my $class_name = $self->name; - - my $current = Class::MOP::check_package_cache_flag($class_name); - - if (defined $self->{'_package_cache_flag'} && $self->{'_package_cache_flag'} == $current) { - return $self->{'methods'} ||= {}; - } - - $self->{_package_cache_flag} = $current; - - my $map = $self->{'methods'} ||= {}; - - my $method_metaclass = $self->method_metaclass; - - my $all_code = $self->get_all_package_symbols('CODE'); - - foreach my $symbol (keys %{ $all_code }) { - my $code = $all_code->{$symbol}; - - next if exists $map->{$symbol} && - defined $map->{$symbol} && - $map->{$symbol}->body == $code; - - my ($pkg, $name) = Class::MOP::get_code_info($code); - - # NOTE: - # in 5.10 constant.pm the constants show up - # as being in the right package, but in pre-5.10 - # they show up as constant::__ANON__ so we - # make an exception here to be sure that things - # work as expected in both. - # - SL - unless ($pkg eq 'constant' && $name eq '__ANON__') { - next if ($pkg || '') ne $class_name || - (($name || '') ne '__ANON__' && ($pkg || '') ne $class_name); - } - - $map->{$symbol} = $method_metaclass->wrap( - $code, - associated_metaclass => $self, - package_name => $class_name, - name => $symbol, - ); - } - - return $map; -} +sub get_attribute_map { $_[0]->{'attributes'} } +sub attribute_metaclass { $_[0]->{'attribute_metaclass'} } +sub method_metaclass { $_[0]->{'method_metaclass'} } +sub wrapped_method_metaclass { $_[0]->{'wrapped_method_metaclass'} } +sub instance_metaclass { $_[0]->{'instance_metaclass'} } # Instance Construction & Cloning @@ -658,6 +616,7 @@ sub add_method { { my $fetch_and_prepare_method = sub { my ($self, $method_name) = @_; + my $wrapped_metaclass = $self->wrapped_method_metaclass; # fetch it locally my $method = $self->get_method($method_name); # if we dont have local ... @@ -666,16 +625,16 @@ 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 inheritance hierarchy for class " . $self->name; + || confess "The method '$method_name' was not found in the inheritance hierarchy for " . $self->name; # and now make sure to wrap it # even if it is already wrapped # because we need a new sub ref - $method = Class::MOP::Method::Wrapped->wrap($method); + $method = $wrapped_metaclass->wrap($method); } else { # now make sure we wrap it properly - $method = Class::MOP::Method::Wrapped->wrap($method) - unless $method->isa('Class::MOP::Method::Wrapped'); + $method = $wrapped_metaclass->wrap($method) + unless $method->isa($wrapped_metaclass); } $self->add_method($method_name => $method); return $method; @@ -800,6 +759,12 @@ sub compute_all_applicable_methods { } shift->get_all_methods(@_); } +sub get_all_method_names { + my $self = shift; + my %uniq; + grep { $uniq{$_}++ == 0 } map { $_->name } $self->get_all_methods; +} + sub find_all_methods_by_name { my ($self, $method_name) = @_; (defined $method_name && $method_name) @@ -1100,6 +1065,7 @@ sub create_immutable_transformer { class_precedence_list => 'ARRAY', linearized_isa => 'ARRAY', # FIXME perl 5.10 memoizes this on its own, no need? get_all_methods => 'ARRAY', + get_all_method_names => 'ARRAY', #get_all_attributes => 'ARRAY', # it's an alias, no need, but maybe in the future compute_all_applicable_attributes => 'ARRAY', get_meta_instance => 'SCALAR', @@ -1243,8 +1209,9 @@ as we use a special reserved slot (C<__MOP__>) to store this. =item B -This initializes and returns returns a B object -for a given a C<$package_name>. +This initializes and returns returns a B object for +a given a C<$package_name>. If a metaclass already exists for the +package, it simply returns it instead of creating a new one. =item B @@ -1541,7 +1508,7 @@ methods, use the C method. =item B -This will traverse the inheritance heirachy and return a list of all +This will traverse the inheritance hierarchy and return a list of all the applicable L objects for this class. =item B @@ -1554,6 +1521,12 @@ class. Use L, which is easier/better/faster. This method predates L. +=item B + +This will traverse the inheritance hierarchy and return a list of all the +applicable method names for this class. Duplicate names are removed, but the +order the methods come out is not defined. + =item B This will traverse the inheritence hierarchy and locate all methods @@ -1756,14 +1729,14 @@ use the C method. =item B -This will traverse the inheritance heirachy and return a list of all +This will traverse the inheritance hierarchy and return a list of all the applicable L objects for this class. C is an alias for consistency with C. =item B -This method will traverse the inheritance heirachy and find the +This method will traverse the inheritance hierarchy and find the first attribute whose name matches C<$attr_name>, then return it. It will return undef if nothing is found.