From: Florian Ragwitz Date: Mon, 9 Mar 2009 23:36:47 +0000 (+0100) Subject: Split MOP.xs into more managable parts under xs/ X-Git-Tag: 0.78_01~72^2~2 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d846ade3f993c0e6c140bb28284022e602b8988e;p=gitmo%2FClass-MOP.git Split MOP.xs into more managable parts under xs/ --- diff --git a/MOP.xs b/MOP.xs deleted file mode 100644 index 7d82305..0000000 --- a/MOP.xs +++ /dev/null @@ -1,560 +0,0 @@ -/* 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_newRV_noinc -#define NEED_sv_2pv_flags -#define NEED_sv_2pv_nolen -#include "ppport.h" - -#define DECLARE_KEY(name) SV *key_##name; U32 hash_##name; - -#define PREHASH_KEY_WITH_VALUE(name, value) do { \ - key_##name = newSVpvs(value); \ - PERL_HASH(hash_##name, value, sizeof(value) - 1); \ -} while (0) - -/* this is basically the same as the above macro, except that the value will be - * the stringified name. However, we can't just implement this in terms of - * PREHASH_KEY_WITH_VALUE as that'd cause macro expansion on the value of - * 'name' when it's being passed to the other macro. suggestions on how to make - * this more elegant would be much appreciated */ - -#define PREHASH_KEY(name) do { \ - key_##name = newSVpvs(#name); \ - PERL_HASH(hash_##name, #name, sizeof(#name) - 1); \ -} while (0) - -DECLARE_KEY(name); -DECLARE_KEY(package); -DECLARE_KEY(package_name); -DECLARE_KEY(body); -DECLARE_KEY(package_cache_flag); -DECLARE_KEY(methods); -DECLARE_KEY(VERSION); -DECLARE_KEY(ISA); - -SV *method_metaclass; -SV *associated_metaclass; -SV *wrap; - - -#define check_package_cache_flag(stash) mop_check_package_cache_flag(aTHX_ stash) -#if PERL_VERSION >= 10 - -static UV -mop_check_package_cache_flag(pTHX_ HV* stash) { - assert(SvTYPE(stash) == SVt_PVHV); - - /* here we're trying to implement a c version of mro::get_pkg_gen($stash), - * however the perl core doesn't make it easy for us. It doesn't provide an - * api that just does what we want. - * - * However, we know that the information we want is, inside the core, - * available using HvMROMETA(stash)->pkg_gen. Unfortunately, although the - * HvMROMETA macro is public, it is implemented using Perl_mro_meta_init, - * which is not public and only available inside the core, as the mro - * interface as well as the structure returned by mro_meta_init isn't - * considered to be stable yet. - * - * Perl_mro_meta_init isn't declared static, so we could just define it - * ourselfs if perls headers don't do that for us, except that won't work - * on platforms where symbols need to be explicitly exported when linking - * shared libraries. - * - * So our, hopefully temporary, solution is to be even more evil and - * basically reimplement HvMROMETA in a very fragile way that'll blow up - * when the relevant parts of the mro implementation in core change. - * - * :-( - * - */ - - return HvAUX(stash)->xhv_mro_meta - ? HvAUX(stash)->xhv_mro_meta->pkg_gen - : 0; -} - -#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 int -get_code_info (SV *coderef, char **pkg, char **name) -{ - if (!SvOK(coderef) || !SvROK(coderef) || SvTYPE(SvRV(coderef)) != SVt_PVCV) { - return 0; - } - - coderef = SvRV(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 - - return 1; -} - -typedef enum { - TYPE_FILTER_NONE, - TYPE_FILTER_CODE, - TYPE_FILTER_ARRAY, - TYPE_FILTER_IO, - TYPE_FILTER_HASH, - TYPE_FILTER_SCALAR, -} type_filter_t; - -typedef bool (*get_package_symbols_cb_t) (const char *, STRLEN, SV *, void *); - -static void -get_package_symbols(HV *stash, type_filter_t filter, get_package_symbols_cb_t cb, void *ud) -{ - HE *he; - - (void)hv_iterinit(stash); - - if (filter == TYPE_FILTER_NONE) { - while ( (he = hv_iternext(stash)) ) { - STRLEN keylen; - const char *key = HePV(he, keylen); - if (!cb(key, keylen, HeVAL(he), ud)) { - return; - } - } - return; - } - - 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 (filter == TYPE_FILTER_CODE) { - 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 (filter) { - case TYPE_FILTER_CODE: sv = (SV *)GvCVu(gv); break; - case TYPE_FILTER_ARRAY: sv = (SV *)GvAV(gv); break; - case TYPE_FILTER_IO: sv = (SV *)GvIO(gv); break; - case TYPE_FILTER_HASH: sv = (SV *)GvHV(gv); break; - case TYPE_FILTER_SCALAR: sv = (SV *)GvSV(gv); break; - default: - croak("Unknown type"); - } - break; - default: - continue; - } - - if (sv) { - const char *key = HePV(he, keylen); - if (!cb(key, keylen, sv, ud)) { - return; - } - } - } -} - -static bool -find_method (const char *key, STRLEN keylen, SV *val, void *ud) -{ - bool *found_method = (bool *)ud; - *found_method = TRUE; - return FALSE; -} - -static bool -collect_all_symbols (const char *key, STRLEN keylen, SV *val, void *ud) -{ - HV *hash = (HV *)ud; - - if (!hv_store (hash, key, keylen, newRV_inc(val), 0)) { - croak("failed to store symbol ref"); - } - - return TRUE; -} - -static HV * -get_all_package_symbols (HV *stash, type_filter_t filter) -{ - HV *ret = newHV (); - get_package_symbols (stash, filter, collect_all_symbols, ret); - 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; - SV *coderef; - HV *symbols; - dSP; - - symbols = get_all_package_symbols(stash, TYPE_FILTER_CODE); - - (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 (!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 = 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: - [ 'Foo::Bar', 'new' ] -*/ - -MODULE = Class::MOP PACKAGE = Class::MOP - -BOOT: - PREHASH_KEY(name); - PREHASH_KEY(body); - PREHASH_KEY(package); - PREHASH_KEY(package_name); - PREHASH_KEY(methods); - PREHASH_KEY(ISA); - PREHASH_KEY(VERSION); - PREHASH_KEY_WITH_VALUE(package_cache_flag, "_package_cache_flag"); - - method_metaclass = newSVpvs("method_metaclass"); - wrap = newSVpvs("wrap"); - associated_metaclass = newSVpvs("associated_metaclass"); - - -PROTOTYPES: DISABLE - -# use prototype here to be compatible with get_code_info from Sub::Identify -void -get_code_info(coderef) - SV *coderef - PROTOTYPE: $ - PREINIT: - char *pkg = NULL; - char *name = NULL; - PPCODE: - if (get_code_info(coderef, &pkg, &name)) { - EXTEND(SP, 2); - PUSHs(newSVpv(pkg, 0)); - PUSHs(newSVpv(name, 0)); - } - -# This is some pretty grotty logic. It _should_ be parallel to the -# pure Perl version in lib/Class/MOP.pm, so if you want to understand -# it we suggest you start there. -void -is_class_loaded(klass=&PL_sv_undef) - SV *klass - PREINIT: - HV *stash; - bool found_method = FALSE; - PPCODE: - if (!SvPOK(klass) || !SvCUR(klass)) { - XSRETURN_NO; - } - - stash = gv_stashsv(klass, 0); - if (!stash) { - XSRETURN_NO; - } - - if (hv_exists_ent (stash, key_VERSION, hash_VERSION)) { - HE *version = hv_fetch_ent(stash, key_VERSION, 0, hash_VERSION); - SV *version_sv; - if (version && HeVAL(version) && (version_sv = GvSV(HeVAL(version)))) { - if (SvROK(version_sv)) { - SV *version_sv_ref = SvRV(version_sv); - - if (SvOK(version_sv_ref)) { - XSRETURN_YES; - } - } - else if (SvOK(version_sv)) { - XSRETURN_YES; - } - } - } - - if (hv_exists_ent (stash, key_ISA, hash_ISA)) { - HE *isa = hv_fetch_ent(stash, key_ISA, 0, hash_ISA); - if (isa && HeVAL(isa) && GvAV(HeVAL(isa))) { - XSRETURN_YES; - } - } - - get_package_symbols(stash, TYPE_FILTER_CODE, find_method, &found_method); - if (found_method) { - XSRETURN_YES; - } - - XSRETURN_NO; - -MODULE = Class::MOP PACKAGE = Class::MOP::Package - -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_package, 0, hash_package)) ) { - stash = gv_stashsv(HeVAL(he), 0); - } - - - if (!stash) { - XSRETURN_UNDEF; - } - - symbols = get_all_package_symbols(stash, filter); - PUSHs(sv_2mortal(newRV_noinc((SV *)symbols))); - -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: - HV *const obj = (HV *)SvRV(self); - SV *const class_name = HeVAL( hv_fetch_ent(obj, key_package, 0, hash_package) ); - HV *const stash = gv_stashsv(class_name, 0); - UV const current = check_package_cache_flag(stash); - SV *const cache_flag = HeVAL( hv_fetch_ent(obj, key_package_cache_flag, TRUE, hash_package_cache_flag)); - SV *const map_ref = HeVAL( hv_fetch_ent(obj, key_methods, TRUE, hash_methods)); - PPCODE: - /* 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 ) { - 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() */ - } - - XPUSHs(map_ref); diff --git a/Makefile.PL b/Makefile.PL index 47397e9..417fa13 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -10,7 +10,8 @@ perl_version '5.008001'; all_from 'lib/Class/MOP.pm'; license 'perl'; -my $ccflags = -d '.svn' || -d '.git' || $ENV{MAINTAINER_MODE} ? '-Wall' : ''; +my $ccflags = ' -I.'; +$ccflags .= ' -Wall' if -d '.svn' || -d '.git' || $ENV{MAINTAINER_MODE}; requires 'Carp'; requires 'Devel::GlobalDestruction'; @@ -25,6 +26,31 @@ test_requires 'Test::Exception' => '0.21'; makemaker_args( CCFLAGS => $ccflags ); +{ + my (@clean, @OBJECT, %XS); + + for my $xs () { + (my $c = $xs) =~ s/\.xs$/.c/i; + (my $o = $xs) =~ s/\.xs$/\$(OBJ_EXT)/i; + + $XS{$xs} = $c; + push @OBJECT, $o; + push @clean, $o; + } + + for my $c (<*.c>) { + (my $o = $c) =~ s/\.c$/\$(OBJ_EXT)/i; + push @OBJECT, $o; + push @clean, $o; + } + + makemaker_args( + clean => { FILES => join(q{ }, @clean) }, + OBJECT => join (q{ }, @OBJECT), + XS => \%XS, + ); +} + WriteAll(); # Use the cpan-smolder-stable script in the Moose svn root to figure @@ -67,3 +93,22 @@ EOF sleep 4; } + +package MY; + +use Config; + +sub const_cccmd { + my $ret = shift->SUPER::const_cccmd(@_); + return q{} unless $ret; + + if ($Config{cc} =~ /^cl\b/i) { + warn 'you are using MSVC... my condolences.'; + $ret .= ' /Fo$@'; + } + else { + $ret .= ' -o $@'; + } + + return $ret; +} diff --git a/mop.c b/mop.c new file mode 100644 index 0000000..11a856b --- /dev/null +++ b/mop.c @@ -0,0 +1,197 @@ +#include "mop.h" + +void +mop_call_xs (pTHX_ void (*subaddr) (pTHX_ CV *), CV *cv, SV **mark) +{ + dSP; + PUSHMARK(mark); + (*subaddr)(aTHX_ cv); + PUTBACK; +} + +#if PERL_VERSION >= 10 +UV +mop_check_package_cache_flag (pTHX_ HV *stash) +{ + assert(SvTYPE(stash) == SVt_PVHV); + + /* here we're trying to implement a c version of mro::get_pkg_gen($stash), + * however the perl core doesn't make it easy for us. It doesn't provide an + * api that just does what we want. + * + * However, we know that the information we want is, inside the core, + * available using HvMROMETA(stash)->pkg_gen. Unfortunately, although the + * HvMROMETA macro is public, it is implemented using Perl_mro_meta_init, + * which is not public and only available inside the core, as the mro + * interface as well as the structure returned by mro_meta_init isn't + * considered to be stable yet. + * + * Perl_mro_meta_init isn't declared static, so we could just define it + * ourselfs if perls headers don't do that for us, except that won't work + * on platforms where symbols need to be explicitly exported when linking + * shared libraries. + * + * So our, hopefully temporary, solution is to be even more evil and + * basically reimplement HvMROMETA in a very fragile way that'll blow up + * when the relevant parts of the mro implementation in core change. + * + * :-( + * + */ + + return HvAUX(stash)->xhv_mro_meta + ? HvAUX(stash)->xhv_mro_meta->pkg_gen + : 0; +} + +#else /* pre 5.10.0 */ + +UV +mop_check_package_cache_flag (pTHX_ HV *stash) +{ + PERL_UNUSED_ARG(stash); + assert(SvTYPE(stash) == SVt_PVHV); + + return PL_sub_generation; +} +#endif + +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; +} + +int +get_code_info (SV *coderef, char **pkg, char **name) +{ + if (!SvOK(coderef) || !SvROK(coderef) || SvTYPE(SvRV(coderef)) != SVt_PVCV) { + return 0; + } + + coderef = SvRV(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 + + return 1; +} + +void +get_package_symbols (HV *stash, type_filter_t filter, get_package_symbols_cb_t cb, void *ud) +{ + HE *he; + + (void)hv_iterinit(stash); + + if (filter == TYPE_FILTER_NONE) { + while ( (he = hv_iternext(stash)) ) { + STRLEN keylen; + const char *key = HePV(he, keylen); + if (!cb(key, keylen, HeVAL(he), ud)) { + return; + } + } + return; + } + + 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 (filter == TYPE_FILTER_CODE) { + 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 (filter) { + case TYPE_FILTER_CODE: sv = (SV *)GvCVu(gv); break; + case TYPE_FILTER_ARRAY: sv = (SV *)GvAV(gv); break; + case TYPE_FILTER_IO: sv = (SV *)GvIO(gv); break; + case TYPE_FILTER_HASH: sv = (SV *)GvHV(gv); break; + case TYPE_FILTER_SCALAR: sv = (SV *)GvSV(gv); break; + default: + croak("Unknown type"); + } + break; + default: + continue; + } + + if (sv) { + const char *key = HePV(he, keylen); + if (!cb(key, keylen, sv, ud)) { + return; + } + } + } +} + +static bool +collect_all_symbols (const char *key, STRLEN keylen, SV *val, void *ud) +{ + HV *hash = (HV *)ud; + + if (!hv_store (hash, key, keylen, newRV_inc(val), 0)) { + croak("failed to store symbol ref"); + } + + return TRUE; +} + +HV * +get_all_package_symbols (HV *stash, type_filter_t filter) +{ + HV *ret = newHV (); + get_package_symbols (stash, filter, collect_all_symbols, ret); + return ret; +} diff --git a/mop.h b/mop.h new file mode 100644 index 0000000..35a7292 --- /dev/null +++ b/mop.h @@ -0,0 +1,62 @@ +#ifndef __MOP_H__ +#define __MOP_H__ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#define NEED_newRV_noinc +#define NEED_sv_2pv_flags +#define NEED_sv_2pv_nolen +#include "ppport.h" + +#define MOP_CALL_BOOT(name) \ + { \ + EXTERN_C XS(name); \ + mop_call_xs(aTHX_ name, cv, mark); \ + } + +void mop_call_xs (pTHX_ void (*subaddr) (pTHX_ CV *), CV *cv, SV **mark); + +#define DECLARE_KEY(name) SV *key_##name; U32 hash_##name; +#define NEEDS_KEY(name) extern SV *key_##name; extern U32 hash_##name; + +#define PREHASH_KEY_WITH_VALUE(name, value) do { \ + key_##name = newSVpvs(value); \ + PERL_HASH(hash_##name, value, sizeof(value) - 1); \ +} while (0) + +/* this is basically the same as the above macro, except that the value will be + * the stringified name. However, we can't just implement this in terms of + * PREHASH_KEY_WITH_VALUE as that'd cause macro expansion on the value of + * 'name' when it's being passed to the other macro. suggestions on how to make + * this more elegant would be much appreciated */ + +#define PREHASH_KEY(name) do { \ + key_##name = newSVpvs(#name); \ + PERL_HASH(hash_##name, #name, sizeof(#name) - 1); \ +} while (0) + +extern SV *method_metaclass; +extern SV *associated_metaclass; +extern SV *wrap; + +UV mop_check_package_cache_flag(pTHX_ HV *stash); +int get_code_info (SV *coderef, char **pkg, char **name); +SV *mop_call0(pTHX_ SV *const self, SV *const method); + +typedef enum { + TYPE_FILTER_NONE, + TYPE_FILTER_CODE, + TYPE_FILTER_ARRAY, + TYPE_FILTER_IO, + TYPE_FILTER_HASH, + TYPE_FILTER_SCALAR, +} type_filter_t; + +typedef bool (*get_package_symbols_cb_t) (const char *, STRLEN, SV *, void *); + +void get_package_symbols(HV *stash, type_filter_t filter, get_package_symbols_cb_t cb, void *ud); +HV *get_all_package_symbols (HV *stash, type_filter_t filter); + +#endif diff --git a/xs/Attribute.xs b/xs/Attribute.xs new file mode 100644 index 0000000..807e7e5 --- /dev/null +++ b/xs/Attribute.xs @@ -0,0 +1,22 @@ +#include "mop.h" + +NEEDS_KEY(name); + +MODULE = Class::MOP::Attribute PACKAGE = Class::MOP::Attribute + +PROTOTYPES: DISABLE + +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; diff --git a/xs/Class.xs b/xs/Class.xs new file mode 100644 index 0000000..911e97d --- /dev/null +++ b/xs/Class.xs @@ -0,0 +1,114 @@ +#include "mop.h" + +NEEDS_KEY(name); +NEEDS_KEY(body); +NEEDS_KEY(methods); +NEEDS_KEY(package); +NEEDS_KEY(package_name); +NEEDS_KEY(package_cache_flag); + +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 = get_all_package_symbols(stash, TYPE_FILTER_CODE); + + (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 (!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_body); /* $method_object->body() */ + if ( SvROK(body) && ((CV *) SvRV(body)) == cv ) { + continue; + } + } + + method_metaclass_name = mop_call0(aTHX_ 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; + } +} + +MODULE = Class::MOP::Class PACKAGE = Class::MOP::Class + +PROTOTYPES: DISABLE + +void +get_method_map(self) + SV *self + PREINIT: + HV *const obj = (HV *)SvRV(self); + SV *const class_name = HeVAL( hv_fetch_ent(obj, key_package, 0, hash_package) ); + HV *const stash = gv_stashsv(class_name, 0); + UV const current = mop_check_package_cache_flag(aTHX_ stash); + SV *const cache_flag = HeVAL( hv_fetch_ent(obj, key_package_cache_flag, TRUE, hash_package_cache_flag)); + SV *const map_ref = HeVAL( hv_fetch_ent(obj, key_methods, TRUE, hash_methods)); + PPCODE: + /* 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 ) { + 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/MOP.xs b/xs/MOP.xs new file mode 100644 index 0000000..545933e --- /dev/null +++ b/xs/MOP.xs @@ -0,0 +1,110 @@ +#include "mop.h" + +static bool +find_method (const char *key, STRLEN keylen, SV *val, void *ud) +{ + bool *found_method = (bool *)ud; + *found_method = TRUE; + return FALSE; +} + +DECLARE_KEY(name); +DECLARE_KEY(package); +DECLARE_KEY(package_name); +DECLARE_KEY(body); +DECLARE_KEY(package_cache_flag); +DECLARE_KEY(methods); +DECLARE_KEY(VERSION); +DECLARE_KEY(ISA); + +SV *method_metaclass; +SV *associated_metaclass; +SV *wrap; + +MODULE = Class::MOP PACKAGE = Class::MOP + +PROTOTYPES: DISABLE + +BOOT: + PREHASH_KEY(name); + PREHASH_KEY(body); + PREHASH_KEY(package); + PREHASH_KEY(package_name); + PREHASH_KEY(methods); + PREHASH_KEY(ISA); + PREHASH_KEY(VERSION); + PREHASH_KEY_WITH_VALUE(package_cache_flag, "_package_cache_flag"); + + method_metaclass = newSVpvs("method_metaclass"); + wrap = newSVpvs("wrap"); + associated_metaclass = newSVpvs("associated_metaclass"); + + MOP_CALL_BOOT (boot_Class__MOP__Package); + MOP_CALL_BOOT (boot_Class__MOP__Class); + MOP_CALL_BOOT (boot_Class__MOP__Attribute); + MOP_CALL_BOOT (boot_Class__MOP__Method); + +# use prototype here to be compatible with get_code_info from Sub::Identify +void +get_code_info(coderef) + SV *coderef + PROTOTYPE: $ + PREINIT: + char *pkg = NULL; + char *name = NULL; + PPCODE: + if (get_code_info(coderef, &pkg, &name)) { + EXTEND(SP, 2); + PUSHs(newSVpv(pkg, 0)); + PUSHs(newSVpv(name, 0)); + } + +# This is some pretty grotty logic. It _should_ be parallel to the +# pure Perl version in lib/Class/MOP.pm, so if you want to understand +# it we suggest you start there. +void +is_class_loaded(klass=&PL_sv_undef) + SV *klass + PREINIT: + HV *stash; + bool found_method = FALSE; + PPCODE: + if (!SvPOK(klass) || !SvCUR(klass)) { + XSRETURN_NO; + } + + stash = gv_stashsv(klass, 0); + if (!stash) { + XSRETURN_NO; + } + + if (hv_exists_ent (stash, key_VERSION, hash_VERSION)) { + HE *version = hv_fetch_ent(stash, key_VERSION, 0, hash_VERSION); + SV *version_sv; + if (version && HeVAL(version) && (version_sv = GvSV(HeVAL(version)))) { + if (SvROK(version_sv)) { + SV *version_sv_ref = SvRV(version_sv); + + if (SvOK(version_sv_ref)) { + XSRETURN_YES; + } + } + else if (SvOK(version_sv)) { + XSRETURN_YES; + } + } + } + + if (hv_exists_ent (stash, key_ISA, hash_ISA)) { + HE *isa = hv_fetch_ent(stash, key_ISA, 0, hash_ISA); + if (isa && HeVAL(isa) && GvAV(HeVAL(isa))) { + XSRETURN_YES; + } + } + + get_package_symbols(stash, TYPE_FILTER_CODE, find_method, &found_method); + if (found_method) { + XSRETURN_YES; + } + + XSRETURN_NO; diff --git a/xs/Method.xs b/xs/Method.xs new file mode 100644 index 0000000..18865bc --- /dev/null +++ b/xs/Method.xs @@ -0,0 +1,54 @@ +#include "mop.h" + +NEEDS_KEY(name); +NEEDS_KEY(body); +NEEDS_KEY(package_name); + +MODULE = Class::MOP::Method PACKAGE = Class::MOP::Method + +PROTOTYPES: DISABLE + +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; diff --git a/xs/Package.xs b/xs/Package.xs new file mode 100644 index 0000000..7bc25ca --- /dev/null +++ b/xs/Package.xs @@ -0,0 +1,53 @@ +#include "mop.h" + +NEEDS_KEY(package); + +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_package, 0, hash_package)) ) { + stash = gv_stashsv(HeVAL(he), 0); + } + + + if (!stash) { + XSRETURN_UNDEF; + } + + symbols = get_all_package_symbols(stash, filter); + PUSHs(sv_2mortal(newRV_noinc((SV *)symbols))); + +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; diff --git a/typemap b/xs/typemap similarity index 100% rename from typemap rename to xs/typemap