Op.xs

   1 /* This file is part of the Sub::Op Perl module.
   2  * See http://search.cpan.org/dist/Sub-Op/ */
   3
   4 #define PERL_NO_GET_CONTEXT
   5 #include "EXTERN.h"
   6 #include "perl.h"
   7 #include "XSUB.h"
   8
   9 #define __PACKAGE__     "Sub::Op"
  10 #define __PACKAGE_LEN__ (sizeof(__PACKAGE__)-1)
  11
  12 /* --- Compatibility wrappers ---------------------------------------------- */
  13
  14 #define SO_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
  15
  16 /* ... Thread safety and multiplicity ...................................... */
  17
  18 #ifndef SO_MULTIPLICITY
  19 # if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT)
  20 #  define SO_MULTIPLICITY 1
  21 # else
  22 #  define SO_MULTIPLICITY 0
  23 # endif
  24 #endif
  25 #if SO_MULTIPLICITY && !defined(tTHX)
  26 # define tTHX PerlInterpreter*
  27 #endif
  28
  29 #if SO_MULTIPLICITY && defined(USE_ITHREADS) && defined(dMY_CXT) && defined(MY_CXT) && defined(START_MY_CXT) && defined(MY_CXT_INIT) && (defined(MY_CXT_CLONE) || defined(dMY_CXT_SV))
  30 # define SO_THREADSAFE 1
  31 # ifndef MY_CXT_CLONE
  32 #  define MY_CXT_CLONE \
  33     dMY_CXT_SV;                                                      \
  34     my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \
  35     Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t); \
  36     sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
  37 # endif
  38 #else
  39 # define SO_THREADSAFE 0
  40 # undef  dMY_CXT
  41 # define dMY_CXT      dNOOP
  42 # undef  MY_CXT
  43 # define MY_CXT       indirect_globaldata
  44 # undef  START_MY_CXT
  45 # define START_MY_CXT STATIC my_cxt_t MY_CXT;
  46 # undef  MY_CXT_INIT
  47 # define MY_CXT_INIT  NOOP
  48 # undef  MY_CXT_CLONE
  49 # define MY_CXT_CLONE NOOP
  50 #endif
  51
  52 /* --- Global data --------------------------------------------------------- */
  53
  54 #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
  55
  56 typedef struct {
  57  HV  *map;
  58  CV  *placeholder;
  59 #if SO_THREADSAFE
  60  tTHX owner;
  61 #endif /* SO_THREADSAFE */
  62 } my_cxt_t;
  63
  64 START_MY_CXT
  65
  66 #if SO_THREADSAFE
  67
  68 STATIC SV *so_clone(pTHX_ SV *sv, tTHX owner) {
  69 #define so_clone(S, O) so_clone(aTHX_ (S), (O))
  70  CLONE_PARAMS  param;
  71  AV           *stashes = NULL;
  72  SV           *dupsv;
  73
  74  if (SvTYPE(sv) == SVt_PVHV && HvNAME_get(sv))
  75   stashes = newAV();
  76
  77  param.stashes    = stashes;
  78  param.flags      = 0;
  79  param.proto_perl = owner;
  80
  81  dupsv = sv_dup(sv, &param);
  82
  83  if (stashes) {
  84   av_undef(stashes);
  85   SvREFCNT_dec(stashes);
  86  }
  87
  88  return SvREFCNT_inc(dupsv);
  89 }
  90
  91 #endif /* SO_THREADSAFE */
  92
  93 /* --- Public API ---------------------------------------------------------- */
  94
  95 #include "sub_op.h"
  96
  97 void sub_op_init(sub_op_config_t *c) {
  98  c->name     = NULL;
  99  c->namelen  = 0;
 100  c->proto    = NULL;
 101  c->protolen = 0;
 102  c->call     = 0;
 103  c->ref      = 0;
 104  c->ud       = NULL;
 105
 106  return;
 107 }
 108
 109 void sub_op_register(pTHX_ const sub_op_config_t *c, U32 flags) {
 110  dMY_CXT;
 111
 112  if (!(flags & SUB_OP_REGISTER_STEAL))
 113   c = sub_op_dup(aTHX_ c);
 114
 115  (void) hv_store(MY_CXT.map, c->name, c->namelen, newSViv(PTR2IV(c)), 0);
 116 }
 117
 118 STATIC const char *so_strndup(pTHX_ const char *s, STRLEN len) {
 119 #define so_strndup(S, L) so_strndup(aTHX_ (S), (L))
 120  const char *d;
 121
 122  if (!s)
 123   return NULL;
 124
 125  d = PerlMemShared_malloc(len + 1);
 126  Copy(s, d, len, char);
 127  ((char *) d)[len] = '\0';
 128
 129  return d;
 130 }
 131
 132 sub_op_config_t *sub_op_dup(pTHX_ const sub_op_config_t *orig) {
 133  sub_op_config_t *dupe = PerlMemShared_malloc(sizeof *dupe);
 134
 135  dupe->name    = so_strndup(orig->name, orig->namelen);
 136  dupe->namelen = orig->namelen;
 137
 138  dupe->proto    = so_strndup(orig->proto, orig->protolen);
 139  dupe->protolen = orig->protolen;
 140
 141  dupe->call = orig->call;
 142  dupe->ref  = orig->ref;
 143  dupe->ud   = orig->ud;
 144
 145  return dupe;
 146 }
 147
 148 void sub_op_free(pTHX_ sub_op_config_t *c) {
 149  PerlMemShared_free((char *) c->name);
 150  PerlMemShared_free(c);
 151
 152  return;
 153 }
 154
 155 OP *sub_op_study(const OP *o, OP **last_arg_p, OP **rv2cv_p) {
 156  OP *ex_list, *last_arg, *rv2cv, *gvop;
 157
 158  ex_list = cUNOPo->op_first;
 159  /* pushmark when a method call */
 160  if (!ex_list || ex_list->op_type != OP_NULL)
 161   goto skip;
 162
 163  rv2cv = cUNOPx(ex_list)->op_first;
 164  if (!rv2cv)
 165   goto skip;
 166
 167  while (1) {
 168   OP *next = rv2cv->op_sibling;
 169   if (!next)
 170    break;
 171   last_arg = rv2cv;
 172   rv2cv    = next;
 173  }
 174
 175  if (!(rv2cv->op_flags & OPf_KIDS))
 176   goto skip;
 177
 178  gvop = cUNOPx(rv2cv)->op_first;
 179
 180  if (gvop && gvop->op_type == OP_GV)
 181   goto done;
 182
 183 skip:
 184  last_arg = NULL;
 185  rv2cv    = NULL;
 186  gvop     = NULL;
 187
 188 done:
 189  if (last_arg_p)
 190   *last_arg_p = last_arg;
 191  if (rv2cv_p)
 192   *rv2cv_p    = rv2cv;
 193
 194  return gvop;
 195 }
 196
 197 /* --- Private helpers ----------------------------------------------------- */
 198
 199 STATIC IV so_hint(pTHX) {
 200 #define so_hint() so_hint(aTHX)
 201  SV *hint;
 202
 203 #if SO_HAS_PERL(5, 9, 5)
 204  hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
 205                                        NULL,
 206                                        __PACKAGE__, __PACKAGE_LEN__,
 207                                        0,
 208                                        0);
 209 #else
 210  {
 211   SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, 0);
 212   if (!val)
 213    return 0;
 214   hint = *val;
 215  }
 216 #endif
 217
 218  return (SvOK(hint) && SvIOK(hint)) ? SvIVX(hint) : 0;
 219 }
 220
 221 STATIC OP *so_find_gvop(const OP *o) {
 222  OP *ex_list, *last_arg, *rv2cv, *gvop;
 223
 224  ex_list = cUNOPo->op_first;
 225  /* pushmark when a method call */
 226  if (!ex_list || ex_list->op_type != OP_NULL)
 227   goto skip;
 228
 229  rv2cv = cUNOPx(ex_list)->op_first;
 230  if (!rv2cv)
 231   goto skip;
 232
 233  while (1) {
 234   OP *next = rv2cv->op_sibling;
 235   if (!next)
 236    break;
 237   rv2cv = next;
 238  }
 239
 240  if (!(rv2cv->op_flags & OPf_KIDS))
 241   goto skip;
 242
 243  gvop = cUNOPx(rv2cv)->op_first;
 244  if (gvop && gvop->op_type == OP_GV)
 245   return gvop;
 246
 247 skip:
 248  return NULL;
 249 }
 250
 251 STATIC OP *(*so_old_ck_entersub)(pTHX_ OP *) = 0;
 252
 253 STATIC OP *so_ck_entersub(pTHX_ OP *o) {
 254  o = CALL_FPTR(so_old_ck_entersub)(aTHX_ o);
 255
 256  if (so_hint()) {
 257   OP *gvop;
 258   GV *gv;
 259
 260   if (o->op_type != OP_ENTERSUB)
 261    goto skip;
 262   if (o->op_private & OPpENTERSUB_AMPER) /* hopefully \&foo */
 263    goto skip;
 264
 265   gvop = so_find_gvop(o);
 266   if (!gvop)
 267    goto skip;
 268
 269   gv = cGVOPx_gv(gvop);
 270
 271   {
 272    SV **svp;
 273    CV  *cv = NULL;
 274    const char *name = GvNAME(gv);
 275    I32         len  = GvNAMELEN(gv);
 276    const sub_op_config_t *c;
 277    dMY_CXT;
 278
 279    svp = hv_fetch(MY_CXT.map, name, len, 0);
 280    if (!svp)
 281     goto skip;
 282
 283    c = INT2PTR(const sub_op_config_t *, SvIVX(*svp));
 284
 285    if (gv && SvTYPE(gv) >= SVt_PVGV && (cv = GvCV(gv)) == MY_CXT.placeholder) {
 286     SvREFCNT_dec(cv);
 287     GvCV(gv) = NULL;
 288    }
 289
 290    if (c->call)
 291     o = CALL_FPTR(c->call)(aTHX_ o, c->ud);
 292   }
 293  }
 294
 295 skip:
 296  return o;
 297 }
 298
 299 STATIC OP *(*so_old_ck_refgen)(pTHX_ OP *) = 0;
 300
 301 STATIC OP *so_ck_refgen(pTHX_ OP *o) {
 302  o = CALL_FPTR(so_old_ck_refgen)(aTHX_ o);
 303
 304  if (so_hint()) {
 305   OP *kid    = o;
 306   OP *prev   = NULL;
 307   OP *parent = NULL;
 308
 309   while (kid->op_flags & OPf_KIDS) {
 310    parent = kid;
 311    kid    = cUNOPx(kid)->op_first;
 312   }
 313
 314   if (!parent)
 315    goto skip;
 316
 317   for (kid; kid; prev = kid, kid = kid->op_sibling) {
 318    OP *gvop;
 319    GV *gv;
 320    const sub_op_config_t *c;
 321
 322    if (kid->op_type != OP_RV2CV)
 323     continue;
 324
 325    gvop = so_find_gvop(kid);
 326    if (!gvop)
 327     continue;
 328
 329    gv = cGVOPx_gv(gvop);
 330
 331    {
 332     SV **svp;
 333     const char *name = GvNAME(gv);
 334     I32         len  = GvNAMELEN(gv);
 335     dMY_CXT;
 336
 337     svp = hv_fetch(MY_CXT.map, name, len, 0);
 338     if (!svp)
 339      continue;
 340
 341     c = INT2PTR(const sub_op_config_t *, SvIVX(*svp));
 342    }
 343
 344    if (c->ref) {
 345     OP *new_kid = CALL_FPTR(c->ref)(aTHX_ kid, c->ud);
 346
 347     if (new_kid != kid) {
 348      new_kid->op_sibling = kid->op_sibling;
 349      new_kid->op_next = new_kid;
 350      if (prev)
 351       prev->op_sibling = new_kid;
 352      else
 353       cUNOPx(parent)->op_first = new_kid;
 354      op_null(kid);
 355      kid = new_kid;
 356     }
 357    }
 358   }
 359  }
 360
 361 skip:
 362  return o;
 363 }
 364
 365 STATIC OP *(*so_old_ck_gelem)(pTHX_ OP *) = 0;
 366
 367 STATIC OP *so_ck_gelem(pTHX_ OP *o) {
 368  o = CALL_FPTR(so_old_ck_entersub)(aTHX_ o);
 369
 370  if (so_hint()) {
 371   OP *rv2gv, *gvop;
 372   GV *gv;
 373
 374   rv2gv = cUNOPo->op_first;
 375   if (!rv2gv)
 376    goto skip;
 377
 378   gvop = cUNOPx(rv2gv)->op_first;
 379   if (!gvop || gvop->op_type != OP_GV)
 380    goto skip;
 381
 382   gv = cGVOPx_gv(gvop);
 383   if (!gv)
 384    goto skip;
 385
 386   {
 387    CV *cv;
 388    dMY_CXT;
 389
 390    if (gv && SvTYPE(gv) >= SVt_PVGV && (cv = GvCV(gv)) == MY_CXT.placeholder) {
 391     SvREFCNT_dec(cv);
 392     GvCV(gv) = NULL;
 393    }
 394   }
 395  }
 396
 397 skip:
 398  return o;
 399 }
 400
 401 /* --- XS ------------------------------------------------------------------ */
 402
 403 MODULE = Sub::Op      PACKAGE = Sub::Op
 404
 405 PROTOTYPES: ENABLE
 406
 407 BOOT:
 408 {
 409  MY_CXT_INIT;
 410  MY_CXT.map         = newHV();
 411  MY_CXT.placeholder = NULL;
 412 #if SO_THREADSAFE
 413  MY_CXT.owner       = aTHX;
 414 #endif /* SO_THREADSAFE */
 415
 416  so_old_ck_entersub    = PL_check[OP_ENTERSUB];
 417  PL_check[OP_ENTERSUB] = so_ck_entersub;
 418  so_old_ck_refgen      = PL_check[OP_REFGEN];
 419  PL_check[OP_REFGEN]   = so_ck_refgen;
 420  so_old_ck_gelem       = PL_check[OP_GELEM];
 421  PL_check[OP_GELEM]    = so_ck_gelem;
 422 }
 423
 424 #if SO_THREADSAFE
 425
 426 void
 427 CLONE(...)
 428 PROTOTYPE: DISABLE
 429 PREINIT:
 430  HV  *map;
 431  CV  *placeholder;
 432  tTHX owner;
 433 PPCODE:
 434  {
 435   dMY_CXT;
 436   owner       = MY_CXT.owner;
 437   map         = (HV *) so_clone((SV *) MY_CXT.map,         owner);
 438   placeholder = (CV *) so_clone((SV *) MY_CXT.placeholder, owner);
 439  }
 440  {
 441   MY_CXT_CLONE;
 442   MY_CXT.map         = map;
 443   MY_CXT.placeholder = placeholder;
 444   MY_CXT.owner       = aTHX;
 445  }
 446  XSRETURN(0);
 447
 448 #endif /* SO_THREADSAFE */
 449
 450 void
 451 _placeholder(SV *sv)
 452 PROTOTYPE: $
 453 PPCODE:
 454  if (SvROK(sv)) {
 455   sv = SvRV(sv);
 456   if (SvTYPE(sv) >= SVt_PVCV) {
 457    dMY_CXT;
 458    SvREFCNT_dec(MY_CXT.placeholder);
 459    MY_CXT.placeholder = (CV *) SvREFCNT_inc(sv);
 460   }
 461  }
 462  XSRETURN(0);
 463
 464 void
 465 _constant_sub(SV *sv)
 466 PROTOTYPE: $
 467 PPCODE:
 468  if (!SvROK(sv))
 469   XSRETURN_UNDEF;
 470  sv = SvRV(sv);
 471  if (SvTYPE(sv) < SVt_PVCV)
 472   XSRETURN_UNDEF;
 473  ST(0) = sv_2mortal(newSVuv(CvCONST(sv)));
 474  XSRETURN(1);
 475
 476 SV *
 477 _get_prototype(SV *name)
 478 PROTOTYPE: $
 479 PREINIT:
 480  HE *he;
 481  const sub_op_config_t *c;
 482 PPCODE:
 483  dMY_CXT;
 484  he = hv_fetch_ent(MY_CXT.map, name, 0, 0);
 485  if (!he)
 486   XSRETURN_UNDEF;
 487  c = INT2PTR(const sub_op_config_t *, SvIVX(HeVAL(he)));
 488  if (!c->proto)
 489   XSRETURN_UNDEF;
 490  ST(0) = sv_2mortal(newSVpvn(c->proto, c->protolen));
 491  XSRETURN(1);