* 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
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
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 { {} }
))
Class::MOP::Class->meta->add_attribute(
Class::MOP::Attribute->new('$:attribute_metaclass' => (
+ reader => 'attribute_metaclass',
init_arg => ':attribute_metaclass',
default => 'Class::MOP::Attribute',
))
Class::MOP::Class->meta->add_attribute(
Class::MOP::Attribute->new('$:method_metaclass' => (
+ reader => 'method_metaclass',
init_arg => ':method_metaclass',
default => 'Class::MOP::Method',
))
## 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
(!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;
});
(!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,
} => $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 }
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') {
# class association
-sub associated_class { $_[0]->{associated_class} }
-
sub attach_to_class {
my ($self, $class) = @_;
(blessed($class) && $class->isa('Class::MOP::Class'))
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<default>
The value of this key is the default value which
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 {
sub clone_object {
my $class = shift;
- my $instance = shift;
+ my $instance = shift;
bless $class->clone_instance($instance, @_) => $class->name;
}
# Informational
-sub name { $_[0]->{'$:package'} }
+# &name should be here too, but it is above
+# because it gets bootstrapped away
sub version {
my $self = shift;
## Methods
-# un-used right now ...
-sub method_metaclass { $_[0]->{'$:method_metaclass'} }
-
sub add_method {
my ($self, $method_name, $method) = @_;
(defined $method_name && $method_name)
## Attributes
-sub attribute_metaclass { $_[0]->{'$:attribute_metaclass'} }
-
sub add_attribute {
my $self = shift;
# either we have an attribute object already
|| 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);
}
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();
sub get_attribute_list {
my $self = shift;
- keys %{$self->{'%:attrs'}};
+ keys %{$self->get_attribute_map};
}
sub compute_all_applicable_attributes {
=item B<attribute_metaclass>
+=item B<get_attribute_map>
+
=item B<add_attribute ($attribute_name, $attribute_meta_object)>
This stores a C<$attribute_meta_object> in the B<Class::MOP::Class>
use strict;
use warnings;
-use Test::More tests => 60;
+use Test::More tests => 113;
use Test::Exception;
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';
}
}
+# check for imported functions which are not methods
+
foreach my $non_method_name (qw(
confess
blessed reftype
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 ],
[],
[ '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');
+
use strict;
use warnings;
-use Test::More tests => 64;
+use Test::More tests => 65;
use Test::Exception;
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');
}
projects / gitmo/Class-MOP.git / commitdiff