X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=MOP.xs;h=9be66a1be9ec689ed41570f377dae1658256ee98;hb=6b5ac420e48ce3b29d9fe53094954821508b2925;hp=39e54b4306c1a86ebc32565395e9cfd5d31a4cfa;hpb=6bd19edb48b45c76562cd8163a8d546d57ff2c86;p=gitmo%2FClass-MOP.git

diff --git a/MOP.xs b/MOP.xs
index 39e54b4..9be66a1 100644
--- a/MOP.xs
+++ b/MOP.xs
@@ -25,9 +25,15 @@ U32 hash_package_name;
 SV *key_body;
 U32 hash_body;
 
-SV* method_metaclass;
-SV* associated_metaclass;
-SV* wrap;
+SV *key_package_cache_flag;
+U32 hash_package_cache_flag;
+
+SV *key_methods;
+U32 hash_methods;
+
+SV *method_metaclass;
+SV *associated_metaclass;
+SV *wrap;
 
 
 #define check_package_cache_flag(stash) mop_check_package_cache_flag(aTHX_ stash)
@@ -47,7 +53,7 @@ mop_check_package_cache_flag(pTHX_ HV* stash) {
 #else /* pre 5.10.0 */
 
 static UV
-mop_check_package_cache_flag(pTHX_ HV* stash) {
+mop_check_package_cache_flag(pTHX_ HV *stash) {
     PERL_UNUSED_ARG(stash);
     assert(SvTYPE(stash) == SVt_PVHV);
 
@@ -56,10 +62,10 @@ mop_check_package_cache_flag(pTHX_ HV* stash) {
 #endif
 
 #define call0(s, m)  mop_call0(aTHX_ s, m)
-static SV*
-mop_call0(pTHX_ SV* const self, SV* const method) {
+static SV *
+mop_call0(pTHX_ SV *const self, SV *const method) {
     dSP;
-    SV* ret;
+    SV *ret;
 
     PUSHMARK(SP);
     XPUSHs(self);
@@ -74,100 +80,197 @@ mop_call0(pTHX_ SV* const self, SV* const method) {
     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;
+static int
+get_code_info (SV *coderef, char **pkg, char **name)
+{
+    if (!SvOK(coderef) || !SvROK(coderef) || SvTYPE(SvRV(coderef)) != SVt_PVCV) {
+        return 0;
+    }
 
-    /* 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 */
+    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;
+
+static HV *
+get_all_package_symbols(HV *stash, type_filter_t filter)
+{
+    HE *he;
+    HV *ret = newHV();
+
+    (void)hv_iterinit(stash);
+
+    if (filter == TYPE_FILTER_NONE) {
+        while ( (he = hv_iternext(stash)) ) {
+            STRLEN keylen;
+            char *key = HePV(he, keylen);
+            if (!hv_store(ret, key, keylen, SvREFCNT_inc(HeVAL(he)), 0)) {
+                croak("failed to store glob ref");
+            }
+        }
+
+        return ret;
+    }
 
-    hv_iterinit(stash);
-    while ( (gv = (GV*)hv_iternextsv(stash, &method_name, &method_name_len)) ) {
-        CV* cv;
-        switch (SvTYPE (gv)) {
+    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:
-                if (!SvROK(gv)) {
-                    break;
-                }
-                /* fall through */
-            case SVt_IV:
+#endif
             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);
+            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 ( 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;
-                }
+        if (sv) {
+            char *key = HePV(he, keylen);
+            if (!hv_store(ret, key, keylen, newRV_inc(sv), 0)) {
+                croak("failed to store symbol ref");
             }
+        }
+    }
 
-            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;
-                }
+    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_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;
+        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:
@@ -182,11 +285,15 @@ BOOT:
     key_body = newSVpvs("body");
     key_package = newSVpvs("package");
     key_package_name = newSVpvs("package_name");
+    key_package_cache_flag = newSVpvs("_package_cache_flag");
+    key_methods = newSVpvs("methods");
 
     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);
+    PERL_HASH(hash_package_cache_flag, "_package_cache_flag", 19);
+    PERL_HASH(hash_methods, "methods", 7);
 
     method_metaclass     = newSVpvs("method_metaclass");
     wrap                 = newSVpvs("wrap");
@@ -198,141 +305,76 @@ PROTOTYPES: ENABLE
 
 void
 get_code_info(coderef)
-  SV* coderef
-  PREINIT:
-    char* name;
-    char* pkg;
-  PPCODE:
-    if ( SvOK(coderef) && SvROK(coderef) && SvTYPE(SvRV(coderef)) == SVt_PVCV ) {
-      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
-
-      EXTEND(SP, 2);
-      PUSHs(newSVpvn(pkg, strlen(pkg)));
-      PUSHs(newSVpvn(name, strlen(name)));
-    }
+    SV *coderef
+    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));
+        }
 
 
 MODULE = Class::MOP   PACKAGE = Class::MOP::Package
 
 void
-get_all_package_symbols(self, ...)
+get_all_package_symbols(self, filter=TYPE_FILTER_NONE)
     SV *self
+    type_filter_t filter
     PROTOTYPE: $;$
     PREINIT:
         HV *stash = NULL;
-        SV *type_filter = NULL;
+        HV *symbols = 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 (GIMME_V == G_VOID) {
+            XSRETURN_EMPTY;
         }
 
-        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) ) {
-                        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') {
-                                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;
-                        case SVt_RV:
-                            /* BAH! constants are horrible */
-
-                            if ( ! SvROK(gv) ) {
-                                continue;
-                            }
-
-                            /* 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;
-                        default:
-                            continue;
-                    }
+        if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package, 0, hash_package)) ) {
+            stash = gv_stashsv(HeVAL(he), 0);
+        }
 
-                    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;
-                }
+
+        if (!stash) {
+            switch (GIMME_V) {
+                case G_SCALAR: XSRETURN_UNDEF; break;
+                case G_ARRAY:  XSRETURN_EMPTY; break;
             }
+        }
+
+        symbols = get_all_package_symbols(stash, filter);
+
+        switch (GIMME_V) {
+            case G_SCALAR:
+                PUSHs(sv_2mortal(newRV_inc((SV *)symbols)));
+                break;
+            case G_ARRAY:
+                warn("Class::MOP::Package::get_all_package_symbols in list context is deprecated. use scalar context instead.");
 
+                EXTEND(SP, HvKEYS(symbols) * 2);
+
+                while ((he = hv_iternext(symbols))) {
+                    PUSHs(hv_iterkeysv(he));
+                    PUSHs(sv_2mortal(SvREFCNT_inc(HeVAL(he))));
+                }
+
+                break;
+            default:
+                break;
         }
 
+        SvREFCNT_dec((SV *)symbols);
+
 void
 name(self)
     SV *self
@@ -417,35 +459,25 @@ MODULE = Class::MOP    PACKAGE = Class::MOP::Class
 
 void
 get_method_map(self)
-    SV* 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);
+        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 = *hv_fetchs((HV*)SvRV(self), "_package_cache_flag", TRUE);
-        SV* const map_ref    = *hv_fetchs((HV*)SvRV(self), "methods", TRUE);
+        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:
-        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());
+        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));
+        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() */
-
-            FREETMPS;
-            LEAVE;
         }
 
         XPUSHs(map_ref);
-