X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=MOP.xs;h=09e90cd2589984f7539243fe183894e23146d9d3;hb=7f8de9b4f7ee31388ffb3c32f8d3387ec8e0f599;hp=47d02d42172564f9414c37c40396090c8fff14d9;hpb=49f7873e0bf43676a5f8d7c97154e63111a4f2a2;p=gitmo%2FClass-MOP.git diff --git a/MOP.xs b/MOP.xs index 47d02d4..09e90cd 100644 --- a/MOP.xs +++ b/MOP.xs @@ -1,14 +1,174 @@ +/* There's a lot of cases of doubled parens in here like this: + + while ( (he = ...) ) { + +This shuts up warnings from gcc -Wall +*/ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" + +#define NEED_sv_2pv_flags +#define NEED_sv_2pv_nolen #include "ppport.h" -/* -check_method_cache_flag: - check the PL_sub_generation - ISA/method cache thing +SV *key_name; +U32 hash_name; + +SV *key_package; +U32 hash_package; + +SV *key_package_name; +U32 hash_package_name; + +SV *key_body; +U32 hash_body; + +SV* method_metaclass; +SV* associated_metaclass; +SV* wrap; + + +#define check_package_cache_flag(stash) mop_check_package_cache_flag(aTHX_ stash) +#ifdef HvMROMETA /* 5.10.0 */ + +#ifndef mro_meta_init +#define mro_meta_init(stash) Perl_mro_meta_init(aTHX_ stash) /* used in HvMROMETA macro */ +#endif /* !mro_meta_init */ + +static UV +mop_check_package_cache_flag(pTHX_ HV* stash) { + assert(SvTYPE(stash) == SVt_PVHV); + + return HvMROMETA(stash)->pkg_gen; /* mro::get_pkg_gen($pkg) */ +} + +#else /* pre 5.10.0 */ + +static UV +mop_check_package_cache_flag(pTHX_ HV* stash) { + PERL_UNUSED_ARG(stash); + assert(SvTYPE(stash) == SVt_PVHV); + + return PL_sub_generation; +} +#endif + +#define call0(s, m) mop_call0(aTHX_ s, m) +static SV* +mop_call0(pTHX_ SV* const self, SV* const method) { + dSP; + SV* ret; + + PUSHMARK(SP); + XPUSHs(self); + PUTBACK; + + call_sv(method, G_SCALAR | G_METHOD); + + SPAGAIN; + ret = POPs; + PUTBACK; + return ret; +} + +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; + GV* gv; + dSP; + + /* this function massivly overlaps with the xs version of + * get_all_package_symbols. a common c function to walk the symbol table + * should be factored out and used by both. --rafl */ + + hv_iterinit(stash); + while ( (gv = (GV*)hv_iternextsv(stash, &method_name, &method_name_len)) ) { + CV* cv; + switch (SvTYPE (gv)) { +#ifndef SVt_RV + case SVt_RV: +#endif + case SVt_IV: + case SVt_PV: + /* rafl says that this wastes memory savings that GvSVs have + in 5.8.9 and 5.10.x. But without it some tests fail. rafl + says the right thing to do is to handle GvSVs differently + here. */ + gv_init((GV*)gv, stash, method_name, method_name_len, GV_ADDMULTI); + /* fall through */ + default: + break; + } + + if ( SvTYPE(gv) == SVt_PVGV && (cv = GvCVu(gv)) ) { + GV* const cvgv = CvGV(cv); + /* ($cvpkg_name, $cv_name) = get_code_info($cv) */ + const char* const cvpkg_name = HvNAME(GvSTASH(cvgv)); + const char* const cv_name = GvNAME(cvgv); + SV* method_slot; + SV* method_object; + + /* 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 = call0(method_slot, key_body); /* $method_object->body() */ + if ( SvROK(body) && ((CV*) SvRV(body)) == cv ) { + continue; + } + } + + method_metaclass_name = call0(self, 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(associated_metaclass); + PUSHs(self); + PUSHs(key_package_name); + PUSHs(class_name); + PUSHs(key_name); + mPUSHs(newSVpv(method_name, method_name_len)); + PUTBACK; + + call_sv(wrap, G_SCALAR | G_METHOD); + SPAGAIN; + method_object = POPs; + PUTBACK; + /* $map->{$method_name} = $method_object */ + sv_setsv(method_slot, method_object); + + FREETMPS; + LEAVE; + } + } +} + + +/* get_code_info: Pass in a coderef, returns: [ $pkg_name, $coderef_name ] ie: @@ -17,13 +177,24 @@ get_code_info: MODULE = Class::MOP PACKAGE = Class::MOP -SV* -check_package_cache_flag(pkg) - SV* pkg - CODE: - RETVAL = newSViv(PL_sub_generation); - OUTPUT: - RETVAL +BOOT: + key_name = newSVpvs("name"); + key_body = newSVpvs("body"); + key_package = newSVpvs("package"); + key_package_name = newSVpvs("package_name"); + + PERL_HASH(hash_name, "name", 4); + PERL_HASH(hash_body, "body", 4); + PERL_HASH(hash_package, "package", 7); + PERL_HASH(hash_package_name, "package_name", 12); + + method_metaclass = newSVpvs("method_metaclass"); + wrap = newSVpvs("wrap"); + associated_metaclass = newSVpvs("associated_metaclass"); + + +PROTOTYPES: ENABLE + void get_code_info(coderef) @@ -32,13 +203,248 @@ get_code_info(coderef) char* name; char* pkg; PPCODE: - if( SvOK(coderef) && SvROK(coderef) && SvTYPE(SvRV(coderef)) == SVt_PVCV){ + if ( SvOK(coderef) && SvROK(coderef) && SvTYPE(SvRV(coderef)) == SVt_PVCV ) { coderef = SvRV(coderef); - name = GvNAME( CvGV(coderef) ); - pkg = HvNAME( GvSTASH(CvGV(coderef)) ); + /* I think this only gets triggered with a mangled coderef, but if + we hit it without the guard, we segfault. The slightly odd return + value strikes me as an improvement (mst) + */ +#ifdef isGV_with_GP + if ( isGV_with_GP(CvGV(coderef)) ) { +#endif + pkg = HvNAME( GvSTASH(CvGV(coderef)) ); + name = GvNAME( CvGV(coderef) ); +#ifdef isGV_with_GP + } else { + pkg = "__UNKNOWN__"; + name = "__ANON__"; + } +#endif EXTEND(SP, 2); PUSHs(newSVpvn(pkg, strlen(pkg))); PUSHs(newSVpvn(name, strlen(name))); } + +MODULE = Class::MOP PACKAGE = Class::MOP::Package + +void +get_all_package_symbols(self, ...) + SV *self + PROTOTYPE: $;$ + PREINIT: + HV *stash = NULL; + SV *type_filter = NULL; + register HE *he; + PPCODE: + if ( ! SvROK(self) ) { + die("Cannot call get_all_package_symbols as a class method"); + } + + switch (GIMME_V) { + case G_VOID: return; break; + case G_SCALAR: ST(0) = &PL_sv_undef; return; break; + } + + if ( items > 1 ) type_filter = ST(1); + + PUTBACK; + + if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package, 0, hash_package)) ) + stash = gv_stashsv(HeVAL(he),0); + + if (stash) { + + (void)hv_iterinit(stash); + + if ( type_filter && SvPOK(type_filter) ) { + const char *const type = SvPV_nolen(type_filter); + + while ( (he = hv_iternext(stash)) ) { + SV *const gv = HeVAL(he); + SV *sv = NULL; + char *key; + STRLEN keylen; + char *package; + SV *fq; + + switch( SvTYPE(gv) ) { +#ifndef SVt_RV + case SVt_RV: +#endif + case SVt_PV: + case SVt_IV: + /* expand the gv into a real typeglob if it + * contains stub functions and we were asked to + * return CODE symbols */ + if (*type == 'C') { + if (SvROK(gv)) { + /* we don't really care about the length, + but that's the API */ + key = HePV(he, keylen); + package = HvNAME(stash); + fq = newSVpvf("%s::%s", package, key); + sv = (SV*)get_cv(SvPV_nolen(fq), 0); + break; + } + + key = HePV(he, keylen); + gv_init((GV *)gv, stash, key, keylen, GV_ADDMULTI); + } + /* fall through */ + case SVt_PVGV: + switch (*type) { + case 'C': sv = (SV *)GvCVu(gv); break; /* CODE */ + case 'A': sv = (SV *)GvAV(gv); break; /* ARRAY */ + case 'I': sv = (SV *)GvIO(gv); break; /* IO */ + case 'H': sv = (SV *)GvHV(gv); break; /* HASH */ + case 'S': sv = (SV *)GvSV(gv); break; /* SCALAR */ + default: + croak("Unknown type %s\n", type); + } + break; + default: + continue; + } + + if (sv) { + SV *key = hv_iterkeysv(he); + SPAGAIN; + EXTEND(SP, 2); + PUSHs(key); + PUSHs(sv_2mortal(newRV_inc(sv))); + PUTBACK; + } + } + } else { + EXTEND(SP, HvKEYS(stash) * 2); + + while ( (he = hv_iternext(stash)) ) { + SV *key = hv_iterkeysv(he); + SV *sv = HeVAL(he); + SPAGAIN; + PUSHs(key); + PUSHs(sv); + PUTBACK; + } + } + + } + +void +name(self) + SV *self + PREINIT: + register HE *he; + PPCODE: + if ( ! SvROK(self) ) { + die("Cannot call name as a class method"); + } + + if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package, 0, hash_package)) ) + XPUSHs(HeVAL(he)); + else + ST(0) = &PL_sv_undef; + +MODULE = Class::MOP PACKAGE = Class::MOP::Attribute + +void +name(self) + SV *self + PREINIT: + register HE *he; + PPCODE: + if ( ! SvROK(self) ) { + die("Cannot call name as a class method"); + } + + if ( (he = hv_fetch_ent((HV *)SvRV(self), key_name, 0, hash_name)) ) + XPUSHs(HeVAL(he)); + else + ST(0) = &PL_sv_undef; + +MODULE = Class::MOP PACKAGE = Class::MOP::Method + +void +name(self) + SV *self + PREINIT: + register HE *he; + PPCODE: + if ( ! SvROK(self) ) { + die("Cannot call name as a class method"); + } + + if ( (he = hv_fetch_ent((HV *)SvRV(self), key_name, 0, hash_name)) ) + XPUSHs(HeVAL(he)); + else + ST(0) = &PL_sv_undef; + +void +package_name(self) + SV *self + PREINIT: + register HE *he; + PPCODE: + if ( ! SvROK(self) ) { + die("Cannot call package_name as a class method"); + } + + if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package_name, 0, hash_package_name)) ) + XPUSHs(HeVAL(he)); + else + ST(0) = &PL_sv_undef; + +void +body(self) + SV *self + PREINIT: + register HE *he; + PPCODE: + if ( ! SvROK(self) ) { + die("Cannot call body as a class method"); + } + + if ( (he = hv_fetch_ent((HV *)SvRV(self), key_body, 0, hash_body)) ) + XPUSHs(HeVAL(he)); + else + ST(0) = &PL_sv_undef; + + +MODULE = Class::MOP PACKAGE = Class::MOP::Class + +void +get_method_map(self) + SV* self + PREINIT: + SV* const class_name = HeVAL( hv_fetch_ent((HV*)SvRV(self), key_package, TRUE, hash_package) ); + HV* const stash = gv_stashsv(class_name, TRUE); + UV const current = check_package_cache_flag(stash); + SV* const cache_flag = *hv_fetchs((HV*)SvRV(self), "_package_cache_flag", TRUE); + SV* const map_ref = *hv_fetchs((HV*)SvRV(self), "methods", TRUE); + PPCODE: + if ( ! SvRV(self) ) { + die("Cannot call get_method_map as a class method"); + } + + /* in $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) ) { + ENTER; + SAVETMPS; + + mop_update_method_map(aTHX_ self, class_name, stash, (HV*)SvRV(map_ref)); + sv_setuv(cache_flag, check_package_cache_flag(stash)); /* update_cache_flag() */ + + FREETMPS; + LEAVE; + } + + XPUSHs(map_ref); +