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