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 /* --- XS helpers ---------------------------------------------------------- */
  10
  11 #define XSH_PACKAGE "indirect"
  12
  13 #include "xsh/caps.h"
  14 #include "xsh/util.h"
  15 #include "xsh/mem.h"
  16 #include "xsh/ops.h"
  17
  18 /* ... op => source position map ........................................... */
  19
  20 typedef struct {
  21  char   *buf;
  22  STRLEN  pos;
  23  STRLEN  size;
  24  STRLEN  len;
  25  line_t  line;
  26 } indirect_op_info_t;
  27
  28 #define PTABLE_NAME        ptable
  29 #define PTABLE_VAL_FREE(V) if (V) { indirect_op_info_t *oi = (V); XSH_LOCAL_FREE(oi->buf, oi->size, char); XSH_LOCAL_FREE(oi, 1, indirect_op_info_t); }
  30 #define PTABLE_NEED_DELETE 1
  31 #define PTABLE_NEED_WALK   0
  32
  33 #include "xsh/ptable.h"
  34
  35 /* XSH_LOCAL_FREE() always need aTHX */
  36 #define ptable_store(T, K, V) ptable_store(aTHX_ (T), (K), (V))
  37 #define ptable_delete(T, K)   ptable_delete(aTHX_ (T), (K))
  38 #define ptable_clear(T)       ptable_clear(aTHX_ (T))
  39 #define ptable_free(T)        ptable_free(aTHX_ (T))
  40
  41 /* ... Lexical hints ....................................................... */
  42
  43 #define XSH_HINTS_TYPE_SV 1
  44
  45 #include "xsh/hints.h"
  46
  47 /* ... Thread-local storage ................................................ */
  48
  49 typedef struct {
  50  ptable *map;
  51  SV     *global_code;
  52 } xsh_user_cxt_t;
  53
  54 #define XSH_THREADS_USER_CONTEXT            1
  55 #define XSH_THREADS_USER_CLONE_NEEDS_DUP    1
  56 #define XSH_THREADS_COMPILE_TIME_PROTECTION 1
  57
  58 #if XSH_THREADSAFE
  59
  60 static void xsh_user_clone(pTHX_ const xsh_user_cxt_t *old_cxt, xsh_user_cxt_t *new_cxt, CLONE_PARAMS *params) {
  61  new_cxt->map         = ptable_new(32);
  62  new_cxt->global_code = xsh_dup_inc(old_cxt->global_code, params);
  63
  64  return;
  65 }
  66
  67 #endif /* XSH_THREADSAFE */
  68
  69 #include "xsh/threads.h"
  70
  71 /* ... Lexical hints, continued ............................................ */
  72
  73 static SV *indirect_hint(pTHX) {
  74 #define indirect_hint() indirect_hint(aTHX)
  75  SV *hint;
  76
  77 #if XSH_HAS_PERL(5, 10, 0) || defined(PL_parser)
  78  if (!PL_parser)
  79   return NULL;
  80 #endif
  81
  82  hint = xsh_hints_fetch();
  83  if (hint && SvOK(hint)) {
  84   return xsh_hints_detag(hint);
  85  } else {
  86   dXSH_CXT;
  87   if (xsh_is_loaded(&XSH_CXT))
  88    return XSH_CXT.global_code;
  89   else
  90    return NULL;
  91  }
  92 }
  93
  94 /* --- Compatibility wrappers ---------------------------------------------- */
  95
  96 #ifndef SvPV_const
  97 # define SvPV_const SvPV
  98 #endif
  99
 100 #ifndef SvPV_nolen_const
 101 # define SvPV_nolen_const SvPV_nolen
 102 #endif
 103
 104 #ifndef SvPVX_const
 105 # define SvPVX_const SvPVX
 106 #endif
 107
 108 #ifndef SvREFCNT_inc_simple_void_NN
 109 # ifdef SvREFCNT_inc_simple_NN
 110 #  define SvREFCNT_inc_simple_void_NN SvREFCNT_inc_simple_NN
 111 # else
 112 #  define SvREFCNT_inc_simple_void_NN SvREFCNT_inc
 113 # endif
 114 #endif
 115
 116 #ifndef sv_catpvn_nomg
 117 # define sv_catpvn_nomg sv_catpvn
 118 #endif
 119
 120 #ifndef mPUSHp
 121 # define mPUSHp(P, L) PUSHs(sv_2mortal(newSVpvn((P), (L))))
 122 #endif
 123
 124 #ifndef mPUSHu
 125 # define mPUSHu(U) PUSHs(sv_2mortal(newSVuv(U)))
 126 #endif
 127
 128 #ifndef HvNAME_get
 129 # define HvNAME_get(H) HvNAME(H)
 130 #endif
 131
 132 #ifndef HvNAMELEN_get
 133 # define HvNAMELEN_get(H) strlen(HvNAME_get(H))
 134 #endif
 135
 136 #if XSH_HAS_PERL(5, 10, 0) || defined(PL_parser)
 137 # ifndef PL_linestr
 138 #  define PL_linestr PL_parser->linestr
 139 # endif
 140 # ifndef PL_bufptr
 141 #  define PL_bufptr PL_parser->bufptr
 142 # endif
 143 # ifndef PL_oldbufptr
 144 #  define PL_oldbufptr PL_parser->oldbufptr
 145 # endif
 146 # ifndef PL_lex_inwhat
 147 #  define PL_lex_inwhat PL_parser->lex_inwhat
 148 # endif
 149 #else
 150 # ifndef PL_linestr
 151 #  define PL_linestr PL_Ilinestr
 152 # endif
 153 # ifndef PL_bufptr
 154 #  define PL_bufptr PL_Ibufptr
 155 # endif
 156 # ifndef PL_oldbufptr
 157 #  define PL_oldbufptr PL_Ioldbufptr
 158 # endif
 159 # ifndef PL_lex_inwhat
 160 #  define PL_lex_inwhat PL_Ilex_inwhat
 161 # endif
 162 #endif
 163
 164 /* ... Safe version of call_sv() ........................................... */
 165
 166 static I32 indirect_call_sv(pTHX_ SV *sv, I32 flags) {
 167 #define indirect_call_sv(S, F) indirect_call_sv(aTHX_ (S), (F))
 168  I32          ret, cxix;
 169  PERL_CONTEXT saved_cx;
 170  SV          *saved_errsv = NULL;
 171
 172  if (SvTRUE(ERRSV)) {
 173   if (IN_PERL_COMPILETIME && PL_errors)
 174    sv_catsv(PL_errors, ERRSV);
 175   else
 176    saved_errsv = newSVsv(ERRSV);
 177   SvCUR_set(ERRSV, 0);
 178  }
 179
 180  cxix     = (cxstack_ix < cxstack_max) ? (cxstack_ix + 1) : Perl_cxinc(aTHX);
 181  /* The last popped context will be reused by call_sv(), but our callers may
 182   * still need its previous value. Back it up so that it isn't clobbered. */
 183  saved_cx = cxstack[cxix];
 184
 185  ret = call_sv(sv, flags | G_EVAL);
 186
 187  cxstack[cxix] = saved_cx;
 188
 189  if (SvTRUE(ERRSV)) {
 190   /* Discard the old ERRSV, and reuse the variable to temporarily store the
 191    * new one. */
 192   if (saved_errsv)
 193    sv_setsv(saved_errsv, ERRSV);
 194   else
 195    saved_errsv = newSVsv(ERRSV);
 196   SvCUR_set(ERRSV, 0);
 197   /* Immediately flush all errors. */
 198   if (IN_PERL_COMPILETIME) {
 199 #if XSH_HAS_PERL(5, 10, 0) || defined(PL_parser)
 200    if (PL_parser)
 201     ++PL_parser->error_count;
 202 #elif defined(PL_error_count)
 203    ++PL_error_count;
 204 #else
 205    ++PL_Ierror_count;
 206 #endif
 207    if (PL_errors) {
 208     sv_setsv(ERRSV, PL_errors);
 209     SvCUR_set(PL_errors, 0);
 210    }
 211   }
 212   sv_catsv(ERRSV, saved_errsv);
 213   SvREFCNT_dec(saved_errsv);
 214   croak(NULL);
 215  } else if (saved_errsv) {
 216   /* If IN_PERL_COMPILETIME && PL_errors, then the old ERRSV has already been
 217    * added to PL_errors. Otherwise, just restore it to ERRSV, as if no eval
 218    * block has ever been executed. */
 219   sv_setsv(ERRSV, saved_errsv);
 220   SvREFCNT_dec(saved_errsv);
 221  }
 222
 223  return ret;
 224 }
 225
 226 /* --- Check functions ----------------------------------------------------- */
 227
 228 /* ... op => source position map, continued ................................ */
 229
 230 static void indirect_map_store(pTHX_ const OP *o, STRLEN pos, SV *sv, line_t line) {
 231 #define indirect_map_store(O, P, N, L) indirect_map_store(aTHX_ (O), (P), (N), (L))
 232  indirect_op_info_t *oi;
 233  const char *s;
 234  STRLEN len;
 235  dXSH_CXT;
 236
 237  /* No need to check for XSH_CXT.map != NULL because this code path is always
 238   * guarded by indirect_hint(). */
 239
 240  if (!(oi = ptable_fetch(XSH_CXT.map, o))) {
 241   XSH_LOCAL_ALLOC(oi, 1, indirect_op_info_t);
 242   ptable_store(XSH_CXT.map, o, oi);
 243   oi->buf  = NULL;
 244   oi->size = 0;
 245  }
 246
 247  if (sv) {
 248   s = SvPV_const(sv, len);
 249  } else {
 250   s   = "{";
 251   len = 1;
 252  }
 253
 254  if (len > oi->size) {
 255   XSH_LOCAL_REALLOC(oi->buf, oi->size, len, char);
 256   oi->size = len;
 257  }
 258  Copy(s, oi->buf, len, char);
 259
 260  oi->len  = len;
 261  oi->pos  = pos;
 262  oi->line = line;
 263 }
 264
 265 static const indirect_op_info_t *indirect_map_fetch(pTHX_ const OP *o) {
 266 #define indirect_map_fetch(O) indirect_map_fetch(aTHX_ (O))
 267  dXSH_CXT;
 268
 269  /* No need to check for XSH_CXT.map != NULL because this code path is always
 270   * guarded by indirect_hint(). */
 271
 272  return ptable_fetch(XSH_CXT.map, o);
 273 }
 274
 275 static void indirect_map_delete(pTHX_ const OP *o) {
 276 #define indirect_map_delete(O) indirect_map_delete(aTHX_ (O))
 277  dXSH_CXT;
 278
 279  if (xsh_is_loaded(&XSH_CXT) && XSH_CXT.map)
 280   ptable_delete(XSH_CXT.map, o);
 281 }
 282
 283 /* ... Heuristics for finding a string in the source buffer ................ */
 284
 285 static int indirect_find(pTHX_ SV *name_sv, const char *line_bufptr, STRLEN *name_pos) {
 286 #define indirect_find(NSV, LBP, NP) indirect_find(aTHX_ (NSV), (LBP), (NP))
 287  STRLEN      name_len, line_len;
 288  const char *name, *name_end;
 289  const char *line, *line_end;
 290  const char *p;
 291
 292  line     = SvPV_const(PL_linestr, line_len);
 293  line_end = line + line_len;
 294
 295  name = SvPV_const(name_sv, name_len);
 296  if (name_len >= 1 && *name == '$') {
 297   ++name;
 298   --name_len;
 299   while (line_bufptr < line_end && *line_bufptr != '$')
 300    ++line_bufptr;
 301   if (line_bufptr >= line_end)
 302    return 0;
 303  }
 304  name_end = name + name_len;
 305
 306  p = line_bufptr;
 307  while (1) {
 308   p = ninstr(p, line_end, name, name_end);
 309   if (!p)
 310    return 0;
 311   if (!isALNUM(p[name_len]))
 312    break;
 313   /* p points to a word that has name as prefix, skip the rest of the word */
 314   p += name_len + 1;
 315   while (isALNUM(*p))
 316    ++p;
 317  }
 318
 319  *name_pos = p - line;
 320
 321  return 1;
 322 }
 323
 324 /* ... ck_const ............................................................ */
 325
 326 static OP *(*indirect_old_ck_const)(pTHX_ OP *) = 0;
 327
 328 static OP *indirect_ck_const(pTHX_ OP *o) {
 329  o = indirect_old_ck_const(aTHX_ o);
 330
 331  if (indirect_hint()) {
 332   SV *sv = cSVOPo_sv;
 333
 334   if (SvPOK(sv) && (SvTYPE(sv) >= SVt_PV)) {
 335    STRLEN pos;
 336
 337    if (indirect_find(sv, PL_oldbufptr, &pos)) {
 338     STRLEN len;
 339
 340     /* If the constant is equal to the current package name, try to look for
 341      * a "__PACKAGE__" coming before what we got. We only need to check this
 342      * when we already had a match because __PACKAGE__ can only appear in
 343      * direct method calls ("new __PACKAGE__" is a syntax error). */
 344     len = SvCUR(sv);
 345     if (PL_curstash
 346         && len == (STRLEN) HvNAMELEN_get(PL_curstash)
 347         && memcmp(SvPVX(sv), HvNAME_get(PL_curstash), len) == 0) {
 348      STRLEN pos_pkg;
 349      SV    *pkg = sv_newmortal();
 350      sv_setpvn(pkg, "__PACKAGE__", sizeof("__PACKAGE__")-1);
 351
 352      if (indirect_find(pkg, PL_oldbufptr, &pos_pkg) && pos_pkg < pos) {
 353       sv  = pkg;
 354       pos = pos_pkg;
 355      }
 356     }
 357
 358     indirect_map_store(o, pos, sv, CopLINE(&PL_compiling));
 359     return o;
 360    }
 361   }
 362  }
 363
 364  indirect_map_delete(o);
 365  return o;
 366 }
 367
 368 /* ... ck_rv2sv ............................................................ */
 369
 370 static OP *(*indirect_old_ck_rv2sv)(pTHX_ OP *) = 0;
 371
 372 static OP *indirect_ck_rv2sv(pTHX_ OP *o) {
 373  if (indirect_hint()) {
 374   OP *op = cUNOPo->op_first;
 375   SV *sv;
 376   const char *name = NULL;
 377   STRLEN pos, len;
 378   OPCODE type = (OPCODE) op->op_type;
 379
 380   switch (type) {
 381    case OP_GV:
 382    case OP_GVSV: {
 383     GV *gv = cGVOPx_gv(op);
 384     name = GvNAME(gv);
 385     len  = GvNAMELEN(gv);
 386     break;
 387    }
 388    default:
 389     if ((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP) {
 390      SV *nsv = cSVOPx_sv(op);
 391      if (SvPOK(nsv) && (SvTYPE(nsv) >= SVt_PV))
 392       name = SvPV_const(nsv, len);
 393     }
 394   }
 395   if (!name)
 396    goto done;
 397
 398   sv = sv_2mortal(newSVpvn("$", 1));
 399   sv_catpvn_nomg(sv, name, len);
 400   if (!indirect_find(sv, PL_oldbufptr, &pos)) {
 401    /* If it failed, retry without the current stash */
 402    const char *stash = HvNAME_get(PL_curstash);
 403    STRLEN stashlen = HvNAMELEN_get(PL_curstash);
 404
 405    if ((len < stashlen + 2) || strnNE(name, stash, stashlen)
 406        || name[stashlen] != ':' || name[stashlen+1] != ':') {
 407     /* Failed again ? Try to remove main */
 408     stash = "main";
 409     stashlen = 4;
 410     if ((len < stashlen + 2) || strnNE(name, stash, stashlen)
 411         || name[stashlen] != ':' || name[stashlen+1] != ':')
 412      goto done;
 413    }
 414
 415    sv_setpvn(sv, "$", 1);
 416    stashlen += 2;
 417    sv_catpvn_nomg(sv, name + stashlen, len - stashlen);
 418    if (!indirect_find(sv, PL_oldbufptr, &pos))
 419     goto done;
 420   }
 421
 422   o = indirect_old_ck_rv2sv(aTHX_ o);
 423
 424   indirect_map_store(o, pos, sv, CopLINE(&PL_compiling));
 425   return o;
 426  }
 427
 428 done:
 429  o = indirect_old_ck_rv2sv(aTHX_ o);
 430
 431  indirect_map_delete(o);
 432  return o;
 433 }
 434
 435 /* ... ck_padany ........................................................... */
 436
 437 static OP *(*indirect_old_ck_padany)(pTHX_ OP *) = 0;
 438
 439 static OP *indirect_ck_padany(pTHX_ OP *o) {
 440  o = indirect_old_ck_padany(aTHX_ o);
 441
 442  if (indirect_hint()) {
 443   SV *sv;
 444   const char *s = PL_oldbufptr, *t = PL_bufptr - 1;
 445
 446   while (s < t && isSPACE(*s)) ++s;
 447   if (*s == '$' && ++s <= t) {
 448    while (s < t && isSPACE(*s)) ++s;
 449    while (s < t && isSPACE(*t)) --t;
 450    sv = sv_2mortal(newSVpvn("$", 1));
 451    sv_catpvn_nomg(sv, s, t - s + 1);
 452    indirect_map_store(o, s - SvPVX_const(PL_linestr),
 453                          sv, CopLINE(&PL_compiling));
 454    return o;
 455   }
 456  }
 457
 458  indirect_map_delete(o);
 459  return o;
 460 }
 461
 462 /* ... ck_scope ............................................................ */
 463
 464 static OP *(*indirect_old_ck_scope)  (pTHX_ OP *) = 0;
 465 static OP *(*indirect_old_ck_lineseq)(pTHX_ OP *) = 0;
 466
 467 static OP *indirect_ck_scope(pTHX_ OP *o) {
 468  OP *(*old_ck)(pTHX_ OP *) = 0;
 469
 470  switch (o->op_type) {
 471   case OP_SCOPE:   old_ck = indirect_old_ck_scope;   break;
 472   case OP_LINESEQ: old_ck = indirect_old_ck_lineseq; break;
 473  }
 474  o = old_ck(aTHX_ o);
 475
 476  if (indirect_hint()) {
 477   indirect_map_store(o, PL_oldbufptr - SvPVX_const(PL_linestr),
 478                         NULL, CopLINE(&PL_compiling));
 479   return o;
 480  }
 481
 482  indirect_map_delete(o);
 483  return o;
 484 }
 485
 486 /* We don't need to clean the map entries for leave ops because they can only
 487  * be created by mutating from a lineseq. */
 488
 489 /* ... ck_method ........................................................... */
 490
 491 static OP *(*indirect_old_ck_method)(pTHX_ OP *) = 0;
 492
 493 static OP *indirect_ck_method(pTHX_ OP *o) {
 494  if (indirect_hint()) {
 495   OP *op = cUNOPo->op_first;
 496
 497   /* Indirect method call is only possible when the method is a bareword, so
 498    * don't trip up on $obj->$meth. */
 499   if (op && op->op_type == OP_CONST) {
 500    const indirect_op_info_t *oi = indirect_map_fetch(op);
 501    STRLEN pos;
 502    line_t line;
 503    SV *sv;
 504
 505    if (!oi)
 506     goto done;
 507
 508    sv   = sv_2mortal(newSVpvn(oi->buf, oi->len));
 509    pos  = oi->pos;
 510    /* Keep the old line so that we really point to the first line of the
 511     * expression. */
 512    line = oi->line;
 513
 514    o = indirect_old_ck_method(aTHX_ o);
 515    /* o may now be a method_named */
 516
 517    indirect_map_store(o, pos, sv, line);
 518    return o;
 519   }
 520  }
 521
 522 done:
 523  o = indirect_old_ck_method(aTHX_ o);
 524
 525  indirect_map_delete(o);
 526  return o;
 527 }
 528
 529 /* ... ck_method_named ..................................................... */
 530
 531 /* "use foo/no foo" compiles its call to import/unimport directly to a
 532  * method_named op. */
 533
 534 static OP *(*indirect_old_ck_method_named)(pTHX_ OP *) = 0;
 535
 536 static OP *indirect_ck_method_named(pTHX_ OP *o) {
 537  if (indirect_hint()) {
 538   STRLEN pos;
 539   line_t line;
 540   SV *sv;
 541
 542   sv = cSVOPo_sv;
 543   if (!SvPOK(sv) || (SvTYPE(sv) < SVt_PV))
 544    goto done;
 545   sv = sv_mortalcopy(sv);
 546
 547   if (!indirect_find(sv, PL_oldbufptr, &pos))
 548    goto done;
 549   line = CopLINE(&PL_compiling);
 550
 551   o = indirect_old_ck_method_named(aTHX_ o);
 552
 553   indirect_map_store(o, pos, sv, line);
 554   return o;
 555  }
 556
 557 done:
 558  o = indirect_old_ck_method_named(aTHX_ o);
 559
 560  indirect_map_delete(o);
 561  return o;
 562 }
 563
 564 /* ... ck_entersub ......................................................... */
 565
 566 static OP *(*indirect_old_ck_entersub)(pTHX_ OP *) = 0;
 567
 568 static OP *indirect_ck_entersub(pTHX_ OP *o) {
 569  SV *code = indirect_hint();
 570
 571  o = indirect_old_ck_entersub(aTHX_ o);
 572
 573  if (code) {
 574   const indirect_op_info_t *moi, *ooi;
 575   OP     *mop, *oop;
 576   LISTOP *lop;
 577
 578   oop = o;
 579   do {
 580    lop = (LISTOP *) oop;
 581    if (!(lop->op_flags & OPf_KIDS))
 582     goto done;
 583    oop = lop->op_first;
 584   } while (oop->op_type != OP_PUSHMARK);
 585   oop = OpSIBLING(oop);
 586   mop = lop->op_last;
 587
 588   if (!oop)
 589    goto done;
 590
 591   switch (oop->op_type) {
 592    case OP_CONST:
 593    case OP_RV2SV:
 594    case OP_PADSV:
 595    case OP_SCOPE:
 596    case OP_LEAVE:
 597     break;
 598    default:
 599     goto done;
 600   }
 601
 602   if (mop->op_type == OP_METHOD)
 603    mop = cUNOPx(mop)->op_first;
 604   else if (mop->op_type != OP_METHOD_NAMED)
 605    goto done;
 606
 607   moi = indirect_map_fetch(mop);
 608   if (!moi)
 609    goto done;
 610
 611   ooi = indirect_map_fetch(oop);
 612   if (!ooi)
 613    goto done;
 614
 615   /* When positions are identical, the method and the object must have the
 616    * same name. But it also means that it is an indirect call, as "foo->foo"
 617    * results in different positions. */
 618   if (   moi->line < ooi->line
 619       || (moi->line == ooi->line && moi->pos <= ooi->pos)) {
 620    SV *file;
 621    dSP;
 622
 623    ENTER;
 624    SAVETMPS;
 625
 626 #ifdef USE_ITHREADS
 627    file = sv_2mortal(newSVpv(CopFILE(&PL_compiling), 0));
 628 #else
 629    file = sv_mortalcopy(CopFILESV(&PL_compiling));
 630 #endif
 631
 632    PUSHMARK(SP);
 633    EXTEND(SP, 4);
 634    mPUSHp(ooi->buf, ooi->len);
 635    mPUSHp(moi->buf, moi->len);
 636    PUSHs(file);
 637    mPUSHu(moi->line);
 638    PUTBACK;
 639
 640    indirect_call_sv(code, G_VOID);
 641
 642    PUTBACK;
 643
 644    FREETMPS;
 645    LEAVE;
 646   }
 647  }
 648
 649 done:
 650  return o;
 651 }
 652
 653 /* --- Module setup/teardown ----------------------------------------------- */
 654
 655 static void xsh_user_global_setup(pTHX) {
 656  xsh_ck_replace(OP_CONST,   indirect_ck_const,  &indirect_old_ck_const);
 657  xsh_ck_replace(OP_RV2SV,   indirect_ck_rv2sv,  &indirect_old_ck_rv2sv);
 658  xsh_ck_replace(OP_PADANY,  indirect_ck_padany, &indirect_old_ck_padany);
 659  xsh_ck_replace(OP_SCOPE,   indirect_ck_scope,  &indirect_old_ck_scope);
 660  xsh_ck_replace(OP_LINESEQ, indirect_ck_scope,  &indirect_old_ck_lineseq);
 661
 662  xsh_ck_replace(OP_METHOD,       indirect_ck_method,
 663                                  &indirect_old_ck_method);
 664  xsh_ck_replace(OP_METHOD_NAMED, indirect_ck_method_named,
 665                                  &indirect_old_ck_method_named);
 666  xsh_ck_replace(OP_ENTERSUB,     indirect_ck_entersub,
 667                                  &indirect_old_ck_entersub);
 668
 669  return;
 670 }
 671
 672 static void xsh_user_local_setup(pTHX_ xsh_user_cxt_t *cxt) {
 673  HV *stash;
 674
 675  stash = gv_stashpvn(XSH_PACKAGE, XSH_PACKAGE_LEN, 1);
 676  newCONSTSUB(stash, "I_THREADSAFE", newSVuv(XSH_THREADSAFE));
 677  newCONSTSUB(stash, "I_FORKSAFE",   newSVuv(XSH_FORKSAFE));
 678
 679  cxt->map         = ptable_new(32);
 680  cxt->global_code = NULL;
 681
 682  return;
 683 }
 684
 685 static void xsh_user_local_teardown(pTHX_ xsh_user_cxt_t *cxt) {
 686  SvREFCNT_dec(cxt->global_code);
 687  cxt->global_code = NULL;
 688
 689  ptable_free(cxt->map);
 690  cxt->map         = NULL;
 691
 692  return;
 693 }
 694
 695 static void xsh_user_global_teardown(pTHX) {
 696  xsh_ck_restore(OP_CONST,   &indirect_old_ck_const);
 697  xsh_ck_restore(OP_RV2SV,   &indirect_old_ck_rv2sv);
 698  xsh_ck_restore(OP_PADANY,  &indirect_old_ck_padany);
 699  xsh_ck_restore(OP_SCOPE,   &indirect_old_ck_scope);
 700  xsh_ck_restore(OP_LINESEQ, &indirect_old_ck_lineseq);
 701
 702  xsh_ck_restore(OP_METHOD,       &indirect_old_ck_method);
 703  xsh_ck_restore(OP_METHOD_NAMED, &indirect_old_ck_method_named);
 704  xsh_ck_restore(OP_ENTERSUB,     &indirect_old_ck_entersub);
 705
 706  return;
 707 }
 708
 709 /* --- XS ------------------------------------------------------------------ */
 710
 711 MODULE = indirect      PACKAGE = indirect
 712
 713 PROTOTYPES: ENABLE
 714
 715 BOOT:
 716 {
 717  xsh_setup();
 718 }
 719
 720 #if XSH_THREADSAFE
 721
 722 void
 723 CLONE(...)
 724 PROTOTYPE: DISABLE
 725 PPCODE:
 726  xsh_clone();
 727  XSRETURN(0);
 728
 729 #endif /* XSH_THREADSAFE */
 730
 731 SV *
 732 _tag(SV *code)
 733 PROTOTYPE: $
 734 CODE:
 735  if (!SvOK(code))
 736   code = NULL;
 737  else if (SvROK(code))
 738   code = SvRV(code);
 739  RETVAL = xsh_hints_tag(code);
 740 OUTPUT:
 741  RETVAL
 742
 743 void
 744 _global(SV *code)
 745 PROTOTYPE: $
 746 PPCODE:
 747  if (!SvOK(code))
 748   code = NULL;
 749  else if (SvROK(code))
 750   code = SvRV(code);
 751  {
 752   dXSH_CXT;
 753   SvREFCNT_dec(XSH_CXT.global_code);
 754   XSH_CXT.global_code = SvREFCNT_inc(code);
 755  }
 756  XSRETURN(0);