The Big Boilerplate Factorization
[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/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);