Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

make the api strongly encourage checking the mro for methods and attrs

find_method/find_attribute now check the entire mro instead of just the
local class. get_all_methods/get_all_attributes are added to get all
methods/attributes defined in the entire mro, and
get_methods/get_attributes have been renamed to
get_local_methods/get_local_attributes
  • Loading branch information...
commit 9d5bf1053706d12159803df6fce3ed84cd2f8c52 1 parent 82623c3
@doy doy authored
View
2  prototype/lib/mop.pm
@@ -58,7 +58,7 @@ sub WALKCLASS {
sub WALKMETH {
my ($dispatcher, $method_name) = @_;
- { ( $dispatcher->() || return )->find_method( $method_name ) || redo }
+ { ( $dispatcher->() || return )->get_local_methods->{ $method_name } || redo }
}
sub class_of ($) { mop::internal::instance::get_class( shift ) }
View
112 prototype/lib/mop/bootstrap.pm
@@ -165,13 +165,33 @@ sub init {
}
));
- # this method is needed for Class->create_instance
+ # this method is needed for Class->get_all_attributes
$::Class->add_method(mop::internal::create_method(
- name => 'get_attributes',
+ name => 'get_local_attributes',
body => $reader->( '$attributes' ),
));
# this method is needed for Class->create_instance
+ $::Class->add_method(mop::internal::create_method(
+ name => 'get_all_attributes',
+ body => sub {
+ my %attrs;
+ mop::WALKCLASS(
+ $::SELF->get_dispatcher('reverse'),
+ sub {
+ my $class = shift;
+ %attrs = (
+ %attrs,
+ %{ $class->get_local_attributes },
+ );
+ }
+ );
+
+ return \%attrs;
+ },
+ ));
+
+ # this method is needed for Class->create_instance
$::Attribute->add_method(mop::internal::create_method(
name => 'get_initial_value_for_instance',
body => sub {
@@ -205,26 +225,20 @@ sub init {
my $args = shift;
my $data = {};
- mop::WALKCLASS(
- $::SELF->get_dispatcher,
- sub {
- my $class = shift;
- my $attrs = $class->get_attributes;
- foreach my $attr_name ( keys %$attrs ) {
- unless ( exists $data->{ $attr_name } ) {
- my $param_name = $attrs->{ $attr_name }->get_param_name;
- if ( exists $args->{ $param_name } ) {
- my $value = $args->{ $param_name };
- $data->{ $attr_name } = \$value;
- }
- else {
- $data->{ $attr_name } = $attrs->{$attr_name}->get_initial_value_for_instance;
- }
-
- }
+ my $attrs = $::SELF->get_all_attributes;
+ foreach my $attr_name ( keys %$attrs ) {
+ unless ( exists $data->{ $attr_name } ) {
+ my $param_name = $attrs->{ $attr_name }->get_param_name;
+ if ( exists $args->{ $param_name } ) {
+ my $value = $args->{ $param_name };
+ $data->{ $attr_name } = \$value;
+ }
+ else {
+ $data->{ $attr_name } = $attrs->{$attr_name}->get_initial_value_for_instance;
}
+
}
- );
+ }
(mop::internal::get_stash_for( $::SELF ) || die "Could not find stash for class(" . $::SELF->get_name . ")")->bless(
mop::internal::instance::create( \$::SELF, $data )
@@ -273,7 +287,7 @@ sub init {
name => 'add_attribute',
body => sub {
my $attr = shift;
- $::SELF->get_attributes->{ $attr->get_name } = $attr;
+ $::SELF->get_local_attributes->{ $attr->get_name } = $attr;
},
));
@@ -317,14 +331,34 @@ sub init {
$::Class->add_method( $::Method->new( name => 'attribute_class', body => sub { $::Attribute } ) );
$::Class->add_method( $::Method->new( name => 'method_class', body => sub { $::Method } ) );
$::Class->add_method( $::Method->new( name => 'base_object_class', body => sub { $::Object } ) );
+
$::Class->add_method( $::Method->new( name => 'get_name', body => $reader->( '$name' ) ) );
$::Class->add_method( $::Method->new( name => 'get_version', body => $reader->( '$version' ) ) );
$::Class->add_method( $::Method->new( name => 'get_authority', body => $reader->( '$authority' ) ) );
- $::Class->add_method( $::Method->new( name => 'get_methods', body => $reader->( '$methods' ) ) );
+ $::Class->add_method( $::Method->new( name => 'get_local_methods', body => $reader->( '$methods' ) ) );
$::Class->add_method( $::Method->new( name => 'get_destructor', body => $reader->( '$destructor' ) ) );
- $::Class->add_method( $::Method->new( name => 'find_attribute', body => sub { $::SELF->get_attributes->{ $_[0] } } ) );
- $::Class->add_method( $::Method->new( name => 'find_method', body => sub { $::SELF->get_methods->{ $_[0] } } ) );
+ $::Class->add_method( $::Method->new(
+ name => 'get_all_methods',
+ body => sub {
+ my %methods;
+ mop::WALKCLASS(
+ $::SELF->get_dispatcher('reverse'),
+ sub {
+ my $class = shift;
+ %methods = (
+ %methods,
+ %{ $class->get_local_methods },
+ );
+ }
+ );
+
+ return \%methods;
+ },
+ ));
+
+ $::Class->add_method( $::Method->new( name => 'find_attribute', body => sub { $::SELF->get_all_attributes->{ $_[0] } } ) );
+ $::Class->add_method( $::Method->new( name => 'find_method', body => sub { $::SELF->get_all_methods->{ $_[0] } } ) );
## mutators
@@ -359,20 +393,14 @@ sub init {
%$stash = ();
- mop::WALKCLASS(
- $dispatcher,
- sub {
- my $c = shift;
- my $methods = $c->get_methods;
- foreach my $name ( keys %$methods ) {
- my $method = $methods->{ $name };
- $stash->add_method(
- $name,
- sub { $method->execute( @_ ) }
- ) unless exists $stash->{ $name };
- }
- }
- );
+ my $methods = $::SELF->get_all_methods;
+ foreach my $name ( keys %$methods ) {
+ my $method = $methods->{ $name };
+ $stash->add_method(
+ $name,
+ sub { $method->execute( @_ ) }
+ ) unless exists $stash->{ $name };
+ }
$stash->add_method('DESTROY' => sub {
my $invocant = shift;
@@ -511,7 +539,7 @@ sub init {
$::Class->add_method( $::Method->new( name => 'add_method', body => sub {
my $method = shift;
- $::SELF->get_methods->{ $method->get_name } = $method;
+ $::SELF->get_local_methods->{ $method->get_name } = $method;
}));
## --------------------------------
@@ -581,8 +609,8 @@ it under the same terms as Perl itself.
method get_version () { ... }
method get_authority () { ... }
method get_superclass () { ... }
- method get_attributes () { ... }
- method get_methods () { ... }
+ method get_local_attributes () { ... }
+ method get_local_methods () { ... }
method get_constructor () { ... }
method get_destructor () { ... }
@@ -592,7 +620,9 @@ it under the same terms as Perl itself.
method equals ($class) { ... }
method find_attribute ($name) { ... }
+ method get_all_attributes () { ... }
method find_method ($name) { ... }
+ method get_all_methods () { ... }
method get_compatible_class ($class) { ... }
method get_dispatcher ($type) { ... }
method get_mro () { ... }
View
16 prototype/t/000-bootstrap.t
@@ -59,12 +59,12 @@ is_deeply $::Class->get_mro, [ $::Class, $::Object ], '... got the right mro';
}
}
-foreach my $method ( values %{ $::Class->get_methods } ) {
+foreach my $method ( values %{ $::Class->get_all_methods } ) {
ok $method->isa( $::Method ), '... method (' . $method->get_name . ') of class Class is a Method object';
is $::Class->find_method( $method->get_name ), $method, '... found the method too';
}
-foreach my $attribute ( values %{ $::Class->get_attributes } ) {
+foreach my $attribute ( values %{ $::Class->get_all_attributes } ) {
ok $attribute->isa( $::Attribute ), '... attribute (' . $attribute->get_name . ') of class Class is an Attribute object';
is $::Class->find_attribute( $attribute->get_name ), $attribute, '... found the attribute too';
}
@@ -83,12 +83,12 @@ is_deeply $::Object->get_mro, [ $::Object ], '... got the right mro';
}
}
-foreach my $method ( values %{ $::Object->get_methods } ) {
+foreach my $method ( values %{ $::Object->get_all_methods } ) {
ok $method->isa( $::Method ), '... method (' . $method->get_name . ') of class Object is a Method object';
is $::Object->find_method( $method->get_name ), $method, '... found the method too';
}
-foreach my $attribute ( values %{ $::Object->get_attributes } ) {
+foreach my $attribute ( values %{ $::Object->get_all_attributes } ) {
ok $attribute->isa( $::Attribute ), '... attribute (' . $attribute->get_name . ') of class Object is an Attribute object';
is $::Object->find_attribute( $attribute->get_name ), $attribute, '... found the attribute too';
}
@@ -107,12 +107,12 @@ is_deeply $::Method->get_mro, [ $::Method, $::Object ], '... got the right mro';
}
}
-foreach my $method ( values %{ $::Method->get_methods } ) {
+foreach my $method ( values %{ $::Method->get_all_methods } ) {
ok $method->isa( $::Method ), '... method (' . $method->get_name . ') of class Method is a Method object';
is $::Method->find_method( $method->get_name ), $method, '... found the method too';
}
-foreach my $attribute ( values %{ $::Method->get_attributes } ) {
+foreach my $attribute ( values %{ $::Method->get_all_attributes } ) {
ok $attribute->isa( $::Attribute ), '... attribute (' . $attribute->get_name . ') of class Method is an Attribute object';
is $::Method->find_attribute( $attribute->get_name ), $attribute, '... found the attribute too';
}
@@ -131,12 +131,12 @@ is_deeply $::Attribute->get_mro, [ $::Attribute, $::Object ], '... got the right
}
}
-foreach my $method ( values %{ $::Attribute->get_methods } ) {
+foreach my $method ( values %{ $::Attribute->get_all_methods } ) {
ok $method->isa( $::Method ), '... method (' . $method->get_name . ') of class Attribute is a Method object';
is $::Attribute->find_method( $method->get_name ), $method, '... found the method too';
}
-foreach my $attribute ( values %{ $::Attribute->get_attributes } ) {
+foreach my $attribute ( values %{ $::Attribute->get_all_attributes } ) {
ok $attribute->isa( $::Attribute ), '... attribute (' . $attribute->get_name . ') of class Attribute is an Attribute object';
is $::Attribute->find_attribute( $attribute->get_name ), $attribute, '... found the attribute too';
}
View
6 prototype/t/000-examples/001-basic-example.t
@@ -50,7 +50,7 @@ ok Point->is_subclass_of( $::Object ), '... class Point is a subclass of Object'
is Point->get_superclass, $::Object, '... got the superclass we expected';
is_deeply Point->get_mro, [ Point, $::Object ], '... got the mro we expected';
is_deeply
- [ sort { $a cmp $b } map { $_->get_name } values %{ Point->get_attributes } ],
+ [ sort { $a cmp $b } map { $_->get_name } values %{ Point->get_all_attributes } ],
[ '$x', '$y' ],
'... got the attribute list we expected';
@@ -101,8 +101,8 @@ ok Point3D->is_subclass_of( $::Object ), '... class Point3D is a subclass of Obj
is Point3D->get_superclass, Point, '... got the superclass we expected';
is_deeply Point3D->get_mro, [ Point3D, Point, $::Object ], '... got the mro we expected';
is_deeply
- [ map { $_->get_name } values %{ Point3D->get_attributes } ],
- [ '$z' ],
+ [ sort map { $_->get_name } values %{ Point3D->get_all_attributes } ],
+ [ '$x', '$y', '$z' ],
'... got the attributes we expected';
View
2  prototype/t/030-extensions/001-class-accessor.t
@@ -11,7 +11,7 @@ use mop;
class ClassAccessorMeta (extends => $::Class) {
method FINALIZE {
- foreach my $attribute ( values %{ $self->get_attributes } ) {
+ foreach my $attribute ( values %{ $self->get_all_attributes } ) {
my $name = $attribute->get_name;
my $accessor_name = $name;
$accessor_name =~ s/^\$//;
View
2  prototype/t/030-extensions/002-validated-accessor.t
@@ -20,7 +20,7 @@ class ValidatedAccessorMeta (extends => $::Class) {
method FINALIZE {
- foreach my $attribute ( values %{ $self->get_attributes } ) {
+ foreach my $attribute ( values %{ $self->get_all_attributes } ) {
my $name = $attribute->get_name;
my $validator = $attribute->get_validator;
View
2  prototype/t/200-declare/003-class-w-attribute.t
@@ -14,7 +14,7 @@ class Foo {
is(Foo->get_name, 'Foo', '... got the name we expected');
is(Foo->get_superclass, $::Object, '... got the superclass we expected');
-my $bar = Foo->get_attributes->{'$bar'};
+my $bar = Foo->get_all_attributes->{'$bar'};
ok($bar, '... got a bar');
ok($bar->isa( $::Attribute ), '... bar is a Attribute');
is($bar->get_name, '$bar', '... got the right name for bar');
View
2  prototype/t/200-declare/004-class-w-both.t
@@ -16,7 +16,7 @@ class Foo {
is(Foo->get_name, 'Foo', '... got the name we expected');
is(Foo->get_superclass, $::Object, '... got the superclass we expected');
-my $bar = Foo->get_attributes->{'$bar'};
+my $bar = Foo->get_all_attributes->{'$bar'};
ok($bar, '... got a bar');
ok($bar->isa( $::Attribute ), '... bar is a Attribute');
is($bar->get_name, '$bar', '... got the right name for bar');
View
4 prototype/t/200-declare/020-has.t
@@ -17,7 +17,7 @@ my $Foo = $::Class->new;
}
{
- my $attribute = $Foo->get_attributes->{'$foo'};
+ my $attribute = $Foo->get_all_attributes->{'$foo'};
ok( $attribute, '... found the attribute' );
ok( $attribute->isa( $::Attribute ), '... it is a proper attribute');
is( $attribute->get_name, '$foo', '... got the right name');
@@ -25,7 +25,7 @@ my $Foo = $::Class->new;
}
{
- my $attribute = $Foo->get_attributes->{'$bar'};
+ my $attribute = $Foo->get_all_attributes->{'$bar'};
ok( $attribute, '... found the attribute' );
ok( $attribute->isa( $::Attribute ), '... it is a proper attribute');
is( $attribute->get_name, '$bar', '... got the right name');
View
2  prototype/t/200-declare/021-has-w-metadata.t
@@ -16,7 +16,7 @@ my $Foo = $::Class->new;
}
{
- my $attribute = $Foo->get_attributes->{'$bar'};
+ my $attribute = $Foo->get_all_attributes->{'$bar'};
ok( $attribute, '... found the attribute' );
ok( $attribute->isa( $::Attribute ), '... it is a proper attribute');
is( $attribute->get_name, '$bar', '... got the right name');
View
4 prototype/t/200-declare/022-has-w-block.t
@@ -20,7 +20,7 @@ my $Foo = $::Class->new;
}
{
- my $attribute = $Foo->get_attributes->{'$bar'};
+ my $attribute = $Foo->get_all_attributes->{'$bar'};
ok( $attribute, '... found the attribute' );
ok( $attribute->isa( $::Attribute ), '... it is a proper attribute');
is( $attribute->get_name, '$bar', '... got the right name');
@@ -42,7 +42,7 @@ my $Foo = $::Class->new;
}
{
- my $attribute = $Foo->get_attributes->{'$baz'};
+ my $attribute = $Foo->get_all_attributes->{'$baz'};
ok( $attribute, '... found the attribute' );
ok( $attribute->isa( $::Attribute ), '... it is a proper attribute');
is( $attribute->get_name, '$baz', '... got the right name');
View
2  prototype/t/200-declare/023-has-w-object.t
@@ -22,7 +22,7 @@ class Bar {
}
{
- my $attribute = $Foo->get_attributes->{'$foo'};
+ my $attribute = $Foo->get_all_attributes->{'$foo'};
ok( $attribute, '... found the attribute' );
ok( $attribute->isa( $::Attribute ), '... it is a proper attribute');
is( $attribute->get_name, '$foo', '... got the right name');
View
74 prototype/t/ext/Class-MOPX/Class/MOPX.pm
@@ -227,27 +227,21 @@ class Class (extends => $::Class) {
method install_accessors {
my $dispatcher = $self->get_dispatcher;
- mop::WALKCLASS(
- $dispatcher,
- sub {
- my $c = shift;
- my $attributes = $c->get_attributes;
- for my $attr (values %$attributes) {
- next unless $attr->isa(Attribute);
+ my $attributes = $self->get_all_attributes;
+ for my $attr (values %$attributes) {
+ next unless $attr->isa(Attribute);
- $self->add_method($attr->create_reader)
- if $attr->has_reader;
- $self->add_method($attr->create_writer)
- if $attr->has_writer;
- $self->add_method($attr->create_accessor)
- if $attr->has_accessor;
- $self->add_method($attr->create_predicate)
- if $attr->has_predicate;
- $self->add_method($attr->create_clearer)
- if $attr->has_clearer;
- }
- }
- );
+ $self->add_method($attr->create_reader)
+ if $attr->has_reader;
+ $self->add_method($attr->create_writer)
+ if $attr->has_writer;
+ $self->add_method($attr->create_accessor)
+ if $attr->has_accessor;
+ $self->add_method($attr->create_predicate)
+ if $attr->has_predicate;
+ $self->add_method($attr->create_clearer)
+ if $attr->has_clearer;
+ }
}
method install_constructor {
@@ -259,7 +253,7 @@ class Class (extends => $::Class) {
my $instance = $::SELF;
my ($params) = @_;
- for my $attr (values %{ $::CLASS->get_attributes }) {
+ for my $attr (values %{ $::CLASS->get_all_attributes }) {
next unless $attr->isa(Attribute);
my $param = $attr->get_param_name;
if (exists $params->{$param}) {
@@ -274,29 +268,23 @@ class Class (extends => $::Class) {
}
}
- mop::WALKCLASS(
- $dispatcher,
- sub {
- my $c = shift;
- my $attributes = $c->get_attributes;
- for my $attr (values %$attributes) {
- next unless $attr->isa(Attribute);
- next unless $attr->has_builder;
- next if $attr->lazy;
- next if defined mop::internal::instance::get_slot_at(
- $instance, $attr->get_name
- );
+ my $attributes = $::CLASS->get_all_attributes;
+ for my $attr (values %$attributes) {
+ next unless $attr->isa(Attribute);
+ next unless $attr->has_builder;
+ next if $attr->lazy;
+ next if defined mop::internal::instance::get_slot_at(
+ $instance, $attr->get_name
+ );
- my $builder = $attr->builder;
- my $initial_value = $instance->$builder;
- $attr->constraint->validate($initial_value)
- if $attr->has_constraint;
- mop::internal::instance::set_slot_at(
- $instance, $attr->get_name, \$initial_value
- );
- }
- },
- );
+ my $builder = $attr->builder;
+ my $initial_value = $instance->$builder;
+ $attr->constraint->validate($initial_value)
+ if $attr->has_constraint;
+ mop::internal::instance::set_slot_at(
+ $instance, $attr->get_name, \$initial_value
+ );
+ }
$constructor->execute($::SELF, @_) if $constructor;
},
));
Please sign in to comment.
Something went wrong with that request. Please try again.