From: Stevan Little Date: Fri, 23 Nov 2007 17:27:43 +0000 (+0000) Subject: adding in the linearized_isa method X-Git-Tag: 0_47~3 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=b7bdffc385af1765c710357109b620b93ff14eae;hp=c9e922297e918f96b891be64d1e5eae4f675d9eb;p=gitmo%2FClass-MOP.git adding in the linearized_isa method --- diff --git a/Changes b/Changes index 2194653..96398c9 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,11 @@ Revision history for Perl extension Class-MOP. +0.46 + * Class::MOP::Class + - added the linearized_isa method instead of constantly + pruning duplicate classes (this will be even more + useful in the 5.10-compat version coming soon) + 0.45 Thurs. Nov. 13, 2007 * Class::MOP::Attribute - Fix error message on confess (groditi) diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index 938a96d..7d60774 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -13,7 +13,7 @@ use Class::MOP::Method; use Class::MOP::Immutable; -our $VERSION = '0.45'; +our $VERSION = '0.46'; our $AUTHORITY = 'cpan:STEVAN'; { diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index 111b9b6..3da3d96 100644 --- a/lib/Class/MOP/Attribute.pm +++ b/lib/Class/MOP/Attribute.pm @@ -90,12 +90,15 @@ sub initialize_instance_slot { # attribute's default value (if it has one) if(exists $params->{$init_arg}){ $meta_instance->set_slot_value($instance, $self->name, $params->{$init_arg}); - } elsif (defined $self->{'$!default'}) { + } + elsif (defined $self->{'$!default'}) { $meta_instance->set_slot_value($instance, $self->name, $self->default($instance)); - } elsif (defined( my $builder = $self->{'$!builder'})) { - if($builder = $instance->can($builder) ){ + } + elsif (defined( my $builder = $self->{'$!builder'})) { + if ($builder = $instance->can($builder)) { $meta_instance->set_slot_value($instance, $self->name, $instance->$builder); - } else { + } + else { confess(blessed($instance)." does not support builder method '". $self->{'$!builder'} ."' for attribute '" . $self->name . "'"); } } diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index e3b70d1..1dc8e24 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -13,7 +13,7 @@ use Scalar::Util 'blessed', 'reftype', 'weaken'; use Sub::Name 'subname'; use B 'svref_2object'; -our $VERSION = '0.23'; +our $VERSION = '0.24'; our $AUTHORITY = 'cpan:STEVAN'; use base 'Class::MOP::Module'; @@ -134,7 +134,7 @@ sub check_metaclass_compatability { return if blessed($self) eq 'Class::MOP::Class' && $self->instance_metaclass eq 'Class::MOP::Instance'; - my @class_list = $self->class_precedence_list; + my @class_list = $self->linearized_isa; shift @class_list; # shift off $self->name foreach my $class_name (@class_list) { @@ -386,6 +386,11 @@ sub superclasses { @{$self->get_package_symbol('@ISA')}; } +sub linearized_isa { + my %seen; + grep { !($seen{$_}++) } (shift)->class_precedence_list +} + sub class_precedence_list { my $self = shift; # NOTE: @@ -549,15 +554,7 @@ sub find_method_by_name { my ($self, $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}++; + foreach my $class ($self->linearized_isa) { # fetch the meta-class ... my $meta = $self->initialize($class); return $meta->get_method($method_name) @@ -568,15 +565,8 @@ sub find_method_by_name { sub compute_all_applicable_methods { my $self = shift; - my @methods; - # 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, %seen_method); - foreach my $class ($self->class_precedence_list()) { - next if $seen_class{$class}; - $seen_class{$class}++; + my (@methods, %seen_method); + foreach my $class ($self->linearized_isa) { # fetch the meta-class ... my $meta = $self->initialize($class); foreach my $method_name ($meta->get_method_list()) { @@ -597,14 +587,7 @@ sub find_all_methods_by_name { (defined $method_name && $method_name) || confess "You must define a method name to find"; my @methods; - # 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; - foreach my $class ($self->class_precedence_list()) { - next if $seen_class{$class}; - $seen_class{$class}++; + foreach my $class ($self->linearized_isa) { # fetch the meta-class ... my $meta = $self->initialize($class); push @methods => { @@ -620,16 +603,9 @@ sub find_next_method_by_name { my ($self, $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(); + my @cpl = $self->linearized_isa; shift @cpl; # discard ourselves 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) @@ -703,15 +679,8 @@ sub get_attribute_list { sub compute_all_applicable_attributes { my $self = shift; - my @attrs; - # 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, %seen_attr); - foreach my $class ($self->class_precedence_list()) { - next if $seen_class{$class}; - $seen_class{$class}++; + my (@attrs, %seen_attr); + foreach my $class ($self->linearized_isa) { # fetch the meta-class ... my $meta = $self->initialize($class); foreach my $attr_name ($meta->get_attribute_list()) { @@ -725,14 +694,7 @@ sub compute_all_applicable_attributes { sub find_attribute_by_name { my ($self, $attr_name) = @_; - # 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; - foreach my $class ($self->class_precedence_list()) { - next if $seen_class{$class}; - $seen_class{$class}++; + foreach my $class ($self->linearized_isa) { # fetch the meta-class ... my $meta = $self->initialize($class); return $meta->get_attribute($attr_name) @@ -810,6 +772,7 @@ sub create_immutable_transformer { /], memoize => { class_precedence_list => 'ARRAY', + linearized_isa => 'ARRAY', compute_all_applicable_attributes => 'ARRAY', get_meta_instance => 'SCALAR', get_method_map => 'SCALAR', @@ -1075,6 +1038,11 @@ This computes the a list of all the class's ancestors in the same order in which method dispatch will be done. This is similair to what B does, but we don't remove duplicate names. +=item B + +This returns a list based on C but with all +duplicates removed. + =back =head2 Methods diff --git a/lib/Class/MOP/Method/Wrapped.pm b/lib/Class/MOP/Method/Wrapped.pm index 4c84ae5..3c02017 100644 --- a/lib/Class/MOP/Method/Wrapped.pm +++ b/lib/Class/MOP/Method/Wrapped.pm @@ -11,10 +11,10 @@ use Sub::Name 'subname'; our $VERSION = '0.02'; our $AUTHORITY = 'cpan:STEVAN'; -use base 'Class::MOP::Method'; +use base 'Class::MOP::Method'; # NOTE: -# this ugly beast is the result of trying +# this ugly beast is the result of trying # to micro optimize this as much as possible # while not completely loosing maintainability. # At this point it's "fast enough", after all @@ -23,45 +23,45 @@ my $_build_wrapped_method = sub { my $modifier_table = shift; my ($before, $after, $around) = ( $modifier_table->{before}, - $modifier_table->{after}, - $modifier_table->{around}, + $modifier_table->{after}, + $modifier_table->{around}, ); if (@$before && @$after) { $modifier_table->{cache} = sub { $_->(@_) for @{$before}; my @rval; ((defined wantarray) ? - ((wantarray) ? - (@rval = $around->{cache}->(@_)) - : + ((wantarray) ? + (@rval = $around->{cache}->(@_)) + : ($rval[0] = $around->{cache}->(@_))) : $around->{cache}->(@_)); - $_->(@_) for @{$after}; + $_->(@_) for @{$after}; return unless defined wantarray; return wantarray ? @rval : $rval[0]; - } + } } elsif (@$before && !@$after) { $modifier_table->{cache} = sub { $_->(@_) for @{$before}; return $around->{cache}->(@_); - } + } } elsif (@$after && !@$before) { $modifier_table->{cache} = sub { my @rval; ((defined wantarray) ? - ((wantarray) ? - (@rval = $around->{cache}->(@_)) - : + ((wantarray) ? + (@rval = $around->{cache}->(@_)) + : ($rval[0] = $around->{cache}->(@_))) : $around->{cache}->(@_)); - $_->(@_) for @{$after}; + $_->(@_) for @{$after}; return unless defined wantarray; return wantarray ? @rval : $rval[0]; - } + } } else { $modifier_table->{cache} = $around->{cache}; @@ -72,25 +72,25 @@ sub wrap { my $class = shift; my $code = shift; (blessed($code) && $code->isa('Class::MOP::Method')) - || confess "Can only wrap blessed CODE"; - my $modifier_table = { + || confess "Can only wrap blessed CODE"; + my $modifier_table = { cache => undef, orig => $code, before => [], - after => [], + after => [], around => { cache => $code->body, - methods => [], + methods => [], }, }; $_build_wrapped_method->($modifier_table); - my $method = $class->SUPER::wrap(sub { $modifier_table->{cache}->(@_) }); + my $method = $class->SUPER::wrap(sub { $modifier_table->{cache}->(@_) }); $method->{'%!modifier_table'} = $modifier_table; - $method; + $method; } sub get_original_method { - my $code = shift; + my $code = shift; $code->{'%!modifier_table'}->{orig}; } @@ -105,14 +105,14 @@ sub add_after_modifier { my $code = shift; my $modifier = shift; push @{$code->{'%!modifier_table'}->{after}} => $modifier; - $_build_wrapped_method->($code->{'%!modifier_table'}); + $_build_wrapped_method->($code->{'%!modifier_table'}); } { # NOTE: - # this is another possible candidate for + # this is another possible candidate for # optimization as well. There is an overhead - # associated with the currying that, if + # associated with the currying that, if # eliminated might make around modifiers # more manageable. my $compile_around_method = sub {{ @@ -126,13 +126,13 @@ sub add_after_modifier { sub add_around_modifier { my $code = shift; my $modifier = shift; - unshift @{$code->{'%!modifier_table'}->{around}->{methods}} => $modifier; + unshift @{$code->{'%!modifier_table'}->{around}->{methods}} => $modifier; $code->{'%!modifier_table'}->{around}->{cache} = $compile_around_method->( @{$code->{'%!modifier_table'}->{around}->{methods}}, $code->{'%!modifier_table'}->{orig}->body ); - $_build_wrapped_method->($code->{'%!modifier_table'}); - } + $_build_wrapped_method->($code->{'%!modifier_table'}); + } } 1; @@ -141,7 +141,7 @@ __END__ =pod -=head1 NAME +=head1 NAME Class::MOP::Method::Wrapped - Method Meta Object to handle before/around/after modifiers @@ -186,7 +186,7 @@ Copyright 2006, 2007 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. +it under the same terms as Perl itself. =cut diff --git a/t/002_class_precedence_list.t b/t/002_class_precedence_list.t index 2a749ae..2abfeb7 100644 --- a/t/002_class_precedence_list.t +++ b/t/002_class_precedence_list.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 6; +use Test::More tests => 8; BEGIN { use_ok('Class::MOP'); @@ -36,6 +36,11 @@ is_deeply( [ 'My::D', 'My::B', 'My::A', 'My::C', 'My::A' ], '... My::D->meta->class_precedence_list == (D B A C A)'); +is_deeply( + [ My::D->meta->linearized_isa ], + [ 'My::D', 'My::B', 'My::A', 'My::C' ], + '... My::D->meta->linearized_isa == (D B A C)'); + =pod A <-+ @@ -93,6 +98,11 @@ is_deeply( [ 'My::3::D', 'My::3::B', 'My::3::A', 'My::3::C', 'My::3::A', 'My::3::B', 'My::3::A' ], '... My::3::D->meta->class_precedence_list == (D B A C A B A)'); +is_deeply( + [ My::3::D->meta->linearized_isa ], + [ 'My::3::D', 'My::3::B', 'My::3::A', 'My::3::C' ], + '... My::3::D->meta->linearized_isa == (D B A C B)'); + =pod Test all the class_precedence_lists diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t index 33a2f4a..1ca0081 100644 --- a/t/010_self_introspection.t +++ b/t/010_self_introspection.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 195; +use Test::More tests => 197; use Test::Exception; BEGIN { @@ -61,7 +61,7 @@ my @class_mop_class_methods = qw( attribute_metaclass method_metaclass - superclasses class_precedence_list + superclasses class_precedence_list linearized_isa has_method get_method add_method remove_method alias_method get_method_list get_method_map compute_all_applicable_methods