Update XS helpers to 18554226
[perl/modules/indirect.git] / 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);