X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2Findirect.git;a=blobdiff_plain;f=indirect.xs;h=f36c179e8537e024c75b414f90bb1e4d1eeefc2f;hp=beec19f7c470035e994c7d746297862b6d539d4a;hb=122a05bdb9134d5f644ac55e2db7e9479f9f2d0e;hpb=838f008dcda56897a619afdd99f450fb62672a15

diff --git a/indirect.xs b/indirect.xs
index beec19f..f36c179 100644
--- a/indirect.xs
+++ b/indirect.xs
@@ -35,8 +35,12 @@
 # define SvPVX_const SvPVX
 #endif
 
-#ifndef SvREFCNT_inc_simple_NN
-# define SvREFCNT_inc_simple_NN SvREFCNT_inc
+#ifndef SvREFCNT_inc_simple_void_NN
+# ifdef SvREFCNT_inc_simple_NN
+#  define SvREFCNT_inc_simple_void_NN SvREFCNT_inc_simple_NN
+# else
+#  define SvREFCNT_inc_simple_void_NN SvREFCNT_inc
+# endif
 #endif
 
 #ifndef sv_catpvn_nomg
@@ -182,10 +186,10 @@ typedef SV indirect_hint_t;
  * thread cleanup. */
 
 typedef struct {
+ char   *buf;
  STRLEN  pos;
  STRLEN  size;
  STRLEN  len;
- char   *buf;
  line_t  line;
 } indirect_op_info_t;
 
@@ -212,6 +216,7 @@ typedef struct {
  tTHX    owner;
 #endif
  ptable *map;
+ SV     *global_code;
 } my_cxt_t;
 
 START_MY_CXT
@@ -224,6 +229,9 @@ STATIC SV *indirect_clone(pTHX_ SV *sv, tTHX owner) {
  AV           *stashes = NULL;
  SV           *dupsv;
 
+ if (!sv)
+  return NULL;
+
  if (SvTYPE(sv) == SVt_PVHV && HvNAME_get(sv))
   stashes = newAV();
 
@@ -272,6 +280,7 @@ STATIC void indirect_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) {
 STATIC void indirect_thread_cleanup(pTHX_ void *ud) {
  dMY_CXT;
 
+ SvREFCNT_dec(MY_CXT.global_code);
  ptable_free(MY_CXT.map);
  ptable_hints_free(MY_CXT.tbl);
 }
@@ -333,7 +342,7 @@ STATIC SV *indirect_tag(pTHX_ SV *value) {
   value = SvRV(value);
   if (SvTYPE(value) >= SVt_PVCV) {
    code = value;
-   SvREFCNT_inc_simple_NN(code);
+   SvREFCNT_inc_simple_void_NN(code);
   }
  }
 
@@ -363,21 +372,18 @@ STATIC SV *indirect_tag(pTHX_ SV *value) {
 STATIC SV *indirect_detag(pTHX_ const SV *hint) {
 #define indirect_detag(H) indirect_detag(aTHX_ (H))
  indirect_hint_t *h;
-
- if (!(hint && SvIOK(hint)))
-  return NULL;
+#if I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION
+ dMY_CXT;
+#endif
 
  h = INT2PTR(indirect_hint_t *, SvIVX(hint));
 #if I_THREADSAFE
- {
-  dMY_CXT;
-  h = ptable_fetch(MY_CXT.tbl, h);
- }
+ h = ptable_fetch(MY_CXT.tbl, h);
 #endif /* I_THREADSAFE */
 
 #if I_WORKAROUND_REQUIRE_PROPAGATION
  if (indirect_require_tag() != h->require_tag)
-  return NULL;
+  return MY_CXT.global_code;
 #endif /* I_WORKAROUND_REQUIRE_PROPAGATION */
 
  return I_HINT_CODE(h);
@@ -387,11 +393,16 @@ STATIC U32 indirect_hash = 0;
 
 STATIC SV *indirect_hint(pTHX) {
 #define indirect_hint() indirect_hint(aTHX)
- SV *hint;
+ SV *hint = NULL;
 
  if (IN_PERL_RUNTIME)
   return NULL;
 
+#if I_HAS_PERL(5, 10, 0) || defined(PL_parser)
+ if (!PL_parser)
+  return NULL;
+#endif
+
 #ifdef cop_hints_fetch_pvn
  hint = cop_hints_fetch_pvn(PL_curcop, __PACKAGE__, __PACKAGE_LEN__,
                                                               indirect_hash, 0);
@@ -404,13 +415,17 @@ STATIC SV *indirect_hint(pTHX) {
 #else
  {
   SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, 0);
-  if (!val)
-   return 0;
-  hint = *val;
+  if (val)
+   hint = *val;
  }
 #endif
 
- return indirect_detag(hint);
+ if (hint && SvIOK(hint))
+  return indirect_detag(hint);
+ else {
+  dMY_CXT;
+  return MY_CXT.global_code;
+ }
 }
 
 /* ... op -> source position ............................................... */
@@ -851,10 +866,11 @@ STATIC void indirect_setup(pTHX) {
  {
   MY_CXT_INIT;
 #if I_THREADSAFE
-  MY_CXT.tbl   = ptable_new();
-  MY_CXT.owner = aTHX;
+  MY_CXT.tbl         = ptable_new();
+  MY_CXT.owner       = aTHX;
 #endif
-  MY_CXT.map   = ptable_new();
+  MY_CXT.map         = ptable_new();
+  MY_CXT.global_code = NULL;
  }
 
  indirect_old_ck_const        = PL_check[OP_CONST];
@@ -914,6 +930,7 @@ CLONE(...)
 PROTOTYPE: DISABLE
 PREINIT:
  ptable *t;
+ SV     *global_code_dup;
 PPCODE:
  {
   my_cxt_t ud;
@@ -921,12 +938,14 @@ PPCODE:
   ud.tbl   = t = ptable_new();
   ud.owner = MY_CXT.owner;
   ptable_walk(MY_CXT.tbl, indirect_ptable_clone, &ud);
+  global_code_dup = indirect_clone(MY_CXT.global_code, MY_CXT.owner);
  }
  {
   MY_CXT_CLONE;
-  MY_CXT.map   = ptable_new();
-  MY_CXT.tbl   = t;
-  MY_CXT.owner = aTHX;
+  MY_CXT.map         = ptable_new();
+  MY_CXT.tbl         = t;
+  MY_CXT.owner       = aTHX;
+  MY_CXT.global_code = global_code_dup;
  }
  reap(3, indirect_thread_cleanup, NULL);
  XSRETURN(0);
@@ -940,3 +959,18 @@ CODE:
  RETVAL = indirect_tag(value);
 OUTPUT:
  RETVAL
+
+void
+_global(SV *code)
+PROTOTYPE: $
+PPCODE:
+ if (!SvOK(code))
+  code = NULL;
+ else if (SvROK(code))
+  code = SvRV(code);
+ {
+  dMY_CXT;
+  SvREFCNT_dec(MY_CXT.global_code);
+  MY_CXT.global_code = SvREFCNT_inc(code);
+ }
+ XSRETURN(0);