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 NOOP
  15 # define NOOP
  16 #endif
  17
  18 #ifndef dNOOP
  19 # define dNOOP
  20 #endif
  21
  22 #ifndef Newx
  23 # define Newx(v, n, c) New(0, v, n, c)
  24 #endif
  25
  26 #ifndef SvPV_const
  27 # define SvPV_const SvPV
  28 #endif
  29
  30 #ifndef SvPV_nolen_const
  31 # define SvPV_nolen_const SvPV_nolen
  32 #endif
  33
  34 #ifndef SvPVX_const
  35 # define SvPVX_const SvPVX
  36 #endif
  37
  38 #ifndef SvREFCNT_inc_simple_void_NN
  39 # ifdef SvREFCNT_inc_simple_NN
  40 #  define SvREFCNT_inc_simple_void_NN SvREFCNT_inc_simple_NN
  41 # else
  42 #  define SvREFCNT_inc_simple_void_NN SvREFCNT_inc
  43 # endif
  44 #endif
  45
  46 #ifndef sv_catpvn_nomg
  47 # define sv_catpvn_nomg sv_catpvn
  48 #endif
  49
  50 #ifndef mPUSHp
  51 # define mPUSHp(P, L) PUSHs(sv_2mortal(newSVpvn((P), (L))))
  52 #endif
  53
  54 #ifndef mPUSHu
  55 # define mPUSHu(U) PUSHs(sv_2mortal(newSVuv(U)))
  56 #endif
  57
  58 #ifndef HvNAME_get
  59 # define HvNAME_get(H) HvNAME(H)
  60 #endif
  61
  62 #ifndef HvNAMELEN_get
  63 # define HvNAMELEN_get(H) strlen(HvNAME_get(H))
  64 #endif
  65
  66 #ifndef OpSIBLING
  67 # ifdef OP_SIBLING
  68 #  define OpSIBLING(O) OP_SIBLING(O)
  69 # else
  70 #  define OpSIBLING(O) ((O)->op_sibling)
  71 # endif
  72 #endif
  73
  74 #define I_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
  75
  76 #if I_HAS_PERL(5, 10, 0) || defined(PL_parser)
  77 # ifndef PL_linestr
  78 #  define PL_linestr PL_parser->linestr
  79 # endif
  80 # ifndef PL_bufptr
  81 #  define PL_bufptr PL_parser->bufptr
  82 # endif
  83 # ifndef PL_oldbufptr
  84 #  define PL_oldbufptr PL_parser->oldbufptr
  85 # endif
  86 # ifndef PL_lex_inwhat
  87 #  define PL_lex_inwhat PL_parser->lex_inwhat
  88 # endif
  89 #else
  90 # ifndef PL_linestr
  91 #  define PL_linestr PL_Ilinestr
  92 # endif
  93 # ifndef PL_bufptr
  94 #  define PL_bufptr PL_Ibufptr
  95 # endif
  96 # ifndef PL_oldbufptr
  97 #  define PL_oldbufptr PL_Ioldbufptr
  98 # endif
  99 # ifndef PL_lex_inwhat
 100 #  define PL_lex_inwhat PL_Ilex_inwhat
 101 # endif
 102 #endif
 103
 104 #ifndef I_WORKAROUND_REQUIRE_PROPAGATION
 105 # define I_WORKAROUND_REQUIRE_PROPAGATION !I_HAS_PERL(5, 10, 1)
 106 #endif
 107
 108 /* ... Thread safety and multiplicity ...................................... */
 109
 110 /* Safe unless stated otherwise in Makefile.PL */
 111 #ifndef I_FORKSAFE
 112 # define I_FORKSAFE 1
 113 #endif
 114
 115 #ifndef I_MULTIPLICITY
 116 # if defined(MULTIPLICITY)
 117 #  define I_MULTIPLICITY 1
 118 # else
 119 #  define I_MULTIPLICITY 0
 120 # endif
 121 #endif
 122 #if I_MULTIPLICITY
 123 # ifndef PERL_IMPLICIT_CONTEXT
 124 #  error MULTIPLICITY builds must set PERL_IMPLICIT_CONTEXT
 125 # endif
 126 #endif
 127 #if I_MULTIPLICITY && !defined(tTHX)
 128 # define tTHX PerlInterpreter*
 129 #endif
 130
 131 #if I_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))
 132 # define I_THREADSAFE 1
 133 # ifndef MY_CXT_CLONE
 134 #  define MY_CXT_CLONE \
 135     dMY_CXT_SV;                                                      \
 136     my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \
 137     Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t); \
 138     sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
 139 # endif
 140 #else
 141 # define I_THREADSAFE 0
 142 # undef  dMY_CXT
 143 # define dMY_CXT      dNOOP
 144 # undef  MY_CXT
 145 # define MY_CXT       indirect_globaldata
 146 # undef  START_MY_CXT
 147 # define START_MY_CXT static my_cxt_t MY_CXT;
 148 # undef  MY_CXT_INIT
 149 # define MY_CXT_INIT  NOOP
 150 # undef  MY_CXT_CLONE
 151 # define MY_CXT_CLONE NOOP
 152 #endif
 153
 154 #if I_THREADSAFE
 155 /* We must use preexistent global mutexes or we will never be able to destroy
 156  * them. */
 157 # if I_HAS_PERL(5, 9, 3)
 158 #  define I_LOADED_LOCK   MUTEX_LOCK(&PL_my_ctx_mutex)
 159 #  define I_LOADED_UNLOCK MUTEX_UNLOCK(&PL_my_ctx_mutex)
 160 # else
 161 #  define I_LOADED_LOCK   OP_REFCNT_LOCK
 162 #  define I_LOADED_UNLOCK OP_REFCNT_UNLOCK
 163 # endif
 164 #else
 165 # define I_LOADED_LOCK   NOOP
 166 # define I_LOADED_UNLOCK NOOP
 167 #endif
 168
 169 #if defined(OP_CHECK_MUTEX_LOCK) && defined(OP_CHECK_MUTEX_UNLOCK)
 170 # define I_CHECK_LOCK   OP_CHECK_MUTEX_LOCK
 171 # define I_CHECK_UNLOCK OP_CHECK_MUTEX_UNLOCK
 172 #elif I_HAS_PERL(5, 9, 3)
 173 # define I_CHECK_LOCK   OP_REFCNT_LOCK
 174 # define I_CHECK_UNLOCK OP_REFCNT_UNLOCK
 175 #else
 176 /* Before perl 5.9.3, indirect_ck_*() calls are already protected by the
 177  * I_LOADED mutex, which falls back to the OP_REFCNT mutex. Make sure we don't
 178  * lock it twice. */
 179 # define I_CHECK_LOCK   NOOP
 180 # define I_CHECK_UNLOCK NOOP
 181 #endif
 182
 183 typedef OP *(*indirect_ck_t)(pTHX_ OP *);
 184
 185 #ifdef wrap_op_checker
 186
 187 # define indirect_ck_replace(T, NC, OCP) wrap_op_checker((T), (NC), (OCP))
 188
 189 #else
 190
 191 static void indirect_ck_replace(pTHX_ OPCODE type, indirect_ck_t new_ck, indirect_ck_t *old_ck_p) {
 192 #define indirect_ck_replace(T, NC, OCP) indirect_ck_replace(aTHX_ (T), (NC), (OCP))
 193  I_CHECK_LOCK;
 194  if (!*old_ck_p) {
 195   *old_ck_p      = PL_check[type];
 196   PL_check[type] = new_ck;
 197  }
 198  I_CHECK_UNLOCK;
 199 }
 200
 201 #endif
 202
 203 static void indirect_ck_restore(pTHX_ OPCODE type, indirect_ck_t *old_ck_p) {
 204 #define indirect_ck_restore(T, OCP) indirect_ck_restore(aTHX_ (T), (OCP))
 205  I_CHECK_LOCK;
 206  if (*old_ck_p) {
 207   PL_check[type] = *old_ck_p;
 208   *old_ck_p      = 0;
 209  }
 210  I_CHECK_UNLOCK;
 211 }
 212
 213 /* --- Helpers ------------------------------------------------------------- */
 214
 215 /* ... Check if the module is loaded ....................................... */
 216
 217 static I32 indirect_loaded = 0;
 218
 219 #if I_THREADSAFE
 220
 221 #define PTABLE_NAME        ptable_loaded
 222 #define PTABLE_VAL_FREE(V) NOOP
 223
 224 #include "ptable.h"
 225
 226 #define ptable_loaded_store(T, K, V) ptable_loaded_store(aPTBLMS_ (T), (K), (V))
 227 #define ptable_loaded_delete(T, K)   ptable_loaded_delete(aPTBLMS_ (T), (K))
 228 #define ptable_loaded_free(T)        ptable_loaded_free(aPTBLMS_ (T))
 229
 230 static ptable *indirect_loaded_cxts = NULL;
 231
 232 static int indirect_is_loaded(pTHX_ void *cxt) {
 233 #define indirect_is_loaded(C) indirect_is_loaded(aTHX_ (C))
 234  int res = 0;
 235
 236  I_LOADED_LOCK;
 237  if (indirect_loaded_cxts && ptable_fetch(indirect_loaded_cxts, cxt))
 238   res = 1;
 239  I_LOADED_UNLOCK;
 240
 241  return res;
 242 }
 243
 244 static int indirect_set_loaded_locked(pTHX_ void *cxt) {
 245 #define indirect_set_loaded_locked(C) indirect_set_loaded_locked(aTHX_ (C))
 246  int global_setup = 0;
 247
 248  if (indirect_loaded <= 0) {
 249   assert(indirect_loaded == 0);
 250   assert(!indirect_loaded_cxts);
 251   indirect_loaded_cxts = ptable_new();
 252   global_setup         = 1;
 253  }
 254  ++indirect_loaded;
 255  assert(indirect_loaded_cxts);
 256  ptable_loaded_store(indirect_loaded_cxts, cxt, cxt);
 257
 258  return global_setup;
 259 }
 260
 261 static int indirect_clear_loaded_locked(pTHX_ void *cxt) {
 262 #define indirect_clear_loaded_locked(C) indirect_clear_loaded_locked(aTHX_ (C))
 263  int global_teardown = 0;
 264
 265  if (indirect_loaded > 1) {
 266   assert(indirect_loaded_cxts);
 267   ptable_loaded_delete(indirect_loaded_cxts, cxt);
 268   --indirect_loaded;
 269  } else if (indirect_loaded_cxts) {
 270   assert(indirect_loaded == 1);
 271   ptable_loaded_free(indirect_loaded_cxts);
 272   indirect_loaded_cxts = NULL;
 273   indirect_loaded      = 0;
 274   global_teardown      = 1;
 275  }
 276
 277  return global_teardown;
 278 }
 279
 280 #else
 281
 282 #define indirect_is_loaded(C)           (indirect_loaded > 0)
 283 #define indirect_set_loaded_locked(C)   ((indirect_loaded++ <= 0) ? 1 : 0)
 284 #define indirect_clear_loaded_locked(C) ((--indirect_loaded <= 0) ? 1 : 0)
 285
 286 #endif
 287
 288 /* ... Thread-safe hints ................................................... */
 289
 290 #if I_WORKAROUND_REQUIRE_PROPAGATION
 291
 292 typedef struct {
 293  SV *code;
 294  IV  require_tag;
 295 } indirect_hint_t;
 296
 297 #define I_HINT_STRUCT 1
 298
 299 #define I_HINT_CODE(H) ((H)->code)
 300
 301 #define I_HINT_FREE(H) {   \
 302  indirect_hint_t *h = (H); \
 303  SvREFCNT_dec(h->code);    \
 304  PerlMemShared_free(h);    \
 305 }
 306
 307 #else  /*  I_WORKAROUND_REQUIRE_PROPAGATION */
 308
 309 typedef SV indirect_hint_t;
 310
 311 #define I_HINT_STRUCT 0
 312
 313 #define I_HINT_CODE(H) (H)
 314
 315 #define I_HINT_FREE(H) SvREFCNT_dec(H);
 316
 317 #endif /* !I_WORKAROUND_REQUIRE_PROPAGATION */
 318
 319 #if I_THREADSAFE
 320
 321 #define PTABLE_NAME        ptable_hints
 322 #define PTABLE_VAL_FREE(V) I_HINT_FREE(V)
 323
 324 #define pPTBL  pTHX
 325 #define pPTBL_ pTHX_
 326 #define aPTBL  aTHX
 327 #define aPTBL_ aTHX_
 328
 329 #include "ptable.h"
 330
 331 #define ptable_hints_store(T, K, V) ptable_hints_store(aTHX_ (T), (K), (V))
 332 #define ptable_hints_free(T)        ptable_hints_free(aTHX_ (T))
 333
 334 #endif /* I_THREADSAFE */
 335
 336 /* Define the op->str ptable here because we need to be able to clean it during
 337  * thread cleanup. */
 338
 339 typedef struct {
 340  char   *buf;
 341  STRLEN  pos;
 342  STRLEN  size;
 343  STRLEN  len;
 344  line_t  line;
 345 } indirect_op_info_t;
 346
 347 #define PTABLE_NAME        ptable
 348 #define PTABLE_VAL_FREE(V) if (V) { Safefree(((indirect_op_info_t *) (V))->buf); Safefree(V); }
 349
 350 #define pPTBL  pTHX
 351 #define pPTBL_ pTHX_
 352 #define aPTBL  aTHX
 353 #define aPTBL_ aTHX_
 354
 355 #include "ptable.h"
 356
 357 #define ptable_store(T, K, V) ptable_store(aTHX_ (T), (K), (V))
 358 #define ptable_delete(T, K)   ptable_delete(aTHX_ (T), (K))
 359 #define ptable_clear(T)       ptable_clear(aTHX_ (T))
 360 #define ptable_free(T)        ptable_free(aTHX_ (T))
 361
 362 #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
 363
 364 typedef struct {
 365 #if I_THREADSAFE
 366  ptable *tbl; /* It really is a ptable_hints */
 367  tTHX    owner;
 368 #endif
 369  ptable *map;
 370  SV     *global_code;
 371 } my_cxt_t;
 372
 373 START_MY_CXT
 374
 375 #if I_THREADSAFE
 376
 377 typedef struct {
 378  ptable *tbl;
 379 #if I_HAS_PERL(5, 13, 2)
 380  CLONE_PARAMS *params;
 381 #else
 382  CLONE_PARAMS params;
 383 #endif
 384 } indirect_ptable_clone_ud;
 385
 386 #if I_HAS_PERL(5, 13, 2)
 387 # define indirect_ptable_clone_ud_init(U, T, O) \
 388    (U).tbl    = (T); \
 389    (U).params = Perl_clone_params_new((O), aTHX)
 390 # define indirect_ptable_clone_ud_deinit(U) Perl_clone_params_del((U).params)
 391 # define indirect_dup_inc(S, U)             SvREFCNT_inc(sv_dup((S), (U)->params))
 392 #else
 393 # define indirect_ptable_clone_ud_init(U, T, O) \
 394    (U).tbl               = (T);     \
 395    (U).params.stashes    = newAV(); \
 396    (U).params.flags      = 0;       \
 397    (U).params.proto_perl = (O)
 398 # define indirect_ptable_clone_ud_deinit(U) SvREFCNT_dec((U).params.stashes)
 399 # define indirect_dup_inc(S, U)             SvREFCNT_inc(sv_dup((S), &((U)->params)))
 400 #endif
 401
 402 static void indirect_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) {
 403  indirect_ptable_clone_ud *ud = ud_;
 404  indirect_hint_t          *h1 = ent->val;
 405  indirect_hint_t          *h2;
 406
 407 #if I_HINT_STRUCT
 408
 409  h2              = PerlMemShared_malloc(sizeof *h2);
 410  h2->code        = indirect_dup_inc(h1->code, ud);
 411 #if I_WORKAROUND_REQUIRE_PROPAGATION
 412  h2->require_tag = PTR2IV(indirect_dup_inc(INT2PTR(SV *, h1->require_tag), ud));
 413 #endif
 414
 415 #else  /*  I_HINT_STRUCT */
 416
 417  h2 = indirect_dup_inc(h1, ud);
 418
 419 #endif /* !I_HINT_STRUCT */
 420
 421  ptable_hints_store(ud->tbl, ent->key, h2);
 422 }
 423
 424 #endif /* I_THREADSAFE */
 425
 426 #if I_WORKAROUND_REQUIRE_PROPAGATION
 427
 428 static IV indirect_require_tag(pTHX) {
 429 #define indirect_require_tag() indirect_require_tag(aTHX)
 430  const CV *cv, *outside;
 431
 432  cv = PL_compcv;
 433
 434  if (!cv) {
 435   /* If for some reason the pragma is operational at run-time, try to discover
 436    * the current cv in use. */
 437   const PERL_SI *si;
 438
 439   for (si = PL_curstackinfo; si; si = si->si_prev) {
 440    I32 cxix;
 441
 442    for (cxix = si->si_cxix; cxix >= 0; --cxix) {
 443     const PERL_CONTEXT *cx = si->si_cxstack + cxix;
 444
 445     switch (CxTYPE(cx)) {
 446      case CXt_SUB:
 447      case CXt_FORMAT:
 448       /* The propagation workaround is only needed up to 5.10.0 and at that
 449        * time format and sub contexts were still identical. And even later the
 450        * cv members offsets should have been kept the same. */
 451       cv = cx->blk_sub.cv;
 452       goto get_enclosing_cv;
 453      case CXt_EVAL:
 454       cv = cx->blk_eval.cv;
 455       goto get_enclosing_cv;
 456      default:
 457       break;
 458     }
 459    }
 460   }
 461
 462   cv = PL_main_cv;
 463  }
 464
 465 get_enclosing_cv:
 466  for (outside = CvOUTSIDE(cv); outside; outside = CvOUTSIDE(cv))
 467   cv = outside;
 468
 469  return PTR2IV(cv);
 470 }
 471
 472 #endif /* I_WORKAROUND_REQUIRE_PROPAGATION */
 473
 474 static SV *indirect_tag(pTHX_ SV *value) {
 475 #define indirect_tag(V) indirect_tag(aTHX_ (V))
 476  indirect_hint_t *h;
 477  SV              *code = NULL;
 478 #if I_THREADSAFE
 479  dMY_CXT;
 480
 481  if (!MY_CXT.tbl)
 482   return newSViv(0);
 483 #endif /* I_THREADSAFE */
 484
 485  if (SvROK(value)) {
 486   value = SvRV(value);
 487   if (SvTYPE(value) >= SVt_PVCV) {
 488    code = value;
 489    SvREFCNT_inc_simple_void_NN(code);
 490   }
 491  }
 492
 493 #if I_HINT_STRUCT
 494  h = PerlMemShared_malloc(sizeof *h);
 495  h->code        = code;
 496 # if I_WORKAROUND_REQUIRE_PROPAGATION
 497  h->require_tag = indirect_require_tag();
 498 # endif /* I_WORKAROUND_REQUIRE_PROPAGATION */
 499 #else  /*  I_HINT_STRUCT */
 500  h = code;
 501 #endif /* !I_HINT_STRUCT */
 502
 503 #if I_THREADSAFE
 504  /* We only need for the key to be an unique tag for looking up the value later
 505   * Allocated memory provides convenient unique identifiers, so that's why we
 506   * use the hint as the key itself. */
 507  ptable_hints_store(MY_CXT.tbl, h, h);
 508 #endif /* I_THREADSAFE */
 509
 510  return newSViv(PTR2IV(h));
 511 }
 512
 513 static SV *indirect_detag(pTHX_ const SV *hint) {
 514 #define indirect_detag(H) indirect_detag(aTHX_ (H))
 515  indirect_hint_t *h;
 516 #if I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION
 517  dMY_CXT;
 518 #endif
 519
 520 #if I_THREADSAFE
 521  if (!MY_CXT.tbl)
 522   return NULL;
 523 #endif /* I_THREADSAFE */
 524
 525  h = INT2PTR(indirect_hint_t *, SvIVX(hint));
 526 #if I_THREADSAFE
 527  h = ptable_fetch(MY_CXT.tbl, h);
 528 #endif /* I_THREADSAFE */
 529
 530 #if I_WORKAROUND_REQUIRE_PROPAGATION
 531  if (indirect_require_tag() != h->require_tag)
 532   return MY_CXT.global_code;
 533 #endif /* I_WORKAROUND_REQUIRE_PROPAGATION */
 534
 535  return I_HINT_CODE(h);
 536 }
 537
 538 static VOL U32 indirect_hash = 0;
 539
 540 static SV *indirect_hint(pTHX) {
 541 #define indirect_hint() indirect_hint(aTHX)
 542  SV *hint = NULL;
 543
 544  if (IN_PERL_RUNTIME)
 545   return NULL;
 546
 547 #if I_HAS_PERL(5, 10, 0) || defined(PL_parser)
 548  if (!PL_parser)
 549   return NULL;
 550 #endif
 551
 552 #ifdef cop_hints_fetch_pvn
 553  hint = cop_hints_fetch_pvn(PL_curcop, __PACKAGE__, __PACKAGE_LEN__,
 554                                                               indirect_hash, 0);
 555 #elif I_HAS_PERL(5, 9, 5)
 556  hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
 557                                        NULL,
 558                                        __PACKAGE__, __PACKAGE_LEN__,
 559                                        0,
 560                                        indirect_hash);
 561 #else
 562  {
 563   SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, 0);
 564   if (val)
 565    hint = *val;
 566  }
 567 #endif
 568
 569  if (hint && SvIOK(hint)) {
 570   return indirect_detag(hint);
 571  } else {
 572   dMY_CXT;
 573   if (indirect_is_loaded(&MY_CXT))
 574    return MY_CXT.global_code;
 575   else
 576    return NULL;
 577  }
 578 }
 579
 580 /* ... op -> source position ............................................... */
 581
 582 static void indirect_map_store(pTHX_ const OP *o, STRLEN pos, SV *sv, line_t line) {
 583 #define indirect_map_store(O, P, N, L) indirect_map_store(aTHX_ (O), (P), (N), (L))
 584  indirect_op_info_t *oi;
 585  const char *s;
 586  STRLEN len;
 587  dMY_CXT;
 588
 589  /* No need to check for MY_CXT.map != NULL because this code path is always
 590   * guarded by indirect_hint(). */
 591
 592  if (!(oi = ptable_fetch(MY_CXT.map, o))) {
 593   Newx(oi, 1, indirect_op_info_t);
 594   ptable_store(MY_CXT.map, o, oi);
 595   oi->buf  = NULL;
 596   oi->size = 0;
 597  }
 598
 599  if (sv) {
 600   s = SvPV_const(sv, len);
 601  } else {
 602   s   = "{";
 603   len = 1;
 604  }
 605
 606  if (len > oi->size) {
 607   Safefree(oi->buf);
 608   Newx(oi->buf, len, char);
 609   oi->size = len;
 610  }
 611  Copy(s, oi->buf, len, char);
 612
 613  oi->len  = len;
 614  oi->pos  = pos;
 615  oi->line = line;
 616 }
 617
 618 static const indirect_op_info_t *indirect_map_fetch(pTHX_ const OP *o) {
 619 #define indirect_map_fetch(O) indirect_map_fetch(aTHX_ (O))
 620  dMY_CXT;
 621
 622  /* No need to check for MY_CXT.map != NULL because this code path is always
 623   * guarded by indirect_hint(). */
 624
 625  return ptable_fetch(MY_CXT.map, o);
 626 }
 627
 628 static void indirect_map_delete(pTHX_ const OP *o) {
 629 #define indirect_map_delete(O) indirect_map_delete(aTHX_ (O))
 630  dMY_CXT;
 631
 632  if (indirect_is_loaded(&MY_CXT) && MY_CXT.map)
 633   ptable_delete(MY_CXT.map, o);
 634 }
 635
 636 /* --- Check functions ----------------------------------------------------- */
 637
 638 static int indirect_find(pTHX_ SV *name_sv, const char *line_bufptr, STRLEN *name_pos) {
 639 #define indirect_find(NSV, LBP, NP) indirect_find(aTHX_ (NSV), (LBP), (NP))
 640  STRLEN      name_len, line_len;
 641  const char *name, *name_end;
 642  const char *line, *line_end;
 643  const char *p;
 644
 645  line     = SvPV_const(PL_linestr, line_len);
 646  line_end = line + line_len;
 647
 648  name = SvPV_const(name_sv, name_len);
 649  if (name_len >= 1 && *name == '$') {
 650   ++name;
 651   --name_len;
 652   while (line_bufptr < line_end && *line_bufptr != '$')
 653    ++line_bufptr;
 654   if (line_bufptr >= line_end)
 655    return 0;
 656  }
 657  name_end = name + name_len;
 658
 659  p = line_bufptr;
 660  while (1) {
 661   p = ninstr(p, line_end, name, name_end);
 662   if (!p)
 663    return 0;
 664   if (!isALNUM(p[name_len]))
 665    break;
 666   /* p points to a word that has name as prefix, skip the rest of the word */
 667   p += name_len + 1;
 668   while (isALNUM(*p))
 669    ++p;
 670  }
 671
 672  *name_pos = p - line;
 673
 674  return 1;
 675 }
 676
 677 /* ... ck_const ............................................................ */
 678
 679 static OP *(*indirect_old_ck_const)(pTHX_ OP *) = 0;
 680
 681 static OP *indirect_ck_const(pTHX_ OP *o) {
 682  o = indirect_old_ck_const(aTHX_ o);
 683
 684  if (indirect_hint()) {
 685   SV *sv = cSVOPo_sv;
 686
 687   if (SvPOK(sv) && (SvTYPE(sv) >= SVt_PV)) {
 688    STRLEN pos;
 689
 690    if (indirect_find(sv, PL_oldbufptr, &pos)) {
 691     STRLEN len;
 692
 693     /* If the constant is equal to the current package name, try to look for
 694      * a "__PACKAGE__" coming before what we got. We only need to check this
 695      * when we already had a match because __PACKAGE__ can only appear in
 696      * direct method calls ("new __PACKAGE__" is a syntax error). */
 697     len = SvCUR(sv);
 698     if (PL_curstash
 699         && len == (STRLEN) HvNAMELEN_get(PL_curstash)
 700         && memcmp(SvPVX(sv), HvNAME_get(PL_curstash), len) == 0) {
 701      STRLEN pos_pkg;
 702      SV    *pkg = sv_newmortal();
 703      sv_setpvn(pkg, "__PACKAGE__", sizeof("__PACKAGE__")-1);
 704
 705      if (indirect_find(pkg, PL_oldbufptr, &pos_pkg) && pos_pkg < pos) {
 706       sv  = pkg;
 707       pos = pos_pkg;
 708      }
 709     }
 710
 711     indirect_map_store(o, pos, sv, CopLINE(&PL_compiling));
 712     return o;
 713    }
 714   }
 715  }
 716
 717  indirect_map_delete(o);
 718  return o;
 719 }
 720
 721 /* ... ck_rv2sv ............................................................ */
 722
 723 static OP *(*indirect_old_ck_rv2sv)(pTHX_ OP *) = 0;
 724
 725 static OP *indirect_ck_rv2sv(pTHX_ OP *o) {
 726  if (indirect_hint()) {
 727   OP *op = cUNOPo->op_first;
 728   SV *sv;
 729   const char *name = NULL;
 730   STRLEN pos, len;
 731   OPCODE type = (OPCODE) op->op_type;
 732
 733   switch (type) {
 734    case OP_GV:
 735    case OP_GVSV: {
 736     GV *gv = cGVOPx_gv(op);
 737     name = GvNAME(gv);
 738     len  = GvNAMELEN(gv);
 739     break;
 740    }
 741    default:
 742     if ((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP) {
 743      SV *nsv = cSVOPx_sv(op);
 744      if (SvPOK(nsv) && (SvTYPE(nsv) >= SVt_PV))
 745       name = SvPV_const(nsv, len);
 746     }
 747   }
 748   if (!name)
 749    goto done;
 750
 751   sv = sv_2mortal(newSVpvn("$", 1));
 752   sv_catpvn_nomg(sv, name, len);
 753   if (!indirect_find(sv, PL_oldbufptr, &pos)) {
 754    /* If it failed, retry without the current stash */
 755    const char *stash = HvNAME_get(PL_curstash);
 756    STRLEN stashlen = HvNAMELEN_get(PL_curstash);
 757
 758    if ((len < stashlen + 2) || strnNE(name, stash, stashlen)
 759        || name[stashlen] != ':' || name[stashlen+1] != ':') {
 760     /* Failed again ? Try to remove main */
 761     stash = "main";
 762     stashlen = 4;
 763     if ((len < stashlen + 2) || strnNE(name, stash, stashlen)
 764         || name[stashlen] != ':' || name[stashlen+1] != ':')
 765      goto done;
 766    }
 767
 768    sv_setpvn(sv, "$", 1);
 769    stashlen += 2;
 770    sv_catpvn_nomg(sv, name + stashlen, len - stashlen);
 771    if (!indirect_find(sv, PL_oldbufptr, &pos))
 772     goto done;
 773   }
 774
 775   o = indirect_old_ck_rv2sv(aTHX_ o);
 776
 777   indirect_map_store(o, pos, sv, CopLINE(&PL_compiling));
 778   return o;
 779  }
 780
 781 done:
 782  o = indirect_old_ck_rv2sv(aTHX_ o);
 783
 784  indirect_map_delete(o);
 785  return o;
 786 }
 787
 788 /* ... ck_padany ........................................................... */
 789
 790 static OP *(*indirect_old_ck_padany)(pTHX_ OP *) = 0;
 791
 792 static OP *indirect_ck_padany(pTHX_ OP *o) {
 793  o = indirect_old_ck_padany(aTHX_ o);
 794
 795  if (indirect_hint()) {
 796   SV *sv;
 797   const char *s = PL_oldbufptr, *t = PL_bufptr - 1;
 798
 799   while (s < t && isSPACE(*s)) ++s;
 800   if (*s == '$' && ++s <= t) {
 801    while (s < t && isSPACE(*s)) ++s;
 802    while (s < t && isSPACE(*t)) --t;
 803    sv = sv_2mortal(newSVpvn("$", 1));
 804    sv_catpvn_nomg(sv, s, t - s + 1);
 805    indirect_map_store(o, s - SvPVX_const(PL_linestr),
 806                          sv, CopLINE(&PL_compiling));
 807    return o;
 808   }
 809  }
 810
 811  indirect_map_delete(o);
 812  return o;
 813 }
 814
 815 /* ... ck_scope ............................................................ */
 816
 817 static OP *(*indirect_old_ck_scope)  (pTHX_ OP *) = 0;
 818 static OP *(*indirect_old_ck_lineseq)(pTHX_ OP *) = 0;
 819
 820 static OP *indirect_ck_scope(pTHX_ OP *o) {
 821  OP *(*old_ck)(pTHX_ OP *) = 0;
 822
 823  switch (o->op_type) {
 824   case OP_SCOPE:   old_ck = indirect_old_ck_scope;   break;
 825   case OP_LINESEQ: old_ck = indirect_old_ck_lineseq; break;
 826  }
 827  o = old_ck(aTHX_ o);
 828
 829  if (indirect_hint()) {
 830   indirect_map_store(o, PL_oldbufptr - SvPVX_const(PL_linestr),
 831                         NULL, CopLINE(&PL_compiling));
 832   return o;
 833  }
 834
 835  indirect_map_delete(o);
 836  return o;
 837 }
 838
 839 /* We don't need to clean the map entries for leave ops because they can only
 840  * be created by mutating from a lineseq. */
 841
 842 /* ... ck_method ........................................................... */
 843
 844 static OP *(*indirect_old_ck_method)(pTHX_ OP *) = 0;
 845
 846 static OP *indirect_ck_method(pTHX_ OP *o) {
 847  if (indirect_hint()) {
 848   OP *op = cUNOPo->op_first;
 849
 850   /* Indirect method call is only possible when the method is a bareword, so
 851    * don't trip up on $obj->$meth. */
 852   if (op && op->op_type == OP_CONST) {
 853    const indirect_op_info_t *oi = indirect_map_fetch(op);
 854    STRLEN pos;
 855    line_t line;
 856    SV *sv;
 857
 858    if (!oi)
 859     goto done;
 860
 861    sv   = sv_2mortal(newSVpvn(oi->buf, oi->len));
 862    pos  = oi->pos;
 863    /* Keep the old line so that we really point to the first line of the
 864     * expression. */
 865    line = oi->line;
 866
 867    o = indirect_old_ck_method(aTHX_ o);
 868    /* o may now be a method_named */
 869
 870    indirect_map_store(o, pos, sv, line);
 871    return o;
 872   }
 873  }
 874
 875 done:
 876  o = indirect_old_ck_method(aTHX_ o);
 877
 878  indirect_map_delete(o);
 879  return o;
 880 }
 881
 882 /* ... ck_method_named ..................................................... */
 883
 884 /* "use foo/no foo" compiles its call to import/unimport directly to a
 885  * method_named op. */
 886
 887 static OP *(*indirect_old_ck_method_named)(pTHX_ OP *) = 0;
 888
 889 static OP *indirect_ck_method_named(pTHX_ OP *o) {
 890  if (indirect_hint()) {
 891   STRLEN pos;
 892   line_t line;
 893   SV *sv;
 894
 895   sv = cSVOPo_sv;
 896   if (!SvPOK(sv) || (SvTYPE(sv) < SVt_PV))
 897    goto done;
 898   sv = sv_mortalcopy(sv);
 899
 900   if (!indirect_find(sv, PL_oldbufptr, &pos))
 901    goto done;
 902   line = CopLINE(&PL_compiling);
 903
 904   o = indirect_old_ck_method_named(aTHX_ o);
 905
 906   indirect_map_store(o, pos, sv, line);
 907   return o;
 908  }
 909
 910 done:
 911  o = indirect_old_ck_method_named(aTHX_ o);
 912
 913  indirect_map_delete(o);
 914  return o;
 915 }
 916
 917 /* ... ck_entersub ......................................................... */
 918
 919 static OP *(*indirect_old_ck_entersub)(pTHX_ OP *) = 0;
 920
 921 static OP *indirect_ck_entersub(pTHX_ OP *o) {
 922  SV *code = indirect_hint();
 923
 924  o = indirect_old_ck_entersub(aTHX_ o);
 925
 926  if (code) {
 927   const indirect_op_info_t *moi, *ooi;
 928   OP     *mop, *oop;
 929   LISTOP *lop;
 930
 931   oop = o;
 932   do {
 933    lop = (LISTOP *) oop;
 934    if (!(lop->op_flags & OPf_KIDS))
 935     goto done;
 936    oop = lop->op_first;
 937   } while (oop->op_type != OP_PUSHMARK);
 938   oop = OpSIBLING(oop);
 939   mop = lop->op_last;
 940
 941   if (!oop)
 942    goto done;
 943
 944   switch (oop->op_type) {
 945    case OP_CONST:
 946    case OP_RV2SV:
 947    case OP_PADSV:
 948    case OP_SCOPE:
 949    case OP_LEAVE:
 950     break;
 951    default:
 952     goto done;
 953   }
 954
 955   if (mop->op_type == OP_METHOD)
 956    mop = cUNOPx(mop)->op_first;
 957   else if (mop->op_type != OP_METHOD_NAMED)
 958    goto done;
 959
 960   moi = indirect_map_fetch(mop);
 961   if (!moi)
 962    goto done;
 963
 964   ooi = indirect_map_fetch(oop);
 965   if (!ooi)
 966    goto done;
 967
 968   /* When positions are identical, the method and the object must have the
 969    * same name. But it also means that it is an indirect call, as "foo->foo"
 970    * results in different positions. */
 971   if (   moi->line < ooi->line
 972       || (moi->line == ooi->line && moi->pos <= ooi->pos)) {
 973    SV *file;
 974    dSP;
 975
 976    ENTER;
 977    SAVETMPS;
 978
 979 #ifdef USE_ITHREADS
 980    file = sv_2mortal(newSVpv(CopFILE(&PL_compiling), 0));
 981 #else
 982    file = sv_mortalcopy(CopFILESV(&PL_compiling));
 983 #endif
 984
 985    PUSHMARK(SP);
 986    EXTEND(SP, 4);
 987    mPUSHp(ooi->buf, ooi->len);
 988    mPUSHp(moi->buf, moi->len);
 989    PUSHs(file);
 990    mPUSHu(moi->line);
 991    PUTBACK;
 992
 993    call_sv(code, G_VOID);
 994
 995    PUTBACK;
 996
 997    FREETMPS;
 998    LEAVE;
 999   }
1000  }
1001
1002 done:
1003  return o;
1004 }
1005
1006 /* --- Module setup/teardown ----------------------------------------------- */
1007
1008 static void indirect_teardown(pTHX_ void *interp) {
1009  dMY_CXT;
1010
1011  I_LOADED_LOCK;
1012
1013  if (indirect_clear_loaded_locked(&MY_CXT)) {
1014   indirect_ck_restore(OP_CONST,   &indirect_old_ck_const);
1015   indirect_ck_restore(OP_RV2SV,   &indirect_old_ck_rv2sv);
1016   indirect_ck_restore(OP_PADANY,  &indirect_old_ck_padany);
1017   indirect_ck_restore(OP_SCOPE,   &indirect_old_ck_scope);
1018   indirect_ck_restore(OP_LINESEQ, &indirect_old_ck_lineseq);
1019
1020   indirect_ck_restore(OP_METHOD,       &indirect_old_ck_method);
1021   indirect_ck_restore(OP_METHOD_NAMED, &indirect_old_ck_method_named);
1022   indirect_ck_restore(OP_ENTERSUB,     &indirect_old_ck_entersub);
1023  }
1024
1025  I_LOADED_UNLOCK;
1026
1027  SvREFCNT_dec(MY_CXT.global_code);
1028  MY_CXT.global_code = NULL;
1029
1030  ptable_free(MY_CXT.map);
1031  MY_CXT.map = NULL;
1032
1033 #if I_THREADSAFE
1034  ptable_hints_free(MY_CXT.tbl);
1035  MY_CXT.tbl = NULL;
1036 #endif
1037
1038  return;
1039 }
1040
1041 static void indirect_setup(pTHX) {
1042 #define indirect_setup() indirect_setup(aTHX)
1043  MY_CXT_INIT; /* Takes/release PL_my_ctx_mutex */
1044
1045  I_LOADED_LOCK;
1046
1047  if (indirect_set_loaded_locked(&MY_CXT)) {
1048   PERL_HASH(indirect_hash, __PACKAGE__, __PACKAGE_LEN__);
1049
1050   indirect_ck_replace(OP_CONST,   indirect_ck_const,  &indirect_old_ck_const);
1051   indirect_ck_replace(OP_RV2SV,   indirect_ck_rv2sv,  &indirect_old_ck_rv2sv);
1052   indirect_ck_replace(OP_PADANY,  indirect_ck_padany, &indirect_old_ck_padany);
1053   indirect_ck_replace(OP_SCOPE,   indirect_ck_scope,  &indirect_old_ck_scope);
1054   indirect_ck_replace(OP_LINESEQ, indirect_ck_scope,  &indirect_old_ck_lineseq);
1055
1056   indirect_ck_replace(OP_METHOD,       indirect_ck_method,
1057                                        &indirect_old_ck_method);
1058   indirect_ck_replace(OP_METHOD_NAMED, indirect_ck_method_named,
1059                                        &indirect_old_ck_method_named);
1060   indirect_ck_replace(OP_ENTERSUB,     indirect_ck_entersub,
1061                                        &indirect_old_ck_entersub);
1062  }
1063
1064  I_LOADED_UNLOCK;
1065
1066  {
1067   HV *stash;
1068
1069   stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1);
1070   newCONSTSUB(stash, "I_THREADSAFE", newSVuv(I_THREADSAFE));
1071   newCONSTSUB(stash, "I_FORKSAFE",   newSVuv(I_FORKSAFE));
1072
1073 #if I_THREADSAFE
1074   MY_CXT.tbl         = ptable_new();
1075   MY_CXT.owner       = aTHX;
1076 #endif
1077
1078   MY_CXT.map         = ptable_new();
1079   MY_CXT.global_code = NULL;
1080  }
1081
1082  call_atexit(indirect_teardown, NULL);
1083
1084  return;
1085 }
1086
1087 /* --- XS ------------------------------------------------------------------ */
1088
1089 MODULE = indirect      PACKAGE = indirect
1090
1091 PROTOTYPES: ENABLE
1092
1093 BOOT:
1094 {
1095  indirect_setup();
1096 }
1097
1098 #if I_THREADSAFE
1099
1100 void
1101 CLONE(...)
1102 PROTOTYPE: DISABLE
1103 PREINIT:
1104  ptable *t;
1105  SV     *global_code_dup;
1106 PPCODE:
1107  {
1108   indirect_ptable_clone_ud ud;
1109   dMY_CXT;
1110   t = ptable_new();
1111   indirect_ptable_clone_ud_init(ud, t, MY_CXT.owner);
1112   ptable_walk(MY_CXT.tbl, indirect_ptable_clone, &ud);
1113   global_code_dup = indirect_dup_inc(MY_CXT.global_code, &ud);
1114   indirect_ptable_clone_ud_deinit(ud);
1115  }
1116  {
1117   MY_CXT_CLONE;
1118   MY_CXT.map         = ptable_new();
1119   MY_CXT.tbl         = t;
1120   MY_CXT.owner       = aTHX;
1121   MY_CXT.global_code = global_code_dup;
1122   {
1123    int global_setup;
1124    I_LOADED_LOCK;
1125    global_setup = indirect_set_loaded_locked(&MY_CXT);
1126    assert(!global_setup);
1127    I_LOADED_UNLOCK;
1128   }
1129  }
1130  XSRETURN(0);
1131
1132 #endif /* I_THREADSAFE */
1133
1134 SV *
1135 _tag(SV *value)
1136 PROTOTYPE: $
1137 CODE:
1138  RETVAL = indirect_tag(value);
1139 OUTPUT:
1140  RETVAL
1141
1142 void
1143 _global(SV *code)
1144 PROTOTYPE: $
1145 PPCODE:
1146  if (!SvOK(code))
1147   code = NULL;
1148  else if (SvROK(code))
1149   code = SvRV(code);
1150  {
1151   dMY_CXT;
1152   SvREFCNT_dec(MY_CXT.global_code);
1153   MY_CXT.global_code = SvREFCNT_inc(code);
1154  }
1155  XSRETURN(0);