From: Stevan Little Date: Sun, 5 Feb 2006 22:23:35 +0000 (+0000) Subject: bunch more introspection tests, imporved attribute tests, made adjustments in the... X-Git-Tag: 0_06~7 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7b31baf476f970830c62cafa82d8f2efcd4ac1b6;p=gitmo%2FClass-MOP.git bunch more introspection tests, imporved attribute tests, made adjustments in the code here and there --- diff --git a/Changes b/Changes index b665511..70fd924 100644 --- a/Changes +++ b/Changes @@ -4,10 +4,19 @@ Revision history for Perl extension Class-MOP. * metaclass - adding new metaclass pragma to make assiging the metaclass a little more straightforward + + * Class::MOP + - clean up bootstrapping to include more complete + attribute definitions for Class::MOP::Class and + Class::MOP::Attribute (accessors, readers, writers, + etc.) ... it is redundant, but is useful meta-info + to have around. * Class::MOP::Class - fixing minor meta-circularity issue with &meta, it is now more useful for subclasses + - added &get_attribute_map as an accessor for the + hash of attribute meta objects - &compute_all_applicable_attributes now just returns the attribute meta-object, rather than the HASH ref since all the same info can be gotten from the diff --git a/TODO b/TODO index 86671c7..38440fc 100644 --- a/TODO +++ b/TODO @@ -2,6 +2,20 @@ TODO --------------------------------------------------------------------- +- have the init_arg be automagically filled in if it is not present + +(DONE) + +This will simplify some code, and really is not very expensive anyway + +- clean up bootstrapping to include the accessors, etc for attributes + +(PARTIALLY DONE) - could use some tests + +Having all this meta-info is useful actually, so why not add it, and +let the methods get overwritten if they need to be, its a small price +to pay for what we get from it. + - clean up all ->initialize($_[0]) handling (PARTIALLY DONE) - needs tests diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index 5f68dfd..255b868 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -49,12 +49,14 @@ sub import { Class::MOP::Class->meta->add_attribute( Class::MOP::Attribute->new('$:package' => ( - init_arg => ':package' + reader => 'name', + init_arg => ':package', )) ); Class::MOP::Class->meta->add_attribute( Class::MOP::Attribute->new('%:attributes' => ( + reader => 'get_attribute_map', init_arg => ':attributes', default => sub { {} } )) @@ -62,6 +64,7 @@ Class::MOP::Class->meta->add_attribute( Class::MOP::Class->meta->add_attribute( Class::MOP::Attribute->new('$:attribute_metaclass' => ( + reader => 'attribute_metaclass', init_arg => ':attribute_metaclass', default => 'Class::MOP::Attribute', )) @@ -69,6 +72,7 @@ Class::MOP::Class->meta->add_attribute( Class::MOP::Class->meta->add_attribute( Class::MOP::Attribute->new('$:method_metaclass' => ( + reader => 'method_metaclass', init_arg => ':method_metaclass', default => 'Class::MOP::Method', )) @@ -76,13 +80,60 @@ Class::MOP::Class->meta->add_attribute( ## Class::MOP::Attribute -Class::MOP::Attribute->meta->add_attribute(Class::MOP::Attribute->new('name')); -Class::MOP::Attribute->meta->add_attribute(Class::MOP::Attribute->new('accessor')); -Class::MOP::Attribute->meta->add_attribute(Class::MOP::Attribute->new('reader')); -Class::MOP::Attribute->meta->add_attribute(Class::MOP::Attribute->new('writer')); -Class::MOP::Attribute->meta->add_attribute(Class::MOP::Attribute->new('predicate')); -Class::MOP::Attribute->meta->add_attribute(Class::MOP::Attribute->new('init_arg')); -Class::MOP::Attribute->meta->add_attribute(Class::MOP::Attribute->new('default')); +Class::MOP::Attribute->meta->add_attribute( + Class::MOP::Attribute->new('name' => ( + reader => 'name' + )) +); + +Class::MOP::Attribute->meta->add_attribute( + Class::MOP::Attribute->new('associated_class' => ( + reader => 'associated_class' + )) +); + +Class::MOP::Attribute->meta->add_attribute( + Class::MOP::Attribute->new('accessor' => ( + reader => 'accessor', + predicate => 'has_accessor', + )) +); + +Class::MOP::Attribute->meta->add_attribute( + Class::MOP::Attribute->new('reader' => ( + reader => 'reader', + predicate => 'has_reader', + )) +); + +Class::MOP::Attribute->meta->add_attribute( + Class::MOP::Attribute->new('writer' => ( + reader => 'writer', + predicate => 'has_writer', + )) +); + +Class::MOP::Attribute->meta->add_attribute( + Class::MOP::Attribute->new('predicate' => ( + reader => 'predicate', + predicate => 'has_predicate', + )) +); + +Class::MOP::Attribute->meta->add_attribute( + Class::MOP::Attribute->new('init_arg' => ( + reader => 'init_arg', + predicate => 'has_init_arg', + )) +); + +Class::MOP::Attribute->meta->add_attribute( + Class::MOP::Attribute->new('default' => ( + # default has a custom 'reader' method ... + predicate => 'has_default', + )) +); + # NOTE: (meta-circularity) # This should be one of the last things done @@ -99,6 +150,7 @@ Class::MOP::Attribute->meta->add_method('new' => sub { (!exists $options{reader} && !exists $options{writer}) || confess "You cannot declare an accessor and reader and/or writer functions" if exists $options{accessor}; + $options{init_arg} = $name if not exists $options{init_arg}; bless $class->meta->construct_instance(name => $name, %options) => blessed($class) || $class; }); diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index 2a47ecc..c780a1d 100644 --- a/lib/Class/MOP/Attribute.pm +++ b/lib/Class/MOP/Attribute.pm @@ -33,6 +33,8 @@ sub new { (!exists $options{reader} && !exists $options{writer}) || confess "You cannot declare an accessor and reader and/or writer functions" if exists $options{accessor}; + + $options{init_arg} = $name if not exists $options{init_arg}; bless { name => $name, @@ -48,8 +50,14 @@ sub new { } => $class; } +# NOTE: +# the next bunch of methods will get bootstrapped +# away in the Class::MOP bootstrapping section + sub name { $_[0]->{name} } +sub associated_class { $_[0]->{associated_class} } + sub has_accessor { defined($_[0]->{accessor}) ? 1 : 0 } sub has_reader { defined($_[0]->{reader}) ? 1 : 0 } sub has_writer { defined($_[0]->{writer}) ? 1 : 0 } @@ -63,6 +71,9 @@ sub writer { $_[0]->{writer} } sub predicate { $_[0]->{predicate} } sub init_arg { $_[0]->{init_arg} } +# end bootstrapped away method section. +# (all methods below here are kept intact) + sub default { my $self = shift; if (reftype($self->{default}) && reftype($self->{default}) eq 'CODE') { @@ -77,8 +88,6 @@ sub default { # class association -sub associated_class { $_[0]->{associated_class} } - sub attach_to_class { my ($self, $class) = @_; (blessed($class) && $class->isa('Class::MOP::Class')) @@ -255,6 +264,9 @@ value of C<-foo>, then the following code will Just Work. MyClass->meta->construct_instance(-foo => "Hello There"); +In an init_arg is not assigned, it will automatically use the +value of C<$name>. + =item I The value of this key is the default value which diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index f98b44b..1634c8c 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -94,6 +94,17 @@ sub create { return $meta; } +## Attribute readers + +# NOTE: +# all these attribute readers will be bootstrapped +# away in the Class::MOP bootstrap section + +sub name { $_[0]->{'$:package'} } +sub get_attribute_map { $_[0]->{'%:attributes'} } +sub attribute_metaclass { $_[0]->{'$:attribute_metaclass'} } +sub method_metaclass { $_[0]->{'$:method_metaclass'} } + # Instance Construction & Cloning sub new_object { @@ -119,7 +130,7 @@ sub construct_instance { sub clone_object { my $class = shift; - my $instance = shift; + my $instance = shift; bless $class->clone_instance($instance, @_) => $class->name; } @@ -144,7 +155,8 @@ sub clone_instance { # Informational -sub name { $_[0]->{'$:package'} } +# &name should be here too, but it is above +# because it gets bootstrapped away sub version { my $self = shift; @@ -183,9 +195,6 @@ sub class_precedence_list { ## Methods -# un-used right now ... -sub method_metaclass { $_[0]->{'$:method_metaclass'} } - sub add_method { my ($self, $method_name, $method) = @_; (defined $method_name && $method_name) @@ -306,8 +315,6 @@ sub find_all_methods_by_name { ## Attributes -sub attribute_metaclass { $_[0]->{'$:attribute_metaclass'} } - sub add_attribute { my $self = shift; # either we have an attribute object already @@ -318,21 +325,21 @@ sub add_attribute { || confess "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)"; $attribute->attach_to_class($self); $attribute->install_accessors(); - $self->{'%:attrs'}->{$attribute->name} = $attribute; + $self->get_attribute_map->{$attribute->name} = $attribute; } sub has_attribute { my ($self, $attribute_name) = @_; (defined $attribute_name && $attribute_name) || confess "You must define an attribute name"; - exists $self->{'%:attrs'}->{$attribute_name} ? 1 : 0; + exists $self->get_attribute_map->{$attribute_name} ? 1 : 0; } sub get_attribute { my ($self, $attribute_name) = @_; (defined $attribute_name && $attribute_name) || confess "You must define an attribute name"; - return $self->{'%:attrs'}->{$attribute_name} + return $self->get_attribute_map->{$attribute_name} if $self->has_attribute($attribute_name); } @@ -340,8 +347,8 @@ sub remove_attribute { my ($self, $attribute_name) = @_; (defined $attribute_name && $attribute_name) || confess "You must define an attribute name"; - my $removed_attribute = $self->{'%:attrs'}->{$attribute_name}; - delete $self->{'%:attrs'}->{$attribute_name} + my $removed_attribute = $self->get_attribute_map->{$attribute_name}; + delete $self->get_attribute_map->{$attribute_name} if defined $removed_attribute; $removed_attribute->remove_accessors(); $removed_attribute->detach_from_class(); @@ -350,7 +357,7 @@ sub remove_attribute { sub get_attribute_list { my $self = shift; - keys %{$self->{'%:attrs'}}; + keys %{$self->get_attribute_map}; } sub compute_all_applicable_attributes { @@ -730,6 +737,8 @@ their own. See L for more details. =item B +=item B + =item B This stores a C<$attribute_meta_object> in the B diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t index 218b0f5..1d68927 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 => 60; +use Test::More tests => 113; use Test::Exception; BEGIN { @@ -14,21 +14,32 @@ BEGIN { my $meta = Class::MOP::Class->meta(); isa_ok($meta, 'Class::MOP::Class'); -foreach my $method_name (qw( +my @methods = qw( meta initialize create + new_object clone_object + construct_instance construct_class_instance clone_instance + name version + attribute_metaclass method_metaclass + superclasses class_precedence_list has_method get_method add_method remove_method get_method_list compute_all_applicable_methods find_all_methods_by_name has_attribute get_attribute add_attribute remove_attribute - get_attribute_list compute_all_applicable_attributes - )) { + get_attribute_list get_attribute_map compute_all_applicable_attributes + + add_package_variable get_package_variable has_package_variable remove_package_variable + ); + +is_deeply([ sort @methods ], [ sort $meta->get_method_list ], '... got the correct method list'); + +foreach my $method_name (@methods) { ok($meta->has_method($method_name), '... Class::MOP::Class->has_method(' . $method_name . ')'); { no strict 'refs'; @@ -38,6 +49,8 @@ foreach my $method_name (qw( } } +# check for imported functions which are not methods + foreach my $non_method_name (qw( confess blessed reftype @@ -47,17 +60,88 @@ foreach my $non_method_name (qw( ok(!$meta->has_method($non_method_name), '... NOT Class::MOP::Class->has_method(' . $non_method_name . ')'); } -foreach my $attribute_name ( - '$:package', '%:attributes', - '$:attribute_metaclass', '$:method_metaclass' - ) { +# check for the right attributes + +my @attributes = ('$:package', '%:attributes', '$:attribute_metaclass', '$:method_metaclass'); + +is_deeply( + [ sort @attributes ], + [ sort $meta->get_attribute_list ], + '... got the right list of attributes'); + +is_deeply( + [ sort @attributes ], + [ sort keys %{$meta->get_attribute_map} ], + '... got the right list of attributes'); + +foreach my $attribute_name (@attributes) { ok($meta->has_attribute($attribute_name), '... Class::MOP::Class->has_attribute(' . $attribute_name . ')'); isa_ok($meta->get_attribute($attribute_name), 'Class::MOP::Attribute'); } +## check the attributes themselves + +ok($meta->get_attribute('$:package')->has_reader, '... Class::MOP::Class $:package has a reader'); +is($meta->get_attribute('$:package')->reader, 'name', '... Class::MOP::Class $:package\'s a reader is &name'); + +ok($meta->get_attribute('$:package')->has_init_arg, '... Class::MOP::Class $:package has a init_arg'); +is($meta->get_attribute('$:package')->init_arg, ':package', '... Class::MOP::Class $:package\'s a init_arg is :package'); + +ok($meta->get_attribute('%:attributes')->has_reader, '... Class::MOP::Class %:attributes has a reader'); +is($meta->get_attribute('%:attributes')->reader, + 'get_attribute_map', + '... Class::MOP::Class %:attributes\'s a reader is &get_attribute_map'); + +ok($meta->get_attribute('%:attributes')->has_init_arg, '... Class::MOP::Class %:attributes has a init_arg'); +is($meta->get_attribute('%:attributes')->init_arg, + ':attributes', + '... Class::MOP::Class %:attributes\'s a init_arg is :attributes'); + +ok($meta->get_attribute('%:attributes')->has_default, '... Class::MOP::Class %:attributes has a default'); +is_deeply($meta->get_attribute('%:attributes')->default, + {}, + '... Class::MOP::Class %:attributes\'s a default of {}'); + +ok($meta->get_attribute('$:attribute_metaclass')->has_reader, '... Class::MOP::Class $:attribute_metaclass has a reader'); +is($meta->get_attribute('$:attribute_metaclass')->reader, + 'attribute_metaclass', + '... Class::MOP::Class $:attribute_metaclass\'s a reader is &attribute_metaclass'); + +ok($meta->get_attribute('$:attribute_metaclass')->has_init_arg, '... Class::MOP::Class $:attribute_metaclass has a init_arg'); +is($meta->get_attribute('$:attribute_metaclass')->init_arg, + ':attribute_metaclass', + '... Class::MOP::Class $:attribute_metaclass\'s a init_arg is :attribute_metaclass'); + +ok($meta->get_attribute('$:attribute_metaclass')->has_default, '... Class::MOP::Class $:attribute_metaclass has a default'); +is($meta->get_attribute('$:attribute_metaclass')->default, + 'Class::MOP::Attribute', + '... Class::MOP::Class $:attribute_metaclass\'s a default is Class::MOP:::Attribute'); + +ok($meta->get_attribute('$:method_metaclass')->has_reader, '... Class::MOP::Class $:method_metaclass has a reader'); +is($meta->get_attribute('$:method_metaclass')->reader, + 'method_metaclass', + '... Class::MOP::Class $:method_metaclass\'s a reader is &method_metaclass'); + +ok($meta->get_attribute('$:method_metaclass')->has_init_arg, '... Class::MOP::Class $:method_metaclass has a init_arg'); +is($meta->get_attribute('$:method_metaclass')->init_arg, + ':method_metaclass', + '... Class::MOP::Class $:method_metaclass\'s init_arg is :method_metaclass'); + +ok($meta->get_attribute('$:method_metaclass')->has_default, '... Class::MOP::Class $:method_metaclass has a default'); +is($meta->get_attribute('$:method_metaclass')->default, + 'Class::MOP::Method', + '... Class::MOP::Class $:method_metaclass\'s a default is Class::MOP:::Method'); + +# check the values of some of the methods + is($meta->name, 'Class::MOP::Class', '... Class::MOP::Class->name'); is($meta->version, $Class::MOP::Class::VERSION, '... Class::MOP::Class->version'); +ok($meta->has_package_variable('$VERSION'), '... Class::MOP::Class->has_package_variable($VERSION)'); +is(${$meta->get_package_variable('$VERSION')}, + $Class::MOP::Class::VERSION, + '... Class::MOP::Class->get_package_variable($VERSION)'); + is_deeply( [ $meta->superclasses ], [], @@ -68,3 +152,6 @@ is_deeply( [ 'Class::MOP::Class' ], '... Class::MOP::Class->class_precedence_list == []'); +is($meta->attribute_metaclass, 'Class::MOP::Attribute', '... got the right value for attribute_metaclass'); +is($meta->method_metaclass, 'Class::MOP::Method', '... got the right value for method_metaclass'); + diff --git a/t/020_attribute.t b/t/020_attribute.t index d23820d..fd0be90 100644 --- a/t/020_attribute.t +++ b/t/020_attribute.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 64; +use Test::More tests => 65; use Test::Exception; BEGIN { @@ -16,11 +16,12 @@ BEGIN { isa_ok($attr, 'Class::MOP::Attribute'); is($attr->name, '$foo', '... $attr->name == $foo'); + ok($attr->has_init_arg, '... $attr does have an init_arg'); + is($attr->init_arg, '$foo', '... $attr init_arg is the name'); ok(!$attr->has_accessor, '... $attr does not have an accessor'); ok(!$attr->has_reader, '... $attr does not have an reader'); ok(!$attr->has_writer, '... $attr does not have an writer'); - ok(!$attr->has_init_arg, '... $attr does not have an init_arg'); ok(!$attr->has_default, '... $attr does not have an default'); }