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;
use Class::MOP::Method;
# inherit them using _construct_instance
## --------------------------------------------------------
-## Class::MOP::Package
+## Class::MOP::HasMethods
-Class::MOP::Package->meta->add_attribute(
- Class::MOP::Attribute->new('package' => (
+Class::MOP::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::HasMethods::_full_method_map
},
+ default => sub { {} }
))
);
-Class::MOP::Package->meta->add_attribute(
- Class::MOP::Attribute->new('namespace' => (
- reader => {
+Class::MOP::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::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::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::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::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
- 'method_metaclass' => \&Class::MOP::Package::method_metaclass
+ 'attribute_metaclass' => \&Class::MOP::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
Class::MOP::Method::Wrapped
/;
+$_->meta->make_immutable(
+ inline_constructor => 0,
+ constructor_name => undef,
+ inline_accessors => 0,
+) for qw/
+ Class::MOP::HasAttributes
+ Class::MOP::HasMethods
+/;
+
1;
__END__
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
-use base 'Class::MOP::Module';
+use base 'Class::MOP::Module', 'Class::MOP::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::HasAttributes;
+
+use strict;
+use warnings;
+
+use Carp 'confess';
+use Scalar::Util 'blessed';
+
+use base 'Class::MOP::Object';
+
+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::Attribute') )
+ || confess
+ "Your attribute must be an instance of Class::MOP::Attribute (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;
--- /dev/null
+package Class::MOP::HasMethods;
+
+use strict;
+use warnings;
+
+use Scalar::Util 'blessed';
+use Carp 'confess';
+use Sub::Name 'subname';
+
+use base 'Class::MOP::Object';
+
+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;
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::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::HasAttributes');
+ use_ok('Class::MOP::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::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' => Class::MOP::Class->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::Method::Accessor->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
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::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::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::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::Class
Class::MOP::Module
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 ]');
--- /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::HasMethods PACKAGE = Class::MOP::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__HasMethods);
EXTERN_C XS(boot_Class__MOP__Package);
EXTERN_C XS(boot_Class__MOP__Attribute);
EXTERN_C XS(boot_Class__MOP__Method);
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__HasMethods);
MOP_CALL_BOOT (boot_Class__MOP__Package);
MOP_CALL_BOOT (boot_Class__MOP__Attribute);
MOP_CALL_BOOT (boot_Class__MOP__Method);
#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);
projects / gitmo/Class-MOP.git / commitdiff