Next step is to make Moose::Meta::Role work inherit from this class.
use Scalar::Util 'weaken', 'reftype', 'blessed';
use Try::Tiny;
+use Class::MOP::HasAttributes;
use Class::MOP::HasMethods;
use Class::MOP::Class;
use Class::MOP::Attribute;
);
## --------------------------------------------------------
+## Class::MOP::HasMethods
+
+Class::MOP::HasAttributes->meta->add_attribute(
+ Class::MOP::Attribute->new('attributes' => (
+ reader => {
+ # NOTE: we need to do this in order
+ # for the instance meta-object to
+ # not fall into meta-circular death
+ #
+ # we just alias the original method
+ # rather than re-produce it here
+ '_attribute_map' => \&Class::MOP::HasAttributes::_attribute_map
+ },
+ default => sub { {} }
+ ))
+);
+
+Class::MOP::HasAttributes->meta->add_attribute(
+ Class::MOP::Attribute->new('attribute_metaclass' => (
+ reader => {
+ # NOTE:
+ # we just alias the original method
+ # rather than re-produce it here
+ 'attribute_metaclass' => \&Class::MOP::HasAttributes::attribute_metaclass
+ },
+ default => 'Class::MOP::Attribute',
+ ))
+);
+
+## --------------------------------------------------------
## Class::MOP::Package
Class::MOP::Package->meta->add_attribute(
## Class::MOP::Class
Class::MOP::Class->meta->add_attribute(
- Class::MOP::Attribute->new('attributes' => (
- reader => {
- # NOTE: we need to do this in order
- # for the instance meta-object to
- # not fall into meta-circular death
- #
- # we just alias the original method
- # rather than re-produce it here
- '_attribute_map' => \&Class::MOP::Class::_attribute_map
- },
- default => sub { {} }
- ))
-);
-
-Class::MOP::Class->meta->add_attribute(
Class::MOP::Attribute->new('superclasses' => (
accessor => {
# NOTE:
);
Class::MOP::Class->meta->add_attribute(
- Class::MOP::Attribute->new('attribute_metaclass' => (
- reader => {
- # NOTE:
- # we just alias the original method
- # rather than re-produce it here
- 'attribute_metaclass' => \&Class::MOP::Class::attribute_metaclass
- },
- default => 'Class::MOP::Attribute',
- ))
-);
-
-Class::MOP::Class->meta->add_attribute(
Class::MOP::Attribute->new('instance_metaclass' => (
reader => {
# NOTE: we need to do this in order
constructor_name => undef,
inline_accessors => 0,
) for qw/
+ Class::MOP::HasAttributes
Class::MOP::HasMethods
/;
use Scalar::Util 'blessed', 'reftype', 'weaken';
use Sub::Name 'subname';
use Devel::GlobalDestruction 'in_global_destruction';
-use Try::Tiny;
our $VERSION = '0.95';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
-use base 'Class::MOP::Module';
+use base 'Class::MOP::Module', 'Class::MOP::HasAttributes';
# Creation
# all these attribute readers will be bootstrapped
# away in the Class::MOP bootstrap section
-sub _attribute_map { $_[0]->{'attributes'} }
-sub attribute_metaclass { $_[0]->{'attribute_metaclass'} }
sub instance_metaclass { $_[0]->{'instance_metaclass'} }
sub immutable_trait { $_[0]->{'immutable_trait'} }
sub constructor_class { $_[0]->{'constructor_class'} }
return;
}
-## Attributes
-
-sub add_attribute {
- my $self = shift;
- # either we have an attribute object already
- # or we need to create one from the args provided
- my $attribute = blessed($_[0]) ? $_[0] : $self->attribute_metaclass->new(@_);
- # make sure it is derived from the correct type though
- ($attribute->isa('Class::MOP::Attribute'))
- || confess "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)";
-
- # first we attach our new attribute
- # because it might need certain information
- # about the class which it is attached to
- $attribute->attach_to_class($self);
-
- my $attr_name = $attribute->name;
-
- # then we remove attributes of a conflicting
- # name here so that we can properly detach
- # the old attr object, and remove any
- # accessors it would have generated
- if ( $self->has_attribute($attr_name) ) {
- $self->remove_attribute($attr_name);
- } else {
- $self->invalidate_meta_instances();
- }
-
- # get our count of previously inserted attributes and
- # increment by one so this attribute knows its order
- my $order = (scalar keys %{$self->_attribute_map});
- $attribute->_set_insertion_order($order);
-
- # then onto installing the new accessors
- $self->_attribute_map->{$attr_name} = $attribute;
-
- # invalidate package flag here
- try {
- local $SIG{__DIE__};
- $attribute->install_accessors();
- }
- catch {
- $self->remove_attribute($attr_name);
- die $_;
- };
-
- return $attribute;
-}
-
sub update_meta_instance_dependencies {
my $self = shift;
my @attrs = $self->get_all_attributes();
my %seen;
- my @classes = grep { not $seen{$_->name}++ } map { $_->associated_class } @attrs;
+ my @classes = grep { not $seen{ $_->name }++ }
+ map { $_->associated_class } @attrs;
- foreach my $class ( @classes ) {
+ foreach my $class (@classes) {
$class->add_dependent_meta_instance($self);
}
my $self = shift;
if ( my $classes = delete $self->{meta_instance_dependencies} ) {
- foreach my $class ( @$classes ) {
+ foreach my $class (@$classes) {
$class->remove_dependent_meta_instance($self);
}
sub remove_dependent_meta_instance {
my ( $self, $metaclass ) = @_;
my $name = $metaclass->name;
- @$_ = grep { $_->name ne $name } @$_ for $self->{dependent_meta_instances};
+ @$_ = grep { $_->name ne $name } @$_
+ for $self->{dependent_meta_instances};
}
sub invalidate_meta_instances {
my $self = shift;
- $_->invalidate_meta_instance() for $self, @{ $self->{dependent_meta_instances} };
+ $_->invalidate_meta_instance()
+ for $self, @{ $self->{dependent_meta_instances} };
}
sub invalidate_meta_instance {
undef $self->{_meta_instance};
}
-sub has_attribute {
- my ($self, $attribute_name) = @_;
- (defined $attribute_name)
- || confess "You must define an attribute name";
- exists $self->_attribute_map->{$attribute_name};
-}
-
-sub get_attribute {
- my ($self, $attribute_name) = @_;
- (defined $attribute_name)
- || confess "You must define an attribute name";
- return $self->_attribute_map->{$attribute_name}
- # NOTE:
- # this will return undef anyway, so no need ...
- # if $self->has_attribute($attribute_name);
- #return;
-}
-
-sub remove_attribute {
- my ($self, $attribute_name) = @_;
- (defined $attribute_name)
- || confess "You must define an attribute name";
- my $removed_attribute = $self->_attribute_map->{$attribute_name};
- return unless defined $removed_attribute;
- delete $self->_attribute_map->{$attribute_name};
- $self->invalidate_meta_instances();
- $removed_attribute->remove_accessors();
- $removed_attribute->detach_from_class();
- return $removed_attribute;
-}
-
-sub get_attribute_list {
- my $self = shift;
- keys %{$self->_attribute_map};
-}
-
-sub get_all_attributes {
- my $self = shift;
- my %attrs = map { %{ $self->initialize($_)->_attribute_map } } reverse $self->linearized_isa;
- return values %attrs;
-}
-
-sub find_attribute_by_name {
- my ($self, $attr_name) = @_;
- foreach my $class ($self->linearized_isa) {
- # fetch the meta-class ...
- my $meta = $self->initialize($class);
- return $meta->get_attribute($attr_name)
- if $meta->has_attribute($attr_name);
- }
- return;
-}
-
# check if we can reinitialize
sub is_pristine {
my $self = shift;
--- /dev/null
+package Class::MOP::HasAttributes;
+
+use strict;
+use warnings;
+
+use Carp 'confess';
+use Scalar::Util 'blessed';
+use Try::Tiny;
+
+use base 'Class::MOP::Object';
+
+sub _attribute_map { $_[0]->{'attributes'} }
+sub attribute_metaclass { $_[0]->{'attribute_metaclass'} }
+
+sub add_attribute {
+ my $self = shift;
+
+ # either we have an attribute object already
+ # or we need to create one from the args provided
+ my $attribute
+ = blessed( $_[0] ) ? $_[0] : $self->attribute_metaclass->new(@_);
+
+ # make sure it is derived from the correct type though
+ ( $attribute->isa('Class::MOP::Attribute') )
+ || confess
+ "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)";
+
+ # first we attach our new attribute
+ # because it might need certain information
+ # about the class which it is attached to
+ $attribute->attach_to_class($self);
+
+ my $attr_name = $attribute->name;
+
+ # then we remove attributes of a conflicting
+ # name here so that we can properly detach
+ # the old attr object, and remove any
+ # accessors it would have generated
+ if ( $self->has_attribute($attr_name) ) {
+ $self->remove_attribute($attr_name);
+ }
+ else {
+ $self->invalidate_meta_instances();
+ }
+
+ # get our count of previously inserted attributes and
+ # increment by one so this attribute knows its order
+ my $order = ( scalar keys %{ $self->_attribute_map } );
+ $attribute->_set_insertion_order($order);
+
+ # then onto installing the new accessors
+ $self->_attribute_map->{$attr_name} = $attribute;
+
+ # invalidate package flag here
+ try {
+ local $SIG{__DIE__};
+ $attribute->install_accessors();
+ }
+ catch {
+ $self->remove_attribute($attr_name);
+ die $_;
+ };
+
+ return $attribute;
+}
+
+sub has_attribute {
+ my ( $self, $attribute_name ) = @_;
+
+ ( defined $attribute_name )
+ || confess "You must define an attribute name";
+
+ exists $self->_attribute_map->{$attribute_name};
+}
+
+sub get_attribute {
+ my ( $self, $attribute_name ) = @_;
+
+ ( defined $attribute_name )
+ || confess "You must define an attribute name";
+
+ return $self->_attribute_map->{$attribute_name};
+}
+
+sub remove_attribute {
+ my ( $self, $attribute_name ) = @_;
+
+ ( defined $attribute_name )
+ || confess "You must define an attribute name";
+
+ my $removed_attribute = $self->_attribute_map->{$attribute_name};
+ return unless defined $removed_attribute;
+
+ delete $self->_attribute_map->{$attribute_name};
+ $self->invalidate_meta_instances();
+ $removed_attribute->remove_accessors();
+ $removed_attribute->detach_from_class();
+
+ return $removed_attribute;
+}
+
+sub get_attribute_list {
+ my $self = shift;
+ keys %{ $self->_attribute_map };
+}
+
+sub get_all_attributes {
+ my $self = shift;
+ my %attrs = map { %{ $self->initialize($_)->_attribute_map } }
+ reverse $self->linearized_isa;
+ return values %attrs;
+}
+
+sub find_attribute_by_name {
+ my ( $self, $attr_name ) = @_;
+
+ foreach my $class ( $self->linearized_isa ) {
+ # fetch the meta-class ...
+ my $meta = $self->initialize($class);
+ return $meta->get_attribute($attr_name)
+ if $meta->has_attribute($attr_name);
+ }
+
+ return;
+}
+
+1;
BEGIN {
use_ok('Class::MOP');
+ use_ok('Class::MOP::HasAttributes');
use_ok('Class::MOP::HasMethods');
use_ok('Class::MOP::Package');
use_ok('Class::MOP::Module');
'Class::MOP::Method::Accessor' => Class::MOP::Method::Accessor->meta,
'Class::MOP::Method::Constructor' =>
Class::MOP::Method::Constructor->meta,
+ 'Class::MOP::HasAttributes' => Class::MOP::HasAttributes->meta,
'Class::MOP::HasMethods' => Class::MOP::HasMethods->meta,
'Class::MOP::Package' => Class::MOP::Package->meta,
'Class::MOP::Module' => Class::MOP::Module->meta,
Class::MOP::Class->meta,
Class::MOP::Class::Immutable::Class::MOP::Class->meta,
Class::MOP::class_of('Class::MOP::Class::Immutable::Trait'),
+ Class::MOP::HasAttributes->meta,
Class::MOP::HasMethods->meta,
Class::MOP::Instance->meta,
Class::MOP::Method->meta,
Class::MOP::Class
Class::MOP::Class::Immutable::Class::MOP::Class
Class::MOP::Class::Immutable::Trait
+ Class::MOP::HasAttributes
Class::MOP::HasMethods
Class::MOP::Instance
Class::MOP::Method
add_dependent_meta_instance remove_dependent_meta_instance
invalidate_meta_instances invalidate_meta_instance
- attribute_metaclass
-
superclasses subclasses direct_subclasses class_precedence_list
linearized_isa _superclasses_updated
add_before_method_modifier add_after_method_modifier add_around_method_modifier
- has_attribute get_attribute add_attribute remove_attribute
- get_attribute_list _attribute_map get_all_attributes compute_all_applicable_attributes find_attribute_by_name
-
+ compute_all_applicable_attributes
get_attribute_map
is_mutable is_immutable make_mutable make_immutable
my @class_mop_class_attributes = (
'superclasses',
- 'attributes',
- 'attribute_metaclass',
'instance_metaclass',
'immutable_trait',
'constructor_name',
'... Class::MOP::Package method_metaclass\'s a default is Class::MOP:::Method');
-# ... class
+# ... class, but inherited from HasAttributes
-ok($class_mop_class_meta->get_attribute('attributes')->has_reader, '... Class::MOP::Class attributes has a reader');
-is_deeply($class_mop_class_meta->get_attribute('attributes')->reader,
- { '_attribute_map' => \&Class::MOP::Class::_attribute_map },
+ok($class_mop_class_meta->find_attribute_by_name('attributes')->has_reader, '... Class::MOP::Class attributes has a reader');
+is_deeply($class_mop_class_meta->find_attribute_by_name('attributes')->reader,
+ { '_attribute_map' => \&Class::MOP::HasAttributes::_attribute_map },
'... Class::MOP::Class attributes\'s a reader is &_attribute_map');
-ok($class_mop_class_meta->get_attribute('attributes')->has_init_arg, '... Class::MOP::Class attributes has a init_arg');
-is($class_mop_class_meta->get_attribute('attributes')->init_arg,
+ok($class_mop_class_meta->find_attribute_by_name('attributes')->has_init_arg, '... Class::MOP::Class attributes has a init_arg');
+is($class_mop_class_meta->find_attribute_by_name('attributes')->init_arg,
'attributes',
'... Class::MOP::Class attributes\'s a init_arg is attributes');
-ok($class_mop_class_meta->get_attribute('attributes')->has_default, '... Class::MOP::Class attributes has a default');
-is_deeply($class_mop_class_meta->get_attribute('attributes')->default('Foo'),
+ok($class_mop_class_meta->find_attribute_by_name('attributes')->has_default, '... Class::MOP::Class attributes has a default');
+is_deeply($class_mop_class_meta->find_attribute_by_name('attributes')->default('Foo'),
{},
'... Class::MOP::Class attributes\'s a default of {}');
-ok($class_mop_class_meta->get_attribute('attribute_metaclass')->has_reader, '... Class::MOP::Class attribute_metaclass has a reader');
-is_deeply($class_mop_class_meta->get_attribute('attribute_metaclass')->reader,
- { 'attribute_metaclass' => \&Class::MOP::Class::attribute_metaclass },
+ok($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->has_reader, '... Class::MOP::Class attribute_metaclass has a reader');
+is_deeply($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->reader,
+ { 'attribute_metaclass' => \&Class::MOP::HasAttributes::attribute_metaclass },
'... Class::MOP::Class attribute_metaclass\'s a reader is &attribute_metaclass');
-ok($class_mop_class_meta->get_attribute('attribute_metaclass')->has_init_arg, '... Class::MOP::Class attribute_metaclass has a init_arg');
-is($class_mop_class_meta->get_attribute('attribute_metaclass')->init_arg,
+ok($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->has_init_arg, '... Class::MOP::Class attribute_metaclass has a init_arg');
+is($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->init_arg,
'attribute_metaclass',
'... Class::MOP::Class attribute_metaclass\'s a init_arg is attribute_metaclass');
-ok($class_mop_class_meta->get_attribute('attribute_metaclass')->has_default, '... Class::MOP::Class attribute_metaclass has a default');
-is($class_mop_class_meta->get_attribute('attribute_metaclass')->default,
+ok($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->has_default, '... Class::MOP::Class attribute_metaclass has a default');
+is($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->default,
'Class::MOP::Attribute',
'... Class::MOP::Class attribute_metaclass\'s a default is Class::MOP:::Attribute');
is_deeply(
[ $class_mop_class_meta->superclasses ],
- [ qw/Class::MOP::Module/ ],
+ [ qw/Class::MOP::Module Class::MOP::HasAttributes/ ],
'... Class::MOP::Class->superclasses == [ Class::MOP::Module ]');
is_deeply(
Class::MOP::Package
Class::MOP::HasMethods
Class::MOP::Object
+ Class::MOP::HasAttributes
+ Class::MOP::Object
/ ],
'... Class::MOP::Class->class_precedence_list == [ Class::MOP::Class Class::MOP::Module Class::MOP::Package ]');
projects / gitmo/Class-MOP.git / commitdiff