From: gfx Date: Thu, 13 Aug 2009 01:30:36 +0000 (+0900) Subject: Move method_map and related stuff to Module X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0a2deff5b4fc5676ece3e0a296e3f90b0bd0f64b;p=gitmo%2FClass-MOP.git Move method_map and related stuff to Module --- diff --git a/lib/Class/MOP/Module.pm b/lib/Class/MOP/Module.pm index 5522cc6..dcb998f 100644 --- a/lib/Class/MOP/Module.pm +++ b/lib/Class/MOP/Module.pm @@ -6,6 +6,7 @@ use warnings; use Carp 'confess'; use Scalar::Util 'blessed'; +use Sub::Name 'subname'; our $VERSION = '0.91'; $VERSION = eval $VERSION; @@ -31,6 +32,13 @@ sub _new { } => $class; } + +sub method_metaclass { $_[0]->{'method_metaclass'} } +sub wrapped_method_metaclass { $_[0]->{'wrapped_method_metaclass'} } + +sub _method_map { $_[0]->{'methods'} } + + sub version { my $self = shift; ${$self->get_package_symbol({ sigil => '$', type => 'SCALAR', name => 'VERSION' })}; @@ -69,6 +77,130 @@ sub _instantiate_module { return; } +## 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 && $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); + $self->_method_map->{$method_name} = $method; + } + 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; + } + + + my ( $current_package, $current_name ) = Class::MOP::get_code_info($body); + + if ( !defined $current_name || $current_name eq '__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 && $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 && $method_name) + || confess "You must define a method name"; + + my $method_map = $self->_method_map; + my $method_object = $method_map->{$method_name}; + my $code = $self->get_package_symbol({ + name => $method_name, + sigil => '&', + type => 'CODE', + }); + + unless ( $method_object && $method_object->body == ( $code || 0 ) ) { + if ( $code && $self->_code_is_mine($code) ) { + $method_object = $method_map->{$method_name} + = $self->wrap_method_body( + body => $code, + name => $method_name, + associated_metaclass => $self, + ); + } + else { + delete $method_map->{$method_name}; + return undef; + } + } + + return $method_object; +} + +sub remove_method { + my ($self, $method_name) = @_; + (defined $method_name && $method_name) + || confess "You must define a method name"; + + my $removed_method = delete $self->get_method_map->{$method_name}; + + $self->remove_package_symbol( + { sigil => '&', type => 'CODE', name => $method_name } + ); + + $removed_method->detach_from_class if $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__ diff --git a/lib/Class/MOP/Package.pm b/lib/Class/MOP/Package.pm index 5da609f..e8202db 100644 --- a/lib/Class/MOP/Package.pm +++ b/lib/Class/MOP/Package.pm @@ -6,7 +6,6 @@ use warnings; use Scalar::Util 'blessed', 'reftype'; use Carp 'confess'; -use Sub::Name 'subname'; our $VERSION = '0.91'; $VERSION = eval $VERSION; @@ -99,11 +98,6 @@ sub namespace { \%{$_[0]->{'package'} . '::'} } -sub method_metaclass { $_[0]->{'method_metaclass'} } -sub wrapped_method_metaclass { $_[0]->{'wrapped_method_metaclass'} } - -sub _method_map { $_[0]->{'methods'} } - # utility methods { @@ -288,128 +282,6 @@ sub list_all_package_symbols { } } -## 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 && $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); - $self->_method_map->{$method_name} = $method; - } - 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; - } - - - my ( $current_package, $current_name ) = Class::MOP::get_code_info($body); - - if ( !defined $current_name || $current_name eq '__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 && $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 && $method_name) - || confess "You must define a method name"; - - my $method_map = $self->_method_map; - my $method_object = $method_map->{$method_name}; - my $code = $self->get_package_symbol({ - name => $method_name, - sigil => '&', - type => 'CODE', - }); - - unless ( $method_object && $method_object->body == ( $code || 0 ) ) { - if ( $code && $self->_code_is_mine($code) ) { - $method_object = $method_map->{$method_name} - = $self->wrap_method_body( - body => $code, - name => $method_name, - associated_metaclass => $self, - ); - } - else { - delete $method_map->{$method_name}; - return undef; - } - } - - return $method_object; -} - -sub remove_method { - my ($self, $method_name) = @_; - (defined $method_name && $method_name) - || confess "You must define a method name"; - - my $removed_method = delete $self->get_method_map->{$method_name}; - - $self->remove_package_symbol( - { sigil => '&', type => 'CODE', name => $method_name } - ); - - $removed_method->detach_from_class if $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; diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t index bcc6335..e810852 100644 --- a/t/010_self_introspection.t +++ b/t/010_self_introspection.t @@ -34,13 +34,6 @@ my @class_mop_package_methods = qw( 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 get_method_map - _deconstruct_variable_name ); @@ -50,6 +43,13 @@ my @class_mop_module_methods = qw( _instantiate_module version authority identifier create + + method_metaclass wrapped_method_metaclass + + _method_map + _code_is_mine + has_method get_method add_method remove_method wrap_method_body + get_method_list get_method_map ); my @class_mop_class_methods = qw( diff --git a/xs/MOP.xs b/xs/MOP.xs index 85c7659..bc313b9 100644 --- a/xs/MOP.xs +++ b/xs/MOP.xs @@ -16,6 +16,7 @@ find_method (const char *key, STRLEN keylen, SV *val, void *ud) } EXTERN_C XS(boot_Class__MOP__Package); +EXTERN_C XS(boot_Class__MOP__Module); EXTERN_C XS(boot_Class__MOP__Attribute); EXTERN_C XS(boot_Class__MOP__Method); @@ -31,6 +32,7 @@ BOOT: mop_associated_metaclass = newSVpvs("associated_metaclass"); MOP_CALL_BOOT (boot_Class__MOP__Package); + MOP_CALL_BOOT (boot_Class__MOP__Module); MOP_CALL_BOOT (boot_Class__MOP__Attribute); MOP_CALL_BOOT (boot_Class__MOP__Method); diff --git a/xs/Module.xs b/xs/Module.xs new file mode 100755 index 0000000..6908087 --- /dev/null +++ b/xs/Module.xs @@ -0,0 +1,147 @@ +#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 *const body = mop_call0(aTHX_ method_slot, KEY_FOR(body)); /* $method_object->body() */ + 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::Module PACKAGE = Class::MOP::Module + +PROTOTYPES: DISABLE + +void +get_all_package_symbols(self, filter=TYPE_FILTER_NONE) + SV *self + type_filter_t filter + PREINIT: + HV *stash = NULL; + HV *symbols = NULL; + register HE *he; + PPCODE: + if ( ! SvROK(self) ) { + die("Cannot call get_all_package_symbols as a class method"); + } + + if (GIMME_V == G_VOID) { + XSRETURN_EMPTY; + } + + PUTBACK; + + if ( (he = hv_fetch_ent((HV *)SvRV(self), KEY_FOR(package), 0, HASH_FOR(package))) ) { + stash = gv_stashsv(HeVAL(he), 0); + } + + + if (!stash) { + XSRETURN_UNDEF; + } + + symbols = mop_get_all_package_symbols(stash, filter); + PUSHs(sv_2mortal(newRV_noinc((SV *)symbols))); + +void +get_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); diff --git a/xs/Package.xs b/xs/Package.xs index 362c407..6c47099 100644 --- a/xs/Package.xs +++ b/xs/Package.xs @@ -1,150 +1,8 @@ #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 *const body = mop_call0(aTHX_ method_slot, KEY_FOR(body)); /* $method_object->body() */ - 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 -void -get_all_package_symbols(self, filter=TYPE_FILTER_NONE) - SV *self - type_filter_t filter - PREINIT: - HV *stash = NULL; - HV *symbols = NULL; - register HE *he; - PPCODE: - if ( ! SvROK(self) ) { - die("Cannot call get_all_package_symbols as a class method"); - } - - if (GIMME_V == G_VOID) { - XSRETURN_EMPTY; - } - - PUTBACK; - - if ( (he = hv_fetch_ent((HV *)SvRV(self), KEY_FOR(package), 0, HASH_FOR(package))) ) { - stash = gv_stashsv(HeVAL(he), 0); - } - - - if (!stash) { - XSRETURN_UNDEF; - } - - symbols = mop_get_all_package_symbols(stash, filter); - PUSHs(sv_2mortal(newRV_noinc((SV *)symbols))); - -void -get_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);