Revision history for Perl extension Class-MOP.
+ * Various
+ - Internal refactorings to move shared behavior into new "mixin"
+ classes. This made adding some new features to Moose much
+ easier. (Dave Rolsky)
+
0.97 Fri, Dec 18, 2009
* No code changes, just packaging fixes to make this distro installable.
use Scalar::Util 'weaken', 'reftype', 'blessed';
use Try::Tiny;
+use Class::MOP::Mixin::AttributeCore;
+use Class::MOP::Mixin::HasAttributes;
+use Class::MOP::Mixin::HasMethods;
use Class::MOP::Class;
use Class::MOP::Attribute;
use Class::MOP::Method;
# inherit them using _construct_instance
## --------------------------------------------------------
-## Class::MOP::Package
+## Class::MOP::Mixin::HasMethods
-Class::MOP::Package->meta->add_attribute(
- Class::MOP::Attribute->new('package' => (
+Class::MOP::Mixin::HasMethods->meta->add_attribute(
+ Class::MOP::Attribute->new('_methods' => (
reader => {
- # NOTE: we need to do this in order
- # for the instance meta-object to
- # not fall into meta-circular death
- #
+ # NOTE:
# we just alias the original method
# rather than re-produce it here
- 'name' => \&Class::MOP::Package::name
+ '_full_method_map' => \&Class::MOP::Mixin::HasMethods::_full_method_map
},
+ default => sub { {} }
))
);
-Class::MOP::Package->meta->add_attribute(
- Class::MOP::Attribute->new('namespace' => (
- reader => {
+Class::MOP::Mixin::HasMethods->meta->add_attribute(
+ Class::MOP::Attribute->new('method_metaclass' => (
+ reader => {
# NOTE:
# we just alias the original method
# rather than re-produce it here
- 'namespace' => \&Class::MOP::Package::namespace
+ 'method_metaclass' => \&Class::MOP::Mixin::HasMethods::method_metaclass
},
- init_arg => undef,
- default => sub { \undef }
+ default => 'Class::MOP::Method',
))
);
-Class::MOP::Package->meta->add_attribute(
- Class::MOP::Attribute->new('_methods' => (
+Class::MOP::Mixin::HasMethods->meta->add_attribute(
+ Class::MOP::Attribute->new('wrapped_method_metaclass' => (
reader => {
# NOTE:
# we just alias the original method
# rather than re-produce it here
- '_full_method_map' => \&Class::MOP::Package::_full_method_map
+ 'wrapped_method_metaclass' => \&Class::MOP::Mixin::HasMethods::wrapped_method_metaclass
},
- default => sub { {} }
+ default => 'Class::MOP::Method::Wrapped',
))
);
-Class::MOP::Package->meta->add_attribute(
- Class::MOP::Attribute->new('method_metaclass' => (
+## --------------------------------------------------------
+## Class::MOP::Mixin::HasMethods
+
+Class::MOP::Mixin::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::Mixin::HasAttributes::_attribute_map
+ },
+ default => sub { {} }
+ ))
+);
+
+Class::MOP::Mixin::HasAttributes->meta->add_attribute(
+ Class::MOP::Attribute->new('attribute_metaclass' => (
reader => {
# NOTE:
# we just alias the original method
# rather than re-produce it here
- 'method_metaclass' => \&Class::MOP::Package::method_metaclass
+ 'attribute_metaclass' => \&Class::MOP::Mixin::HasAttributes::attribute_metaclass
},
- default => 'Class::MOP::Method',
+ default => 'Class::MOP::Attribute',
))
);
+## --------------------------------------------------------
+## Class::MOP::Package
+
Class::MOP::Package->meta->add_attribute(
- Class::MOP::Attribute->new('wrapped_method_metaclass' => (
+ Class::MOP::Attribute->new('package' => (
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
+ 'name' => \&Class::MOP::Package::name
+ },
+ ))
+);
+
+Class::MOP::Package->meta->add_attribute(
+ Class::MOP::Attribute->new('namespace' => (
+ reader => {
# NOTE:
# we just alias the original method
# rather than re-produce it here
- 'wrapped_method_metaclass' => \&Class::MOP::Package::wrapped_method_metaclass
+ 'namespace' => \&Class::MOP::Package::namespace
},
- default => 'Class::MOP::Method::Wrapped',
+ init_arg => undef,
+ default => sub { \undef }
))
);
## 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
# _construct_class_instance method.
## --------------------------------------------------------
-## Class::MOP::Attribute
-
-Class::MOP::Attribute->meta->add_attribute(
+## Class::MOP::Mixin::AttributeCore
+Class::MOP::Mixin::AttributeCore->meta->add_attribute(
Class::MOP::Attribute->new('name' => (
reader => {
# NOTE: we need to do this in order
#
# we just alias the original method
# rather than re-produce it here
- 'name' => \&Class::MOP::Attribute::name
- }
- ))
-);
-
-Class::MOP::Attribute->meta->add_attribute(
- Class::MOP::Attribute->new('associated_class' => (
- 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
- 'associated_class' => \&Class::MOP::Attribute::associated_class
+ 'name' => \&Class::MOP::Mixin::AttributeCore::name
}
))
);
-Class::MOP::Attribute->meta->add_attribute(
+Class::MOP::Mixin::AttributeCore->meta->add_attribute(
Class::MOP::Attribute->new('accessor' => (
- reader => { 'accessor' => \&Class::MOP::Attribute::accessor },
- predicate => { 'has_accessor' => \&Class::MOP::Attribute::has_accessor },
+ reader => { 'accessor' => \&Class::MOP::Mixin::AttributeCore::accessor },
+ predicate => { 'has_accessor' => \&Class::MOP::Mixin::AttributeCore::has_accessor },
))
);
-Class::MOP::Attribute->meta->add_attribute(
+Class::MOP::Mixin::AttributeCore->meta->add_attribute(
Class::MOP::Attribute->new('reader' => (
- reader => { 'reader' => \&Class::MOP::Attribute::reader },
- predicate => { 'has_reader' => \&Class::MOP::Attribute::has_reader },
+ reader => { 'reader' => \&Class::MOP::Mixin::AttributeCore::reader },
+ predicate => { 'has_reader' => \&Class::MOP::Mixin::AttributeCore::has_reader },
))
);
-Class::MOP::Attribute->meta->add_attribute(
+Class::MOP::Mixin::AttributeCore->meta->add_attribute(
Class::MOP::Attribute->new('initializer' => (
- reader => { 'initializer' => \&Class::MOP::Attribute::initializer },
- predicate => { 'has_initializer' => \&Class::MOP::Attribute::has_initializer },
+ reader => { 'initializer' => \&Class::MOP::Mixin::AttributeCore::initializer },
+ predicate => { 'has_initializer' => \&Class::MOP::Mixin::AttributeCore::has_initializer },
))
);
-Class::MOP::Attribute->meta->add_attribute(
+Class::MOP::Mixin::AttributeCore->meta->add_attribute(
Class::MOP::Attribute->new('definition_context' => (
- reader => { 'definition_context' => \&Class::MOP::Attribute::definition_context },
+ reader => { 'definition_context' => \&Class::MOP::Mixin::AttributeCore::definition_context },
))
);
-Class::MOP::Attribute->meta->add_attribute(
+Class::MOP::Mixin::AttributeCore->meta->add_attribute(
Class::MOP::Attribute->new('writer' => (
- reader => { 'writer' => \&Class::MOP::Attribute::writer },
- predicate => { 'has_writer' => \&Class::MOP::Attribute::has_writer },
+ reader => { 'writer' => \&Class::MOP::Mixin::AttributeCore::writer },
+ predicate => { 'has_writer' => \&Class::MOP::Mixin::AttributeCore::has_writer },
))
);
-Class::MOP::Attribute->meta->add_attribute(
+Class::MOP::Mixin::AttributeCore->meta->add_attribute(
Class::MOP::Attribute->new('predicate' => (
- reader => { 'predicate' => \&Class::MOP::Attribute::predicate },
- predicate => { 'has_predicate' => \&Class::MOP::Attribute::has_predicate },
+ reader => { 'predicate' => \&Class::MOP::Mixin::AttributeCore::predicate },
+ predicate => { 'has_predicate' => \&Class::MOP::Mixin::AttributeCore::has_predicate },
))
);
-Class::MOP::Attribute->meta->add_attribute(
+Class::MOP::Mixin::AttributeCore->meta->add_attribute(
Class::MOP::Attribute->new('clearer' => (
- reader => { 'clearer' => \&Class::MOP::Attribute::clearer },
- predicate => { 'has_clearer' => \&Class::MOP::Attribute::has_clearer },
+ reader => { 'clearer' => \&Class::MOP::Mixin::AttributeCore::clearer },
+ predicate => { 'has_clearer' => \&Class::MOP::Mixin::AttributeCore::has_clearer },
))
);
-Class::MOP::Attribute->meta->add_attribute(
+Class::MOP::Mixin::AttributeCore->meta->add_attribute(
Class::MOP::Attribute->new('builder' => (
- reader => { 'builder' => \&Class::MOP::Attribute::builder },
- predicate => { 'has_builder' => \&Class::MOP::Attribute::has_builder },
+ reader => { 'builder' => \&Class::MOP::Mixin::AttributeCore::builder },
+ predicate => { 'has_builder' => \&Class::MOP::Mixin::AttributeCore::has_builder },
))
);
-Class::MOP::Attribute->meta->add_attribute(
+Class::MOP::Mixin::AttributeCore->meta->add_attribute(
Class::MOP::Attribute->new('init_arg' => (
- reader => { 'init_arg' => \&Class::MOP::Attribute::init_arg },
- predicate => { 'has_init_arg' => \&Class::MOP::Attribute::has_init_arg },
+ reader => { 'init_arg' => \&Class::MOP::Mixin::AttributeCore::init_arg },
+ predicate => { 'has_init_arg' => \&Class::MOP::Mixin::AttributeCore::has_init_arg },
))
);
-Class::MOP::Attribute->meta->add_attribute(
+Class::MOP::Mixin::AttributeCore->meta->add_attribute(
Class::MOP::Attribute->new('default' => (
# default has a custom 'reader' method ...
- predicate => { 'has_default' => \&Class::MOP::Attribute::has_default },
+ predicate => { 'has_default' => \&Class::MOP::Mixin::AttributeCore::has_default },
))
);
+Class::MOP::Mixin::AttributeCore->meta->add_attribute(
+ Class::MOP::Attribute->new('insertion_order' => (
+ reader => { 'insertion_order' => \&Class::MOP::Mixin::AttributeCore::insertion_order },
+ writer => { '_set_insertion_order' => \&Class::MOP::Mixin::AttributeCore::_set_insertion_order },
+ predicate => { 'has_insertion_order' => \&Class::MOP::Mixin::AttributeCore::has_insertion_order },
+ ))
+);
+
+## --------------------------------------------------------
+## Class::MOP::Attribute
Class::MOP::Attribute->meta->add_attribute(
- Class::MOP::Attribute->new('associated_methods' => (
- reader => { 'associated_methods' => \&Class::MOP::Attribute::associated_methods },
- default => sub { [] }
+ Class::MOP::Attribute->new('associated_class' => (
+ 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
+ 'associated_class' => \&Class::MOP::Attribute::associated_class
+ }
))
);
Class::MOP::Attribute->meta->add_attribute(
- Class::MOP::Attribute->new('insertion_order' => (
- reader => { 'insertion_order' => \&Class::MOP::Attribute::insertion_order },
- writer => { '_set_insertion_order' => \&Class::MOP::Attribute::_set_insertion_order },
- predicate => { 'has_insertion_order' => \&Class::MOP::Attribute::has_insertion_order },
+ Class::MOP::Attribute->new('associated_methods' => (
+ reader => { 'associated_methods' => \&Class::MOP::Attribute::associated_methods },
+ default => sub { [] }
))
);
Class::MOP::Method::Wrapped
/;
+$_->meta->make_immutable(
+ inline_constructor => 0,
+ constructor_name => undef,
+ inline_accessors => 0,
+) for qw/
+ Class::MOP::Mixin
+ Class::MOP::Mixin::AttributeCore
+ Class::MOP::Mixin::HasAttributes
+ Class::MOP::Mixin::HasMethods
+/;
+
1;
__END__
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
-use base 'Class::MOP::Object';
+use base 'Class::MOP::Object', 'Class::MOP::Mixin::AttributeCore';
# NOTE: (meta-circularity)
# This method will be replaced in the
confess("Setting both default and builder is not allowed.")
if exists $options{default};
} else {
- (is_default_a_coderef(\%options))
+ ($class->is_default_a_coderef(\%options))
|| confess("References are not allowed as default values, you must ".
"wrap the default of '$name' in a CODE reference (ex: sub { [] } and not [])")
if exists $options{default} && ref $options{default};
$instance->$initializer($value, $callback, $self);
}
-# NOTE:
-# the next bunch of methods will get bootstrapped
-# away in the Class::MOP bootstrapping section
-
sub associated_class { $_[0]->{'associated_class'} }
sub associated_methods { $_[0]->{'associated_methods'} }
-sub has_accessor { defined($_[0]->{'accessor'}) }
-sub has_reader { defined($_[0]->{'reader'}) }
-sub has_writer { defined($_[0]->{'writer'}) }
-sub has_predicate { defined($_[0]->{'predicate'}) }
-sub has_clearer { defined($_[0]->{'clearer'}) }
-sub has_builder { defined($_[0]->{'builder'}) }
-sub has_init_arg { defined($_[0]->{'init_arg'}) }
-sub has_default { defined($_[0]->{'default'}) }
-sub has_initializer { defined($_[0]->{'initializer'}) }
-sub has_insertion_order { defined($_[0]->{'insertion_order'}) }
-
-sub accessor { $_[0]->{'accessor'} }
-sub reader { $_[0]->{'reader'} }
-sub writer { $_[0]->{'writer'} }
-sub predicate { $_[0]->{'predicate'} }
-sub clearer { $_[0]->{'clearer'} }
-sub builder { $_[0]->{'builder'} }
-sub init_arg { $_[0]->{'init_arg'} }
-sub initializer { $_[0]->{'initializer'} }
-sub definition_context { $_[0]->{'definition_context'} }
-sub insertion_order { $_[0]->{'insertion_order'} }
-sub _set_insertion_order { $_[0]->{'insertion_order'} = $_[1] }
-
-# end bootstrapped away method section.
-# (all methods below here are kept intact)
-
-sub has_read_method { $_[0]->has_reader || $_[0]->has_accessor }
-sub has_write_method { $_[0]->has_writer || $_[0]->has_accessor }
-
sub get_read_method {
my $self = shift;
my $reader = $self->reader || $self->accessor;
}
}
-sub is_default_a_coderef {
- my ($value) = $_[0]->{'default'};
- return unless ref($value);
- return ref($value) eq 'CODE' || (blessed($value) && $value->isa('Class::MOP::Method'));
-}
-
-sub default {
- my ($self, $instance) = @_;
- if (defined $instance && $self->is_default_a_coderef) {
- # if the default is a CODE ref, then
- # we pass in the instance and default
- # can return a value based on that
- # instance. Somewhat crude, but works.
- return $self->{'default'}->($instance);
- }
- $self->{'default'};
-}
-
# slots
sub slots { (shift)->name }
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
-use base 'Class::MOP::Module';
+use base 'Class::MOP::Module', 'Class::MOP::Mixin::HasAttributes';
# Creation
no warnings 'uninitialized';
my $name = $self->name;
return unless $name =~ /^$ANON_CLASS_PREFIX/o;
+
# Moose does a weird thing where it replaces the metaclass for
# class when fixing metaclass incompatibility. In that case,
# we don't want to clean out the namespace now. We can detect
# 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'} }
# this intentionally does nothing, it is just a hook
}
+sub _attach_attribute {
+ my ($self, $attribute) = @_;
+ $attribute->attach_to_class($self);
+}
+
+sub _post_add_attribute {
+ my ( $self, $attribute ) = @_;
+
+ $self->invalidate_meta_instances;
+
+ # invalidate package flag here
+ try {
+ local $SIG{__DIE__};
+ $attribute->install_accessors;
+ }
+ catch {
+ $self->remove_attribute( $attribute->name );
+ die $_;
+ };
+}
+
+sub remove_attribute {
+ my $self = shift;
+
+ my $removed_attribute = $self->SUPER::remove_attribute(@_)
+ or return;
+
+ $self->invalidate_meta_instances;
+
+ $removed_attribute->remove_accessors;
+ $removed_attribute->detach_from_class;
+
+ return$removed_attribute;
+}
+
+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;
+}
+
+sub get_all_attributes {
+ my $self = shift;
+ my %attrs = map { %{ $self->initialize($_)->_attribute_map } }
+ reverse $self->linearized_isa;
+ return values %attrs;
+}
+
# Inheritance
sub superclasses {
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;
my ( $self, %args ) = @_;
my $name = $args{constructor_name};
+ # A class may not even have a constructor, and that's okay.
+ return unless defined $name;
if ( $self->has_method($name) && !$args{replace_constructor} ) {
my $class = $self->name;
--- /dev/null
+package Class::MOP::Mixin;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.97';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use Scalar::Util 'blessed';
+
+sub meta {
+ require Class::MOP::Class;
+ Class::MOP::Class->initialize( blessed( $_[0] ) || $_[0] );
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Class::MOP::Mixin - Base class for mixin classes
+
+=head1 DESCRIPTION
+
+This class provides a single method shared by all mixins
+
+=head1 METHODS
+
+This class provides a few methods which are useful in all metaclasses.
+
+=over 4
+
+=item B<< Class::MOP::Mixin->meta >>
+
+This returns a L<Class::MOP::Class> object for the mixin class.
+
+=back
+
+=head1 AUTHORS
+
+Dave Rolsky E<lt>autarch@urth.orgE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006-2009 by Infinity Interactive, Inc.
+
+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.
+
+=cut
--- /dev/null
+package Class::MOP::Mixin::AttributeCore;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.97';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use Scalar::Util 'blessed';
+
+use base 'Class::MOP::Mixin';
+
+sub has_accessor { defined $_[0]->{'accessor'} }
+sub has_reader { defined $_[0]->{'reader'} }
+sub has_writer { defined $_[0]->{'writer'} }
+sub has_predicate { defined $_[0]->{'predicate'} }
+sub has_clearer { defined $_[0]->{'clearer'} }
+sub has_builder { defined $_[0]->{'builder'} }
+sub has_init_arg { defined $_[0]->{'init_arg'} }
+sub has_default { defined $_[0]->{'default'} }
+sub has_initializer { defined $_[0]->{'initializer'} }
+sub has_insertion_order { defined $_[0]->{'insertion_order'} }
+
+sub accessor { $_[0]->{'accessor'} }
+sub reader { $_[0]->{'reader'} }
+sub writer { $_[0]->{'writer'} }
+sub predicate { $_[0]->{'predicate'} }
+sub clearer { $_[0]->{'clearer'} }
+sub builder { $_[0]->{'builder'} }
+sub init_arg { $_[0]->{'init_arg'} }
+sub initializer { $_[0]->{'initializer'} }
+sub definition_context { $_[0]->{'definition_context'} }
+sub insertion_order { $_[0]->{'insertion_order'} }
+sub _set_insertion_order { $_[0]->{'insertion_order'} = $_[1] }
+
+sub has_read_method { $_[0]->has_reader || $_[0]->has_accessor }
+sub has_write_method { $_[0]->has_writer || $_[0]->has_accessor }
+
+sub is_default_a_coderef {
+ # Uber hack because it is called from CMOP::Attribute constructor as
+ # $class->is_default_a_coderef(\%options)
+ my ($value) = ref $_[0] ? $_[0]->{'default'} : $_[1]->{'default'};
+
+ return unless ref($value);
+
+ return ref($value) eq 'CODE'
+ || ( blessed($value) && $value->isa('Class::MOP::Method') );
+}
+
+sub default {
+ my ( $self, $instance ) = @_;
+ if ( defined $instance && $self->is_default_a_coderef ) {
+ # if the default is a CODE ref, then we pass in the instance and
+ # default can return a value based on that instance. Somewhat crude,
+ # but works.
+ return $self->{'default'}->($instance);
+ }
+ $self->{'default'};
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Class::MOP::Mixin::AttributeCore - Core attributes shared by attribute metaclasses
+
+=head1 DESCRIPTION
+
+This class implements the core attributes (aka properties) shared by all
+attributes. See the L<Class::MOP::Attribute> documentation for API details.
+
+=head1 AUTHORS
+
+Dave Rolsky E<lt>autarch@urth.orgE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006-2009 by Infinity Interactive, Inc.
+
+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.
+
+=cut
--- /dev/null
+package Class::MOP::Mixin::HasAttributes;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.97';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use Carp 'confess';
+use Scalar::Util 'blessed';
+
+use base 'Class::MOP::Mixin';
+
+sub _attribute_map { $_[0]->{'attributes'} }
+sub attribute_metaclass { $_[0]->{'attribute_metaclass'} }
+
+sub add_attribute {
+ my $self = shift;
+
+ my $attribute
+ = blessed( $_[0] ) ? $_[0] : $self->attribute_metaclass->new(@_);
+
+ ( $attribute->isa('Class::MOP::Mixin::AttributeCore') )
+ || confess
+ "Your attribute must be an instance of Class::MOP::Mixin::AttributeCore (or a subclass)";
+
+ $self->_attach_attribute($attribute);
+
+ my $attr_name = $attribute->name;
+
+ $self->remove_attribute($attr_name)
+ if $self->has_attribute($attr_name);
+
+ my $order = ( scalar keys %{ $self->_attribute_map } );
+ $attribute->_set_insertion_order($order);
+
+ $self->_attribute_map->{$attr_name} = $attribute;
+
+ # This method is called to allow for installing accessors. Ideally, we'd
+ # use method overriding, but then the subclass would be responsible for
+ # making the attribute, which would end up with lots of code
+ # duplication. Even more ideally, we'd use augment/inner, but this is
+ # Class::MOP!
+ $self->_post_add_attribute($attribute)
+ if $self->can('_post_add_attribute');
+
+ 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};
+
+ return $removed_attribute;
+}
+
+sub get_attribute_list {
+ my $self = shift;
+ keys %{ $self->_attribute_map };
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Class::MOP::Mixin::HasMethods - Methods for metaclasses which have attributes
+
+=head1 DESCRIPTION
+
+This class implements methods for metaclasses which have attributes
+(L<Class::MOP::Class> and L<Moose::Meta::Role>). See L<Class::MOP::Class> for
+API details.
+
+=head1 AUTHORS
+
+Dave Rolsky E<lt>autarch@urth.orgE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006-2009 by Infinity Interactive, Inc.
+
+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.
+
+=cut
--- /dev/null
+package Class::MOP::Mixin::HasMethods;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.97';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use Scalar::Util 'blessed';
+use Carp 'confess';
+use Sub::Name 'subname';
+
+use base 'Class::MOP::Mixin';
+
+sub method_metaclass { $_[0]->{'method_metaclass'} }
+sub wrapped_method_metaclass { $_[0]->{'wrapped_method_metaclass'} }
+
+# This doesn't always get initialized in a constructor because there is a
+# weird object construction path for subclasses of Class::MOP::Class. At one
+# point, this always got initialized by calling into the XS code first, but
+# that is no longer guaranteed to happen.
+sub _method_map { $_[0]->{'methods'} ||= {} }
+
+sub wrap_method_body {
+ my ( $self, %args ) = @_;
+
+ ( 'CODE' eq ref $args{body} )
+ || confess "Your code block must be a CODE reference";
+
+ $self->method_metaclass->wrap(
+ package_name => $self->name,
+ %args,
+ );
+}
+
+sub add_method {
+ my ( $self, $method_name, $method ) = @_;
+ ( defined $method_name && length $method_name )
+ || confess "You must define a method name";
+
+ my $body;
+ if ( blessed($method) ) {
+ $body = $method->body;
+ if ( $method->package_name ne $self->name ) {
+ $method = $method->clone(
+ package_name => $self->name,
+ name => $method_name,
+ ) if $method->can('clone');
+ }
+
+ $method->attach_to_class($self);
+ }
+ else {
+ # If a raw code reference is supplied, its method object is not created.
+ # The method object won't be created until required.
+ $body = $method;
+ }
+
+ $self->_method_map->{$method_name} = $method;
+
+ my ( $current_package, $current_name ) = Class::MOP::get_code_info($body);
+
+ if ( !defined $current_name || $current_name =~ /^__ANON__/ ) {
+ my $full_method_name = ( $self->name . '::' . $method_name );
+ subname( $full_method_name => $body );
+ }
+
+ $self->add_package_symbol(
+ { sigil => '&', type => 'CODE', name => $method_name },
+ $body,
+ );
+}
+
+sub _code_is_mine {
+ my ( $self, $code ) = @_;
+
+ my ( $code_package, $code_name ) = Class::MOP::get_code_info($code);
+
+ return $code_package && $code_package eq $self->name
+ || ( $code_package eq 'constant' && $code_name eq '__ANON__' );
+}
+
+sub has_method {
+ my ( $self, $method_name ) = @_;
+
+ ( defined $method_name && length $method_name )
+ || confess "You must define a method name";
+
+ return defined( $self->get_method($method_name) );
+}
+
+sub get_method {
+ my ( $self, $method_name ) = @_;
+
+ ( defined $method_name && length $method_name )
+ || confess "You must define a method name";
+
+ my $method_map = $self->_method_map;
+ my $map_entry = $method_map->{$method_name};
+ my $code = $self->get_package_symbol(
+ {
+ name => $method_name,
+ sigil => '&',
+ type => 'CODE',
+ }
+ );
+
+ # This seems to happen in some weird cases where methods modifiers are
+ # added via roles or some other such bizareness. Honestly, I don't totally
+ # understand this, but returning the entry works, and keeps various MX
+ # modules from blowing up. - DR
+ return $map_entry if blessed $map_entry && !$code;
+
+ return $map_entry if blessed $map_entry && $map_entry->body == $code;
+
+ unless ($map_entry) {
+ return unless $code && $self->_code_is_mine($code);
+ }
+
+ $code ||= $map_entry;
+
+ return $method_map->{$method_name} = $self->wrap_method_body(
+ body => $code,
+ name => $method_name,
+ associated_metaclass => $self,
+ );
+}
+
+sub remove_method {
+ my ( $self, $method_name ) = @_;
+ ( defined $method_name && length $method_name )
+ || confess "You must define a method name";
+
+ my $removed_method = delete $self->_full_method_map->{$method_name};
+
+ $self->remove_package_symbol(
+ { sigil => '&', type => 'CODE', name => $method_name } );
+
+ $removed_method->detach_from_class
+ if $removed_method && blessed $removed_method;
+
+ # still valid, since we just removed the method from the map
+ $self->update_package_cache_flag;
+
+ return $removed_method;
+}
+
+sub get_method_list {
+ my $self = shift;
+ return grep { $self->has_method($_) } keys %{ $self->namespace };
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Class::MOP::Mixin::HasMethods - Methods for metaclasses which have methods
+
+=head1 DESCRIPTION
+
+This class implements methods for metaclasses which have methods
+(L<Class::MOP::Package> and L<Moose::Meta::Role>). See L<Class::MOP::Package>
+for API details.
+
+=head1 AUTHORS
+
+Dave Rolsky E<lt>autarch@urth.orgE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006-2009 by Infinity Interactive, Inc.
+
+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.
+
+=cut
use Scalar::Util 'blessed', 'reftype';
use Carp 'confess';
-use Sub::Name 'subname';
our $VERSION = '0.97';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
-use base 'Class::MOP::Object';
+use base 'Class::MOP::Object', 'Class::MOP::Mixin::HasMethods';
# creation ...
\%{$_[0]->{'package'} . '::'}
}
-sub method_metaclass { $_[0]->{'method_metaclass'} }
-sub wrapped_method_metaclass { $_[0]->{'wrapped_method_metaclass'} }
-
-# This doesn't always get initialized in a constructor because there is a
-# weird object construction path for subclasses of Class::MOP::Class. At one
-# point, this always got initialized by calling into the XS code first, but
-# that is no longer guaranteed to happen.
-sub _method_map { $_[0]->{'methods'} ||= {} }
-
# utility methods
{
}
}
-## Methods
-
-sub wrap_method_body {
- my ( $self, %args ) = @_;
-
- ('CODE' eq ref $args{body})
- || confess "Your code block must be a CODE reference";
-
- $self->method_metaclass->wrap(
- package_name => $self->name,
- %args,
- );
-}
-
-sub add_method {
- my ($self, $method_name, $method) = @_;
- (defined $method_name && length $method_name)
- || confess "You must define a method name";
-
- my $body;
- if (blessed($method)) {
- $body = $method->body;
- if ($method->package_name ne $self->name) {
- $method = $method->clone(
- package_name => $self->name,
- name => $method_name,
- ) if $method->can('clone');
- }
-
- $method->attach_to_class($self);
- }
- else {
- # If a raw code reference is supplied, its method object is not created.
- # The method object won't be created until required.
- $body = $method;
- }
-
- $self->_method_map->{$method_name} = $method;
-
- my ( $current_package, $current_name ) = Class::MOP::get_code_info($body);
-
- if ( !defined $current_name || $current_name =~ /^__ANON__/ ) {
- my $full_method_name = ($self->name . '::' . $method_name);
- subname($full_method_name => $body);
- }
-
- $self->add_package_symbol(
- { sigil => '&', type => 'CODE', name => $method_name },
- $body,
- );
-}
-
-sub _code_is_mine {
- my ( $self, $code ) = @_;
-
- my ( $code_package, $code_name ) = Class::MOP::get_code_info($code);
-
- return $code_package && $code_package eq $self->name
- || ( $code_package eq 'constant' && $code_name eq '__ANON__' );
-}
-
-sub has_method {
- my ($self, $method_name) = @_;
-
- (defined $method_name && length $method_name)
- || confess "You must define a method name";
-
- return defined($self->get_method($method_name));
-}
-
-sub get_method {
- my ( $self, $method_name ) = @_;
-
- (defined $method_name && length $method_name)
- || confess "You must define a method name";
-
- my $method_map = $self->_method_map;
- my $map_entry = $method_map->{$method_name};
- my $code = $self->get_package_symbol(
- {
- name => $method_name,
- sigil => '&',
- type => 'CODE',
- }
- );
-
- # This seems to happen in some weird cases where methods modifiers are
- # added via roles or some other such bizareness. Honestly, I don't totally
- # understand this, but returning the entry works, and keeps various MX
- # modules from blowing up. - DR
- return $map_entry if blessed $map_entry && !$code;
-
- return $map_entry if blessed $map_entry && $map_entry->body == $code;
-
- unless ($map_entry) {
- return unless $code && $self->_code_is_mine($code);
- }
-
- $code ||= $map_entry;
-
- return $method_map->{$method_name} = $self->wrap_method_body(
- body => $code,
- name => $method_name,
- associated_metaclass => $self,
- );
-}
-
-sub remove_method {
- my ($self, $method_name) = @_;
- (defined $method_name && length $method_name)
- || confess "You must define a method name";
-
- my $removed_method = delete $self->_full_method_map->{$method_name};
-
- $self->remove_package_symbol(
- { sigil => '&', type => 'CODE', name => $method_name }
- );
-
- $removed_method->detach_from_class if $removed_method && blessed $removed_method;
-
- $self->update_package_cache_flag; # still valid, since we just removed the method from the map
-
- return $removed_method;
-}
-
-sub get_method_list {
- my $self = shift;
- return grep { $self->has_method($_) } keys %{ $self->namespace };
-}
-
1;
__END__
BEGIN {
use_ok('Class::MOP');
+ use_ok('Class::MOP::Mixin');
+ use_ok('Class::MOP::Mixin::AttributeCore');
+ use_ok('Class::MOP::Mixin::HasAttributes');
+ use_ok('Class::MOP::Mixin::HasMethods');
use_ok('Class::MOP::Package');
use_ok('Class::MOP::Module');
use_ok('Class::MOP::Class');
use_ok('Class::MOP::Class::Immutable::Trait');
- use_ok('Class::MOP::Attribute');
+ use_ok('Class::MOP::Method');
use_ok('Class::MOP::Method');
use_ok('Class::MOP::Method::Wrapped');
use_ok('Class::MOP::Method::Inlined');
'Class::MOP::Method::Accessor' => Class::MOP::Method::Accessor->meta,
'Class::MOP::Method::Constructor' =>
Class::MOP::Method::Constructor->meta,
+ 'Class::MOP::Mixin' => Class::MOP::Mixin->meta,
+ 'Class::MOP::Mixin::AttributeCore' => Class::MOP::Mixin::AttributeCore->meta,
+ 'Class::MOP::Mixin::HasAttributes' => Class::MOP::Mixin::HasAttributes->meta,
+ 'Class::MOP::Mixin::HasMethods' => Class::MOP::Mixin::HasMethods->meta,
'Class::MOP::Package' => Class::MOP::Package->meta,
'Class::MOP::Module' => Class::MOP::Module->meta,
'Class::MOP::Class' => Class::MOP::Class->meta,
Class::MOP::Method::Generated->meta,
Class::MOP::Method::Inlined->meta,
Class::MOP::Method::Wrapped->meta,
+ Class::MOP::Mixin->meta,
+ Class::MOP::Mixin::AttributeCore->meta,
+ Class::MOP::Mixin::HasAttributes->meta,
+ Class::MOP::Mixin::HasMethods->meta,
Class::MOP::Module->meta,
Class::MOP::Object->meta,
Class::MOP::Package->meta,
Class::MOP::Class
Class::MOP::Class::Immutable::Class::MOP::Class
Class::MOP::Class::Immutable::Trait
+ Class::MOP::Mixin
+ Class::MOP::Mixin::AttributeCore
+ Class::MOP::Mixin::HasAttributes
+ Class::MOP::Mixin::HasMethods
Class::MOP::Instance
Class::MOP::Method
Class::MOP::Method::Accessor
add_package_symbol get_package_symbol has_package_symbol remove_package_symbol
list_all_package_symbols get_all_package_symbols remove_package_glob
- method_metaclass wrapped_method_metaclass
-
- _method_map
- _code_is_mine
- has_method get_method add_method remove_method wrap_method_body
- get_method_list _full_method_map
-
_deconstruct_variable_name
get_method_map
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
+ _attach_attribute
+ _post_add_attribute
+ remove_attribute
+ find_attribute_by_name
+ get_all_attributes
+ compute_all_applicable_attributes
get_attribute_map
is_mutable is_immutable make_mutable make_immutable
my @class_mop_package_attributes = (
'package',
'namespace',
- 'method_metaclass',
- 'wrapped_method_metaclass',
- '_methods',
);
my @class_mop_module_attributes = (
my @class_mop_class_attributes = (
'superclasses',
- 'attributes',
- 'attribute_metaclass',
'instance_metaclass',
'immutable_trait',
'constructor_name',
ok($class_mop_package_meta->get_attribute('package')->has_init_arg, '... Class::MOP::Class package has a init_arg');
is($class_mop_package_meta->get_attribute('package')->init_arg, 'package', '... Class::MOP::Class package\'s a init_arg is package');
-ok($class_mop_package_meta->get_attribute('method_metaclass')->has_reader, '... Class::MOP::Package method_metaclass has a reader');
-is_deeply($class_mop_package_meta->get_attribute('method_metaclass')->reader,
- { 'method_metaclass' => \&Class::MOP::Package::method_metaclass },
+# ... package, but inherited from HasMethods
+ok($class_mop_package_meta->find_attribute_by_name('method_metaclass')->has_reader, '... Class::MOP::Package method_metaclass has a reader');
+is_deeply($class_mop_package_meta->find_attribute_by_name('method_metaclass')->reader,
+ { 'method_metaclass' => \&Class::MOP::Mixin::HasMethods::method_metaclass },
'... Class::MOP::Package method_metaclass\'s a reader is &method_metaclass');
-ok($class_mop_package_meta->get_attribute('method_metaclass')->has_init_arg, '... Class::MOP::Package method_metaclass has a init_arg');
-is($class_mop_package_meta->get_attribute('method_metaclass')->init_arg,
+ok($class_mop_package_meta->find_attribute_by_name('method_metaclass')->has_init_arg, '... Class::MOP::Package method_metaclass has a init_arg');
+is($class_mop_package_meta->find_attribute_by_name('method_metaclass')->init_arg,
'method_metaclass',
'... Class::MOP::Package method_metaclass\'s init_arg is method_metaclass');
-ok($class_mop_package_meta->get_attribute('method_metaclass')->has_default, '... Class::MOP::Package method_metaclass has a default');
-is($class_mop_package_meta->get_attribute('method_metaclass')->default,
+ok($class_mop_package_meta->find_attribute_by_name('method_metaclass')->has_default, '... Class::MOP::Package method_metaclass has a default');
+is($class_mop_package_meta->find_attribute_by_name('method_metaclass')->default,
'Class::MOP::Method',
'... Class::MOP::Package method_metaclass\'s a default is Class::MOP:::Method');
-ok($class_mop_package_meta->get_attribute('wrapped_method_metaclass')->has_reader, '... Class::MOP::Package wrapped_method_metaclass has a reader');
-is_deeply($class_mop_package_meta->get_attribute('wrapped_method_metaclass')->reader,
- { 'wrapped_method_metaclass' => \&Class::MOP::Package::wrapped_method_metaclass },
+ok($class_mop_package_meta->find_attribute_by_name('wrapped_method_metaclass')->has_reader, '... Class::MOP::Package wrapped_method_metaclass has a reader');
+is_deeply($class_mop_package_meta->find_attribute_by_name('wrapped_method_metaclass')->reader,
+ { 'wrapped_method_metaclass' => \&Class::MOP::Mixin::HasMethods::wrapped_method_metaclass },
'... Class::MOP::Package wrapped_method_metaclass\'s a reader is &wrapped_method_metaclass');
-ok($class_mop_package_meta->get_attribute('wrapped_method_metaclass')->has_init_arg, '... Class::MOP::Package wrapped_method_metaclass has a init_arg');
-is($class_mop_package_meta->get_attribute('wrapped_method_metaclass')->init_arg,
+ok($class_mop_package_meta->find_attribute_by_name('wrapped_method_metaclass')->has_init_arg, '... Class::MOP::Package wrapped_method_metaclass has a init_arg');
+is($class_mop_package_meta->find_attribute_by_name('wrapped_method_metaclass')->init_arg,
'wrapped_method_metaclass',
'... Class::MOP::Package wrapped_method_metaclass\'s init_arg is wrapped_method_metaclass');
-ok($class_mop_package_meta->get_attribute('method_metaclass')->has_default, '... Class::MOP::Package method_metaclass has a default');
-is($class_mop_package_meta->get_attribute('method_metaclass')->default,
+ok($class_mop_package_meta->find_attribute_by_name('method_metaclass')->has_default, '... Class::MOP::Package method_metaclass has a default');
+is($class_mop_package_meta->find_attribute_by_name('method_metaclass')->default,
'Class::MOP::Method',
'... 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::Mixin::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::Mixin::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::Mixin::HasAttributes/ ],
'... Class::MOP::Class->superclasses == [ Class::MOP::Module ]');
is_deeply(
Class::MOP::Module
Class::MOP::Package
Class::MOP::Object
+ Class::MOP::Mixin::HasMethods
+ Class::MOP::Mixin
+ Class::MOP::Mixin::HasAttributes
+ Class::MOP::Mixin
/ ],
'... Class::MOP::Class->class_precedence_list == [ Class::MOP::Class Class::MOP::Module Class::MOP::Package ]');
{
my $attr = Class::MOP::Attribute->new('$test');
- is($attr->meta, Class::MOP::Attribute->meta, '... instance and class both lead to the same meta');
+ is( $attr->meta, Class::MOP::Attribute->meta,
+ '... instance and class both lead to the same meta' );
}
{
my $meta = Class::MOP::Attribute->meta();
- isa_ok($meta, 'Class::MOP::Class');
+ isa_ok( $meta, 'Class::MOP::Class' );
my @methods = qw(
new
remove_accessors
_new
- );
+ );
is_deeply(
- [ sort $meta->get_method_list ],
+ [
+ sort Class::MOP::Mixin::AttributeCore->meta->get_method_list,
+ $meta->get_method_list
+ ],
[ sort @methods ],
- '... our method list matches');
+ '... our method list matches'
+ );
foreach my $method_name (@methods) {
- ok($meta->has_method($method_name), '... Class::MOP::Attribute->has_method(' . $method_name . ')');
+ ok( $meta->find_method_by_name($method_name),
+ '... Class::MOP::Attribute->find_method_by_name(' . $method_name . ')' );
}
my @attributes = (
);
is_deeply(
- [ sort $meta->get_attribute_list ],
+ [
+ sort Class::MOP::Mixin::AttributeCore->meta->get_attribute_list,
+ $meta->get_attribute_list
+ ],
[ sort @attributes ],
- '... our attribute list matches');
+ '... our attribute list matches'
+ );
foreach my $attribute_name (@attributes) {
- ok($meta->has_attribute($attribute_name), '... Class::MOP::Attribute->has_attribute(' . $attribute_name . ')');
+ ok( $meta->find_attribute_by_name($attribute_name),
+ '... Class::MOP::Attribute->find_attribute_by_name('
+ . $attribute_name
+ . ')' );
}
# We could add some tests here to make sure that
+++ /dev/null
-#include "mop.h"
-
-MODULE = Class::MOP::Attribute PACKAGE = Class::MOP::Attribute
-
-PROTOTYPES: DISABLE
-
-BOOT:
- INSTALL_SIMPLE_READER(Attribute, name);
--- /dev/null
+#include "mop.h"
+
+MODULE = Class::MOP::Mixin::AttributeCore PACKAGE = Class::MOP::Mixin::AttributeCore
+
+PROTOTYPES: DISABLE
+
+BOOT:
+ INSTALL_SIMPLE_READER(Mixin::AttributeCore, name);
--- /dev/null
+#include "mop.h"
+
+SV *mop_method_metaclass;
+SV *mop_associated_metaclass;
+SV *mop_wrap;
+
+static void
+mop_update_method_map(pTHX_ SV *const self, SV *const class_name, HV *const stash, HV *const map)
+{
+ const char *const class_name_pv = HvNAME(stash); /* must be HvNAME(stash), not SvPV_nolen_const(class_name) */
+ SV *method_metaclass_name;
+ char *method_name;
+ I32 method_name_len;
+ SV *coderef;
+ HV *symbols;
+ dSP;
+
+ symbols = mop_get_all_package_symbols(stash, TYPE_FILTER_CODE);
+ sv_2mortal((SV*)symbols);
+ (void)hv_iterinit(symbols);
+ while ( (coderef = hv_iternextsv(symbols, &method_name, &method_name_len)) ) {
+ CV *cv = (CV *)SvRV(coderef);
+ char *cvpkg_name;
+ char *cv_name;
+ SV *method_slot;
+ SV *method_object;
+
+ if (!mop_get_code_info(coderef, &cvpkg_name, &cv_name)) {
+ continue;
+ }
+
+ /* this checks to see that the subroutine is actually from our package */
+ if ( !(strEQ(cvpkg_name, "constant") && strEQ(cv_name, "__ANON__")) ) {
+ if ( strNE(cvpkg_name, class_name_pv) ) {
+ continue;
+ }
+ }
+
+ method_slot = *hv_fetch(map, method_name, method_name_len, TRUE);
+ if ( SvOK(method_slot) ) {
+ SV *body;
+
+ if ( sv_isobject(method_slot) ) {
+ body = mop_call0(aTHX_ method_slot, KEY_FOR(body)); /* $method_object->body() */
+ }
+ else {
+ body = method_slot;
+ }
+
+ if ( SvROK(body) && ((CV *) SvRV(body)) == cv ) {
+ continue;
+ }
+ }
+
+ method_metaclass_name = mop_call0(aTHX_ self, mop_method_metaclass); /* $self->method_metaclass() */
+
+ /*
+ $method_object = $method_metaclass->wrap(
+ $cv,
+ associated_metaclass => $self,
+ package_name => $class_name,
+ name => $method_name
+ );
+ */
+ ENTER;
+ SAVETMPS;
+
+ PUSHMARK(SP);
+ EXTEND(SP, 8);
+ PUSHs(method_metaclass_name); /* invocant */
+ mPUSHs(newRV_inc((SV *)cv));
+ PUSHs(mop_associated_metaclass);
+ PUSHs(self);
+ PUSHs(KEY_FOR(package_name));
+ PUSHs(class_name);
+ PUSHs(KEY_FOR(name));
+ mPUSHs(newSVpv(method_name, method_name_len));
+ PUTBACK;
+
+ call_sv(mop_wrap, G_SCALAR | G_METHOD);
+ SPAGAIN;
+ method_object = POPs;
+ PUTBACK;
+ /* $map->{$method_name} = $method_object */
+ sv_setsv(method_slot, method_object);
+
+ FREETMPS;
+ LEAVE;
+ }
+}
+
+MODULE = Class::MOP::Mixin::HasMethods PACKAGE = Class::MOP::Mixin::HasMethods
+
+PROTOTYPES: DISABLE
+
+void
+_full_method_map(self)
+ SV *self
+ PREINIT:
+ HV *const obj = (HV *)SvRV(self);
+ SV *const class_name = HeVAL( hv_fetch_ent(obj, KEY_FOR(package), 0, HASH_FOR(package)) );
+ HV *const stash = gv_stashsv(class_name, 0);
+ UV current;
+ SV *cache_flag;
+ SV *map_ref;
+ PPCODE:
+ if (!stash) {
+ mXPUSHs(newRV_noinc((SV *)newHV()));
+ return;
+ }
+
+ current = mop_check_package_cache_flag(aTHX_ stash);
+ cache_flag = HeVAL( hv_fetch_ent(obj, KEY_FOR(package_cache_flag), TRUE, HASH_FOR(package_cache_flag)));
+ map_ref = HeVAL( hv_fetch_ent(obj, KEY_FOR(methods), TRUE, HASH_FOR(methods)));
+
+ /* $self->{methods} does not yet exist (or got deleted) */
+ if ( !SvROK(map_ref) || SvTYPE(SvRV(map_ref)) != SVt_PVHV ) {
+ SV *new_map_ref = newRV_noinc((SV *)newHV());
+ sv_2mortal(new_map_ref);
+ sv_setsv(map_ref, new_map_ref);
+ }
+
+ if ( !SvOK(cache_flag) || SvUV(cache_flag) != current ) {
+ mop_update_method_map(aTHX_ self, class_name, stash, (HV *)SvRV(map_ref));
+ sv_setuv(cache_flag, mop_check_package_cache_flag(aTHX_ stash)); /* update_cache_flag() */
+ }
+
+ XPUSHs(map_ref);
+
+BOOT:
+ mop_method_metaclass = newSVpvs("method_metaclass");
+ mop_associated_metaclass = newSVpvs("associated_metaclass");
+ mop_wrap = newSVpvs("wrap");
#include "mop.h"
-SV *mop_method_metaclass;
-SV *mop_associated_metaclass;
-SV *mop_wrap;
-
static bool
find_method (const char *key, STRLEN keylen, SV *val, void *ud)
{
return FALSE;
}
+EXTERN_C XS(boot_Class__MOP__Mixin__HasMethods);
EXTERN_C XS(boot_Class__MOP__Package);
-EXTERN_C XS(boot_Class__MOP__Attribute);
+EXTERN_C XS(boot_Class__MOP__Mixin__AttributeCore);
EXTERN_C XS(boot_Class__MOP__Method);
MODULE = Class::MOP PACKAGE = Class::MOP
BOOT:
mop_prehash_keys();
- mop_method_metaclass = newSVpvs("method_metaclass");
- mop_wrap = newSVpvs("wrap");
- mop_associated_metaclass = newSVpvs("associated_metaclass");
-
+ MOP_CALL_BOOT (boot_Class__MOP__Mixin__HasMethods);
MOP_CALL_BOOT (boot_Class__MOP__Package);
- MOP_CALL_BOOT (boot_Class__MOP__Attribute);
+ MOP_CALL_BOOT (boot_Class__MOP__Mixin__AttributeCore);
MOP_CALL_BOOT (boot_Class__MOP__Method);
# use prototype here to be compatible with get_code_info from Sub::Identify
#include "mop.h"
-static void
-mop_update_method_map(pTHX_ SV *const self, SV *const class_name, HV *const stash, HV *const map)
-{
- const char *const class_name_pv = HvNAME(stash); /* must be HvNAME(stash), not SvPV_nolen_const(class_name) */
- SV *method_metaclass_name;
- char *method_name;
- I32 method_name_len;
- SV *coderef;
- HV *symbols;
- dSP;
-
- symbols = mop_get_all_package_symbols(stash, TYPE_FILTER_CODE);
- sv_2mortal((SV*)symbols);
- (void)hv_iterinit(symbols);
- while ( (coderef = hv_iternextsv(symbols, &method_name, &method_name_len)) ) {
- CV *cv = (CV *)SvRV(coderef);
- char *cvpkg_name;
- char *cv_name;
- SV *method_slot;
- SV *method_object;
-
- if (!mop_get_code_info(coderef, &cvpkg_name, &cv_name)) {
- continue;
- }
-
- /* this checks to see that the subroutine is actually from our package */
- if ( !(strEQ(cvpkg_name, "constant") && strEQ(cv_name, "__ANON__")) ) {
- if ( strNE(cvpkg_name, class_name_pv) ) {
- continue;
- }
- }
-
- method_slot = *hv_fetch(map, method_name, method_name_len, TRUE);
- if ( SvOK(method_slot) ) {
- SV *body;
-
- if ( sv_isobject(method_slot) ) {
- body = mop_call0(aTHX_ method_slot, KEY_FOR(body)); /* $method_object->body() */
- }
- else {
- body = method_slot;
- }
-
- if ( SvROK(body) && ((CV *) SvRV(body)) == cv ) {
- continue;
- }
- }
-
- method_metaclass_name = mop_call0(aTHX_ self, mop_method_metaclass); /* $self->method_metaclass() */
-
- /*
- $method_object = $method_metaclass->wrap(
- $cv,
- associated_metaclass => $self,
- package_name => $class_name,
- name => $method_name
- );
- */
- ENTER;
- SAVETMPS;
-
- PUSHMARK(SP);
- EXTEND(SP, 8);
- PUSHs(method_metaclass_name); /* invocant */
- mPUSHs(newRV_inc((SV *)cv));
- PUSHs(mop_associated_metaclass);
- PUSHs(self);
- PUSHs(KEY_FOR(package_name));
- PUSHs(class_name);
- PUSHs(KEY_FOR(name));
- mPUSHs(newSVpv(method_name, method_name_len));
- PUTBACK;
-
- call_sv(mop_wrap, G_SCALAR | G_METHOD);
- SPAGAIN;
- method_object = POPs;
- PUTBACK;
- /* $map->{$method_name} = $method_object */
- sv_setsv(method_slot, method_object);
-
- FREETMPS;
- LEAVE;
- }
-}
-
MODULE = Class::MOP::Package PACKAGE = Class::MOP::Package
PROTOTYPES: DISABLE
symbols = mop_get_all_package_symbols(stash, filter);
PUSHs(sv_2mortal(newRV_noinc((SV *)symbols)));
-void
-_full_method_map(self)
- SV *self
- PREINIT:
- HV *const obj = (HV *)SvRV(self);
- SV *const class_name = HeVAL( hv_fetch_ent(obj, KEY_FOR(package), 0, HASH_FOR(package)) );
- HV *const stash = gv_stashsv(class_name, 0);
- UV current;
- SV *cache_flag;
- SV *map_ref;
- PPCODE:
- if (!stash) {
- mXPUSHs(newRV_noinc((SV *)newHV()));
- return;
- }
-
- current = mop_check_package_cache_flag(aTHX_ stash);
- cache_flag = HeVAL( hv_fetch_ent(obj, KEY_FOR(package_cache_flag), TRUE, HASH_FOR(package_cache_flag)));
- map_ref = HeVAL( hv_fetch_ent(obj, KEY_FOR(methods), TRUE, HASH_FOR(methods)));
-
- /* $self->{methods} does not yet exist (or got deleted) */
- if ( !SvROK(map_ref) || SvTYPE(SvRV(map_ref)) != SVt_PVHV ) {
- SV *new_map_ref = newRV_noinc((SV *)newHV());
- sv_2mortal(new_map_ref);
- sv_setsv(map_ref, new_map_ref);
- }
-
- if ( !SvOK(cache_flag) || SvUV(cache_flag) != current ) {
- mop_update_method_map(aTHX_ self, class_name, stash, (HV *)SvRV(map_ref));
- sv_setuv(cache_flag, mop_check_package_cache_flag(aTHX_ stash)); /* update_cache_flag() */
- }
-
- XPUSHs(map_ref);
-
BOOT:
INSTALL_SIMPLE_READER_WITH_KEY(Package, name, package);
'Class::MOP' => [ 'HAVE_ISAREV', 'subname', 'in_global_destruction' ],
'Class::MOP::Attribute' => ['process_accessors'],
'Class::MOP::Class' => [
-
# deprecated
'alias_method',
'compute_all_applicable_attributes',
'Class::MOP::Class::Immutable::Trait' => ['.+'],
'Class::MOP::Class::Immutable::Class::MOP::Class' => ['.+'],
'Class::MOP::Deprecated' => ['.+'],
-
- 'Class::MOP::Instance' => [
+ 'Class::MOP::Instance' => [
qw( BUILDARGS
bless_instance_structure
is_dependent_on_superclasses ),
initialize_body
)
],
- 'Class::MOP::Module' => ['create'],
+ 'Class::MOP::Mixin::AttributeCore' => ['.+'],
+ 'Class::MOP::Mixin::HasAttributes' => ['.+'],
+ 'Class::MOP::Mixin::HasMethods' => ['.+'],
+ 'Class::MOP::Module' => ['create'],
'Class::MOP::Package' => [ 'get_method_map', 'wrap_method_body' ],
);
isa
login
metadata
+mixin
+mixins
munge
namespace
namespaced
projects / gitmo/Class-MOP.git / commitdiff