lib/Class/C3/XS.xs

   1
   2 #include "EXTERN.h"
   3 #include "perl.h"
   4 #include "XSUB.h"
   5
   6 STATIC I32
   7 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
   8     I32 i;
   9     for (i = startingblock; i >= 0; i--) {
  10         register const PERL_CONTEXT * const cx = &cxstk[i];
  11         switch (CxTYPE(cx)) {
  12         default:
  13             continue;
  14         case CXt_EVAL:
  15         case CXt_SUB:
  16         case CXt_FORMAT:
  17             DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
  18             return i;
  19         }
  20     }
  21     return i;
  22 }
  23
  24 MODULE = Class::C3::XS  PACKAGE = next
  25
  26 #ifdef XXX_NEW_PERL /* some sort of cpp check for a perl that has mro_linear */
  27
  28 /* we want to define next::can, next::method, and maybe::next::method */
  29
  30 CV*
  31 canxs(self)
  32     SV* self
  33   PPCODE:
  34     register I32 cxix = __dopoptosub_at(cxstack, cxstack_ix);
  35     register const PERL_CONTEXT *cx;
  36     register const PERL_CONTEXT *ccstack = cxstack;
  37     const PERL_SI *top_si = PL_curstackinfo;
  38     HV* selfstash;
  39     //sv_dump(self);
  40     if(sv_isobject(self)) {
  41         selfstash = SvSTASH(SvRV(self));
  42     }
  43     else {
  44         selfstash = gv_stashsv(self, 0);
  45     }
  46     assert(selfstash);
  47
  48     for (;;) {
  49         /* we may be in a higher stacklevel, so dig down deeper */
  50         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
  51             top_si = top_si->si_prev;
  52             ccstack = top_si->si_cxstack;
  53             cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
  54         }
  55         if (cxix < 0) {
  56             croak("next::/maybe::next:: must be used in method context");
  57         }
  58
  59         /* caller() should not report the automatic calls to &DB::sub */
  60         if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
  61             continue;
  62
  63         cx = &ccstack[cxix];
  64         if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
  65             const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
  66             /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
  67                field below is defined for any cx. */
  68             /* caller() should not report the automatic calls to &DB::sub */
  69             if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
  70                 cx = &ccstack[dbcxix];
  71             }
  72             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
  73                 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
  74                 /* So is ccstack[dbcxix]. */
  75                 if (isGV(cvgv)) { /* we found a real sub here */
  76                     const char *stashname;
  77                     const char *fq_subname;
  78                     const char *subname;
  79                     STRLEN fq_subname_len;
  80                     STRLEN stashname_len;
  81                     STRLEN subname_len;
  82                     GV * found_gv;
  83                     SV * const sv = sv_2mortal(newSV(0));
  84
  85                     gv_efullname3(sv, cvgv, NULL);
  86
  87                     fq_subname = SvPVX(sv);
  88                     fq_subname_len = SvCUR(sv);
  89 /*                    warn("fqsubname is %s", fq_subname); */
  90
  91                     subname = strrchr(fq_subname, ':');
  92                     if(subname) {
  93                         subname++;
  94                         subname_len = fq_subname_len - (subname - fq_subname);
  95                         stashname = fq_subname;
  96                         stashname_len = subname - fq_subname - 2;
  97                         if(subname_len == 8 && strEQ(subname, "__ANON__")) {
  98                             croak("Cannot use next::method/next::can/maybe::next::method from an anonymous sub");
  99                         }
 100                         else {
 101                             GV** gvp;
 102                             AV* linear_av;
 103                             SV** linear_svp;
 104                             SV* linear_sv;
 105                             HV* curstash;
 106                             GV* candidate = NULL;
 107                             CV* cand_cv = NULL;
 108                             const char *hvname;
 109                             I32 items;
 110
 111                             hvname = HvNAME_get(selfstash);
 112                             if (!hvname)
 113                               Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
 114
 115                             linear_av = mro_linear(selfstash); /* has ourselves at the top of the list */
 116                             sv_2mortal((SV*)linear_av);
 117
 118                             linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
 119                             items = AvFILLp(linear_av); /* no +1, to skip over self */
 120
 121                             while (items--) {
 122                                 linear_sv = *linear_svp++;
 123                                 assert(linear_sv);
 124                                 if(strEQ(SvPVX(linear_sv), stashname)) break;
 125                             }
 126
 127                             while (items--) {
 128                                 linear_sv = *linear_svp++;
 129                                 assert(linear_sv);
 130                                 curstash = gv_stashsv(linear_sv, FALSE);
 131
 132                                 if (!curstash) {
 133                                     if (ckWARN(WARN_MISC))
 134                                         Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
 135                                             (void*)linear_sv, hvname);
 136                                     continue;
 137                                 }
 138
 139                                 assert(curstash);
 140
 141                                 gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
 142                                 if (!gvp) continue;
 143                                 candidate = *gvp;
 144                                 assert(candidate);
 145                                 if (SvTYPE(candidate) != SVt_PVGV) gv_init(candidate, curstash, subname, subname_len, TRUE);
 146                                 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
 147                                     PUSHs((SV*)cand_cv);
 148                                     return;
 149                                 }
 150                             }
 151
 152                             /* Check UNIVERSAL without caching */
 153                             if((candidate = gv_fetchmeth(NULL, subname, subname_len, 1))) {
 154                                 PUSHs((SV*)GvCV(candidate));
 155                                 return;
 156                             }
 157                             PUSHs(&PL_sv_undef);
 158                             return;
 159                         }
 160                     }
 161                 }
 162             }
 163
 164             cxix = __dopoptosub_at(ccstack, cxix - 1);
 165         }
 166
 167
 168 #else /* mro_linear stuff not in core, so do some helpers for the pure-perl variant */
 169
 170 /* we want to define two helper functions:
 171    1) A replacement for Alg::C3::merge based on mro_linear_c3, but without the mro_meta caching parts.
 172       it should have optional merge cache support just like Alg::C3 does, but only support @ISA, not
 173       generic parents.  Call it Class::C3::calculateMRO_XS or something.
 174    2) A fast "fetch the most recent caller's package/sub-names", based on the xs can function above,
 175       to speed up the top half of pure-perl next::method.
 176 */
 177 #endif