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)
use Class::MOP::Immutable;
-our $VERSION = '0.45';
+our $VERSION = '0.46';
our $AUTHORITY = 'cpan:STEVAN';
{
# 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 . "'");
}
}
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';
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) {
@{$self->get_package_symbol('@ISA')};
}
+sub linearized_isa {
+ my %seen;
+ grep { !($seen{$_}++) } (shift)->class_precedence_list
+}
+
sub class_precedence_list {
my $self = shift;
# NOTE:
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)
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()) {
(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 => {
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)
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()) {
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)
/],
memoize => {
class_precedence_list => 'ARRAY',
+ linearized_isa => 'ARRAY',
compute_all_applicable_attributes => 'ARRAY',
get_meta_instance => 'SCALAR',
get_method_map => 'SCALAR',
in which method dispatch will be done. This is similair to
what B<Class::ISA::super_path> does, but we don't remove duplicate names.
+=item B<linearized_isa>
+
+This returns a list based on C<class_precedence_list> but with all
+duplicates removed.
+
=back
=head2 Methods
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
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};
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};
}
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 {{
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;
=pod
-=head1 NAME
+=head1 NAME
Class::MOP::Method::Wrapped - Method Meta Object to handle before/around/after modifiers
L<http://www.iinteractive.com>
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
use strict;
use warnings;
-use Test::More tests => 6;
+use Test::More tests => 8;
BEGIN {
use_ok('Class::MOP');
[ '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 <-+
[ '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
use strict;
use warnings;
-use Test::More tests => 195;
+use Test::More tests => 197;
use Test::Exception;
BEGIN {
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
projects / gitmo/Class-MOP.git / commitdiff