use Scalar::Util 'weaken', 'reftype', 'blessed';
use Try::Tiny;
+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
+
Class::MOP::Package->meta->add_attribute(
- Class::MOP::Attribute->new('method_metaclass' => (
+ Class::MOP::Attribute->new('package' => (
reader => {
- # NOTE:
+ # 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
- 'method_metaclass' => \&Class::MOP::Package::method_metaclass
+ 'name' => \&Class::MOP::Package::name
},
- default => 'Class::MOP::Method',
))
);
Class::MOP::Package->meta->add_attribute(
- Class::MOP::Attribute->new('wrapped_method_metaclass' => (
- reader => {
+ 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::Method::Wrapped
/;
+$_->meta->make_immutable(
+ inline_constructor => 0,
+ constructor_name => undef,
+ inline_accessors => 0,
+) for qw/
+ Class::MOP::HasMethods
+/;
+
1;
__END__
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::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.95';
$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::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::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::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::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
my @class_mop_package_attributes = (
'package',
'namespace',
- 'method_metaclass',
- 'wrapped_method_metaclass',
- '_methods',
);
my @class_mop_module_attributes = (
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::MOP::Class
Class::MOP::Module
Class::MOP::Package
+ Class::MOP::HasMethods
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