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