indirect.xs

   1 /* This file is part of the indirect Perl module.
   2  * See http://search.cpan.org/dist/indirect/ */
   3
   4 #define PERL_NO_GET_CONTEXT
   5 #include "EXTERN.h"
   6 #include "perl.h"
   7 #include "XSUB.h"
   8
   9 #define __PACKAGE__     "indirect"
  10 #define __PACKAGE_LEN__ (sizeof(__PACKAGE__)-1)
  11
  12 /* --- Compatibility wrappers ---------------------------------------------- */
  13
  14 #ifndef SvPV_const
  15 # define SvPV_const SvPV
  16 #endif
  17
  18 #ifndef SvPV_nolen_const
  19 # define SvPV_nolen_const SvPV_nolen
  20 #endif
  21
  22 #ifndef SvPVX_const
  23 # define SvPVX_const SvPVX
  24 #endif
  25
  26 #ifndef sv_catpvn_nomg
  27 # define sv_catpvn_nomg sv_catpvn
  28 #endif
  29
  30 #ifndef HvNAME_get
  31 # define HvNAME_get(H) HvNAME(H)
  32 #endif
  33
  34 #ifndef HvNAMELEN_get
  35 # define HvNAMELEN_get(H) strlen(HvNAME_get(H))
  36 #endif
  37
  38 #define I_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
  39
  40 #if I_HAS_PERL(5, 10, 0) || defined(PL_parser)
  41 # ifndef PL_lex_inwhat
  42 #  define PL_lex_inwhat PL_parser->lex_inwhat
  43 # endif
  44 # ifndef PL_linestr
  45 #  define PL_linestr PL_parser->linestr
  46 # endif
  47 # ifndef PL_bufptr
  48 #  define PL_bufptr PL_parser->bufptr
  49 # endif
  50 # ifndef PL_oldbufptr
  51 #  define PL_oldbufptr PL_parser->oldbufptr
  52 # endif
  53 #else
  54 # ifndef PL_lex_inwhat
  55 #  define PL_lex_inwhat PL_Ilex_inwhat
  56 # endif
  57 # ifndef PL_linestr
  58 #  define PL_linestr PL_Ilinestr
  59 # endif
  60 # ifndef PL_bufptr
  61 #  define PL_bufptr PL_Ibufptr
  62 # endif
  63 # ifndef PL_oldbufptr
  64 #  define PL_oldbufptr PL_Ioldbufptr
  65 # endif
  66 #endif
  67
  68 /* ... Hints ............................................................... */
  69
  70 STATIC U32 indirect_hash = 0;
  71
  72 STATIC IV indirect_hint(pTHX) {
  73 #define indirect_hint() indirect_hint(aTHX)
  74  SV *id;
  75 #if I_HAS_PERL(5, 10, 0)
  76  id = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
  77                                      NULL,
  78                                      __PACKAGE__, __PACKAGE_LEN__,
  79                                      0,
  80                                      indirect_hash);
  81 #else
  82  SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__,
  83                                                                  indirect_hash);
  84  if (!val)
  85   return 0;
  86  id = *val;
  87 #endif
  88  return (id && SvOK(id) && SvIOK(id)) ? SvIV(id) : 0;
  89 }
  90
  91 /* ... op -> source position ............................................... */
  92
  93 #define PTABLE_NAME        ptable_map
  94 #define PTABLE_VAL_FREE(V) SvREFCNT_dec(V)
  95
  96 #define pPTBL  pTHX
  97 #define pPTBL_ pTHX_
  98 #define aPTBL  aTHX
  99 #define aPTBL_ aTHX_
 100
 101 #include "ptable.h"
 102
 103 #define ptable_map_store(T, K, V) ptable_map_store(aTHX_ (T), (K), (V))
 104 #define ptable_map_clear(T)       ptable_map_clear(aTHX_ (T))
 105 #define ptable_map_free(T)        ptable_map_free(aTHX_ (T))
 106
 107 STATIC ptable *indirect_map = NULL;
 108
 109 STATIC const char *indirect_linestr = NULL;
 110
 111 STATIC void indirect_map_store(pTHX_ const OP *o, const char *src, SV *sv) {
 112 #define indirect_map_store(O, S, N) indirect_map_store(aTHX_ (O), (S), (N))
 113  SV *val;
 114
 115  /* When lex_inwhat is set, we're in a quotelike environment (qq, qr, but not q)
 116   * In this case the linestr has temporarly changed, but the old buffer should
 117   * still be alive somewhere. */
 118
 119  if (!PL_lex_inwhat) {
 120   const char *pl_linestr = SvPVX_const(PL_linestr);
 121   if (indirect_linestr != pl_linestr) {
 122    ptable_map_clear(indirect_map);
 123    indirect_linestr = pl_linestr;
 124   }
 125  }
 126
 127  val = newSVsv(sv);
 128  SvUPGRADE(val, SVt_PVIV);
 129  SvUVX(val) = PTR2UV(src);
 130  SvIOK_on(val);
 131  SvIsUV_on(val);
 132
 133  ptable_map_store(indirect_map, o, val);
 134 }
 135
 136 STATIC const char *indirect_map_fetch(pTHX_ const OP *o, SV ** const name) {
 137 #define indirect_map_fetch(O, S) indirect_map_fetch(aTHX_ (O), (S))
 138  SV *val;
 139
 140  if (indirect_linestr != SvPVX_const(PL_linestr))
 141   return NULL;
 142
 143  val = ptable_fetch(indirect_map, o);
 144  if (!val) {
 145   *name = NULL;
 146   return NULL;
 147  }
 148
 149  *name = val;
 150  return INT2PTR(const char *, SvUVX(val));
 151 }
 152
 153 STATIC const char *indirect_find(pTHX_ SV *sv, const char *s) {
 154 #define indirect_find(N, S) indirect_find(aTHX_ (N), (S))
 155  STRLEN len;
 156  const char *p = NULL, *r = SvPV_const(sv, len);
 157
 158  if (len >= 1 && *r == '$') {
 159   ++r;
 160   --len;
 161   s = strchr(s, '$');
 162   if (!s)
 163    return NULL;
 164  }
 165
 166  p = strstr(s, r);
 167  while (p) {
 168   p += len;
 169   if (!isALNUM(*p))
 170    break;
 171   p = strstr(p + 1, r);
 172  }
 173
 174  return p;
 175 }
 176
 177 /* ... ck_const ............................................................ */
 178
 179 STATIC OP *(*indirect_old_ck_const)(pTHX_ OP *) = 0;
 180
 181 STATIC OP *indirect_ck_const(pTHX_ OP *o) {
 182  o = CALL_FPTR(indirect_old_ck_const)(aTHX_ o);
 183
 184  if (indirect_hint()) {
 185   SV *sv = cSVOPo_sv;
 186   if (SvPOK(sv) && (SvTYPE(sv) >= SVt_PV))
 187    indirect_map_store(o, indirect_find(sv, PL_oldbufptr), sv);
 188  }
 189
 190  return o;
 191 }
 192
 193 /* ... ck_rv2sv ............................................................ */
 194
 195 STATIC OP *(*indirect_old_ck_rv2sv)(pTHX_ OP *) = 0;
 196
 197 STATIC OP *indirect_ck_rv2sv(pTHX_ OP *o) {
 198  if (indirect_hint()) {
 199   OP *op = cUNOPo->op_first;
 200   SV *sv;
 201   const char *name = NULL, *s;
 202   STRLEN len;
 203   OPCODE type = (OPCODE) op->op_type;
 204
 205   switch (type) {
 206    case OP_GV:
 207    case OP_GVSV: {
 208     GV *gv = cGVOPx_gv(op);
 209     name = GvNAME(gv);
 210     len  = GvNAMELEN(gv);
 211     break;
 212    }
 213    default:
 214     if ((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP) {
 215      SV *nsv = cSVOPx_sv(op);
 216      if (SvPOK(nsv) && (SvTYPE(nsv) >= SVt_PV))
 217       name = SvPV_const(nsv, len);
 218     }
 219   }
 220   if (!name)
 221    goto done;
 222
 223   sv = sv_2mortal(newSVpvn("$", 1));
 224   sv_catpvn_nomg(sv, name, len);
 225   s = indirect_find(sv, PL_oldbufptr);
 226   if (!s) { /* If it failed, retry without the current stash */
 227    const char *stash = HvNAME_get(PL_curstash);
 228    STRLEN stashlen = HvNAMELEN_get(PL_curstash);
 229
 230    if ((len < stashlen + 2) || strnNE(name, stash, stashlen)
 231        || name[stashlen] != ':' || name[stashlen+1] != ':') {
 232     /* Failed again ? Try to remove main */
 233     stash = "main";
 234     stashlen = 4;
 235     if ((len < stashlen + 2) || strnNE(name, stash, stashlen)
 236         || name[stashlen] != ':' || name[stashlen+1] != ':')
 237      goto done;
 238    }
 239
 240    sv_setpvn(sv, "$", 1);
 241    stashlen += 2;
 242    sv_catpvn_nomg(sv, name + stashlen, len - stashlen);
 243    s = indirect_find(sv, PL_oldbufptr);
 244    if (!s)
 245     goto done;
 246   }
 247
 248   o = CALL_FPTR(indirect_old_ck_rv2sv)(aTHX_ o);
 249   indirect_map_store(o, s, sv);
 250   return o;
 251  }
 252
 253 done:
 254  return CALL_FPTR(indirect_old_ck_rv2sv)(aTHX_ o);
 255 }
 256
 257 /* ... ck_padany ........................................................... */
 258
 259 STATIC OP *(*indirect_old_ck_padany)(pTHX_ OP *) = 0;
 260
 261 STATIC OP *indirect_ck_padany(pTHX_ OP *o) {
 262  o = CALL_FPTR(indirect_old_ck_padany)(aTHX_ o);
 263
 264  if (indirect_hint()) {
 265   SV *sv;
 266   const char *s = PL_oldbufptr, *t = PL_bufptr - 1;
 267
 268   while (s < t && isSPACE(*s)) ++s;
 269   if (*s == '$' && ++s <= t) {
 270    while (s < t && isSPACE(*s)) ++s;
 271    while (s < t && isSPACE(*t)) --t;
 272    sv = sv_2mortal(newSVpvn("$", 1));
 273    sv_catpvn_nomg(sv, s, t - s + 1);
 274    indirect_map_store(o, s, sv);
 275   }
 276  }
 277
 278  return o;
 279 }
 280
 281 /* ... ck_method ........................................................... */
 282
 283 STATIC OP *(*indirect_old_ck_method)(pTHX_ OP *) = 0;
 284
 285 STATIC OP *indirect_ck_method(pTHX_ OP *o) {
 286  if (indirect_hint()) {
 287   OP *op = cUNOPo->op_first;
 288   SV *sv;
 289   const char *s = indirect_map_fetch(op, &sv);
 290   if (!s) {
 291    sv = cSVOPx_sv(op);
 292    if (!SvPOK(sv) || (SvTYPE(sv) < SVt_PV))
 293     goto done;
 294    sv = sv_mortalcopy(sv);
 295    s  = indirect_find(sv, PL_oldbufptr);
 296   }
 297   o = CALL_FPTR(indirect_old_ck_method)(aTHX_ o);
 298   /* o may now be a method_named */
 299   indirect_map_store(o, s, sv);
 300   return o;
 301  }
 302
 303 done:
 304  return CALL_FPTR(indirect_old_ck_method)(aTHX_ o);
 305 }
 306
 307 /* ... ck_entersub ......................................................... */
 308
 309 STATIC const char indirect_msg[] = "Indirect call of method \"%s\" on object \"%s\"";
 310
 311 STATIC OP *(*indirect_old_ck_entersub)(pTHX_ OP *) = 0;
 312
 313 STATIC OP *indirect_ck_entersub(pTHX_ OP *o) {
 314  IV hint = indirect_hint();
 315
 316  o = CALL_FPTR(indirect_old_ck_entersub)(aTHX_ o);
 317
 318  if (hint) {
 319   const char *mpos, *opos;
 320   SV *mnamesv, *onamesv;
 321   OP *mop, *oop;
 322   LISTOP *lop;
 323
 324   oop = o;
 325   do {
 326    lop = (LISTOP *) oop;
 327    if (!(lop->op_flags & OPf_KIDS))
 328     goto done;
 329    oop = lop->op_first;
 330   } while (oop->op_type != OP_PUSHMARK);
 331   oop = oop->op_sibling;
 332   mop = lop->op_last;
 333
 334   if (mop->op_type == OP_METHOD)
 335    mop = cUNOPx(mop)->op_first;
 336   else if (mop->op_type != OP_METHOD_NAMED)
 337    goto done;
 338
 339   mpos = indirect_map_fetch(mop, &mnamesv);
 340   if (!mpos)
 341    goto done;
 342
 343   opos = indirect_map_fetch(oop, &onamesv);
 344   if (!opos)
 345    goto done;
 346
 347   if (mpos < opos) {
 348    const char *mname = SvPV_nolen_const(mnamesv);
 349    const char *oname = SvPV_nolen_const(onamesv);
 350    if (hint == 2)
 351     croak(indirect_msg, mname, oname);
 352    else
 353     warn(indirect_msg, mname, oname);
 354   }
 355  }
 356
 357 done:
 358  return o;
 359 }
 360
 361 STATIC U32 indirect_initialized = 0;
 362
 363 /* --- XS ------------------------------------------------------------------ */
 364
 365 MODULE = indirect      PACKAGE = indirect
 366
 367 PROTOTYPES: DISABLE
 368
 369 BOOT:
 370 {
 371  if (!indirect_initialized++) {
 372   indirect_map = ptable_new();
 373
 374   PERL_HASH(indirect_hash, __PACKAGE__, __PACKAGE_LEN__);
 375
 376   indirect_old_ck_const    = PL_check[OP_CONST];
 377   PL_check[OP_CONST]       = MEMBER_TO_FPTR(indirect_ck_const);
 378   indirect_old_ck_rv2sv    = PL_check[OP_RV2SV];
 379   PL_check[OP_RV2SV]       = MEMBER_TO_FPTR(indirect_ck_rv2sv);
 380   indirect_old_ck_padany   = PL_check[OP_PADANY];
 381   PL_check[OP_PADANY]      = MEMBER_TO_FPTR(indirect_ck_padany);
 382   indirect_old_ck_method   = PL_check[OP_METHOD];
 383   PL_check[OP_METHOD]      = MEMBER_TO_FPTR(indirect_ck_method);
 384   indirect_old_ck_entersub = PL_check[OP_ENTERSUB];
 385   PL_check[OP_ENTERSUB]    = MEMBER_TO_FPTR(indirect_ck_entersub);
 386  }
 387 }