X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2Findirect.git;a=blobdiff_plain;f=indirect.xs;h=4f7ac3a9721c19e5abd772d107920c3eb52fa419;hp=dedc58bb453c9003a10980dc27dda2a774dde32a;hb=47795ecd50880244edb1da0a9253bf228d9e9293;hpb=e3609d4f5df9ec09d582f3e60b92e6e8263cd6cd

diff --git a/indirect.xs b/indirect.xs
index dedc58b..4f7ac3a 100644
--- a/indirect.xs
+++ b/indirect.xs
@@ -84,7 +84,7 @@
 #endif
 
 #ifndef I_WORKAROUND_REQUIRE_PROPAGATION
-# define I_WORKAROUND_REQUIRE_PROPAGATION !I_HAS_PERL(5, 12, 0)
+# define I_WORKAROUND_REQUIRE_PROPAGATION !I_HAS_PERL(5, 10, 1)
 #endif
 
 /* ... Thread safety and multiplicity ...................................... */
@@ -182,10 +182,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;
 
@@ -200,6 +200,7 @@ typedef struct {
 #include "ptable.h"
 
 #define ptable_store(T, K, V) ptable_store(aTHX_ (T), (K), (V))
+#define ptable_delete(T, K)   ptable_delete(aTHX_ (T), (K))
 #define ptable_clear(T)       ptable_clear(aTHX_ (T))
 #define ptable_free(T)        ptable_free(aTHX_ (T))
 
@@ -211,6 +212,7 @@ typedef struct {
  tTHX    owner;
 #endif
  ptable *map;
+ SV     *global_code;
 } my_cxt_t;
 
 START_MY_CXT
@@ -223,6 +225,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();
 
@@ -252,7 +257,6 @@ STATIC void indirect_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) {
 
  h2       = PerlMemShared_malloc(sizeof *h2);
  h2->code = indirect_clone(h1->code, ud->owner);
- SvREFCNT_inc(h2->code);
 #if I_WORKAROUND_REQUIRE_PROPAGATION
  h2->require_tag = PTR2IV(indirect_clone(INT2PTR(SV *, h1->require_tag),
                                          ud->owner));
@@ -261,7 +265,6 @@ STATIC void indirect_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) {
 #else  /*  I_HINT_STRUCT */
 
  h2 = indirect_clone(h1, ud->owner);
- SvREFCNT_inc(h2);
 
 #endif /* !I_HINT_STRUCT */
 
@@ -273,6 +276,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);
 }
@@ -329,7 +333,6 @@ STATIC SV *indirect_tag(pTHX_ SV *value) {
 #define indirect_tag(V) indirect_tag(aTHX_ (V))
  indirect_hint_t *h;
  SV *code = NULL;
- dMY_CXT;
 
  if (SvROK(value)) {
   value = SvRV(value);
@@ -350,10 +353,13 @@ STATIC SV *indirect_tag(pTHX_ SV *value) {
 #endif /* !I_HINT_STRUCT */
 
 #if I_THREADSAFE
- /* We only need for the key to be an unique tag for looking up the value later.
-  * Allocated memory provides convenient unique identifiers, so that's why we
-  * use the hint as the key itself. */
- ptable_hints_store(MY_CXT.tbl, h, h);
+ {
+  dMY_CXT;
+  /* We only need for the key to be an unique tag for looking up the value later
+   * Allocated memory provides convenient unique identifiers, so that's why we
+   * use the hint as the key itself. */
+  ptable_hints_store(MY_CXT.tbl, h, h);
+ }
 #endif /* I_THREADSAFE */
 
  return newSViv(PTR2IV(h));
@@ -362,10 +368,9 @@ 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 I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION
  dMY_CXT;
-
- if (!(hint && SvIOK(hint)))
-  return NULL;
+#endif
 
  h = INT2PTR(indirect_hint_t *, SvIVX(hint));
 #if I_THREADSAFE
@@ -374,7 +379,7 @@ STATIC SV *indirect_detag(pTHX_ const SV *hint) {
 
 #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);
@@ -384,16 +389,39 @@ STATIC U32 indirect_hash = 0;
 
 STATIC SV *indirect_hint(pTHX) {
 #define indirect_hint() indirect_hint(aTHX)
- SV **val;
+ SV *hint = NULL;
 
  if (IN_PERL_RUNTIME)
   return NULL;
 
- val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, indirect_hash);
- if (!val)
+#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);
+#elif I_HAS_PERL(5, 9, 5)
+ hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
+                                       NULL,
+                                       __PACKAGE__, __PACKAGE_LEN__,
+                                       0,
+                                       indirect_hash);
+#else
+ {
+  SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, 0);
+  if (val)
+   hint = *val;
+ }
+#endif
 
- return indirect_detag(*val);
+ if (hint && SvIOK(hint))
+  return indirect_detag(hint);
+ else {
+  dMY_CXT;
+  return MY_CXT.global_code;
+ }
 }
 
 /* ... op -> source position ............................................... */
@@ -442,7 +470,7 @@ STATIC void indirect_map_delete(pTHX_ const OP *o) {
 #define indirect_map_delete(O) indirect_map_delete(aTHX_ (O))
  dMY_CXT;
 
- ptable_store(MY_CXT.map, o, NULL);
+ ptable_delete(MY_CXT.map, o);
 }
 
 /* --- Check functions ----------------------------------------------------- */
@@ -483,7 +511,7 @@ STATIC int indirect_find(pTHX_ SV *sv, const char *s, STRLEN *pos) {
 STATIC OP *(*indirect_old_ck_const)(pTHX_ OP *) = 0;
 
 STATIC OP *indirect_ck_const(pTHX_ OP *o) {
- o = CALL_FPTR(indirect_old_ck_const)(aTHX_ o);
+ o = indirect_old_ck_const(aTHX_ o);
 
  if (indirect_hint()) {
   SV *sv = cSVOPo_sv;
@@ -556,14 +584,14 @@ STATIC OP *indirect_ck_rv2sv(pTHX_ OP *o) {
     goto done;
   }
 
-  o = CALL_FPTR(indirect_old_ck_rv2sv)(aTHX_ o);
+  o = indirect_old_ck_rv2sv(aTHX_ o);
 
   indirect_map_store(o, pos, sv, CopLINE(&PL_compiling));
   return o;
  }
 
 done:
- o = CALL_FPTR(indirect_old_ck_rv2sv)(aTHX_ o);
+ o = indirect_old_ck_rv2sv(aTHX_ o);
 
  indirect_map_delete(o);
  return o;
@@ -574,7 +602,7 @@ done:
 STATIC OP *(*indirect_old_ck_padany)(pTHX_ OP *) = 0;
 
 STATIC OP *indirect_ck_padany(pTHX_ OP *o) {
- o = CALL_FPTR(indirect_old_ck_padany)(aTHX_ o);
+ o = indirect_old_ck_padany(aTHX_ o);
 
  if (indirect_hint()) {
   SV *sv;
@@ -608,7 +636,7 @@ STATIC OP *indirect_ck_scope(pTHX_ OP *o) {
   case OP_SCOPE:   old_ck = indirect_old_ck_scope;   break;
   case OP_LINESEQ: old_ck = indirect_old_ck_lineseq; break;
  }
- o = CALL_FPTR(old_ck)(aTHX_ o);
+ o = old_ck(aTHX_ o);
 
  if (indirect_hint()) {
   indirect_map_store(o, PL_oldbufptr - SvPVX_const(PL_linestr),
@@ -648,7 +676,7 @@ STATIC OP *indirect_ck_method(pTHX_ OP *o) {
     * expression. */
    line = oi->line;
 
-   o = CALL_FPTR(indirect_old_ck_method)(aTHX_ o);
+   o = indirect_old_ck_method(aTHX_ o);
    /* o may now be a method_named */
 
    indirect_map_store(o, pos, sv, line);
@@ -657,7 +685,7 @@ STATIC OP *indirect_ck_method(pTHX_ OP *o) {
  }
 
 done:
- o = CALL_FPTR(indirect_old_ck_method)(aTHX_ o);
+ o = indirect_old_ck_method(aTHX_ o);
 
  indirect_map_delete(o);
  return o;
@@ -685,14 +713,14 @@ STATIC OP *indirect_ck_method_named(pTHX_ OP *o) {
    goto done;
   line = CopLINE(&PL_compiling);
 
-  o = CALL_FPTR(indirect_old_ck_method_named)(aTHX_ o);
+  o = indirect_old_ck_method_named(aTHX_ o);
 
   indirect_map_store(o, pos, sv, line);
   return o;
  }
 
 done:
- o = CALL_FPTR(indirect_old_ck_method_named)(aTHX_ o);
+ o = indirect_old_ck_method_named(aTHX_ o);
 
  indirect_map_delete(o);
  return o;
@@ -705,7 +733,7 @@ STATIC OP *(*indirect_old_ck_entersub)(pTHX_ OP *) = 0;
 STATIC OP *indirect_ck_entersub(pTHX_ OP *o) {
  SV *code = indirect_hint();
 
- o = CALL_FPTR(indirect_old_ck_entersub)(aTHX_ o);
+ o = indirect_old_ck_entersub(aTHX_ o);
 
  if (code) {
   const indirect_op_info_t *moi, *ooi;
@@ -789,8 +817,6 @@ done:
 STATIC U32 indirect_initialized = 0;
 
 STATIC void indirect_teardown(pTHX_ void *root) {
- dMY_CXT;
-
  if (!indirect_initialized)
   return;
 
@@ -799,10 +825,13 @@ STATIC void indirect_teardown(pTHX_ void *root) {
   return;
 #endif
 
- ptable_free(MY_CXT.map);
+ {
+  dMY_CXT;
+  ptable_free(MY_CXT.map);
 #if I_THREADSAFE
- ptable_hints_free(MY_CXT.tbl);
+  ptable_hints_free(MY_CXT.tbl);
 #endif
+ }
 
  PL_check[OP_CONST]           = MEMBER_TO_FPTR(indirect_old_ck_const);
  indirect_old_ck_const        = 0;
@@ -833,10 +862,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];
@@ -896,6 +926,7 @@ CLONE(...)
 PROTOTYPE: DISABLE
 PREINIT:
  ptable *t;
+ SV     *global_code_dup;
 PPCODE:
  {
   my_cxt_t ud;
@@ -903,12 +934,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);
@@ -922,3 +955,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);