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