X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2Findirect.git;a=blobdiff_plain;f=indirect.xs;h=3d901d0f7d457d9e0af25a5816c4b4b977abe146;hp=bd52eee412473f577c262d14c6fe8cc4c47c3d5a;hb=4f7c4a9fe4fd2332dd2a748b17171f9d45129e4f;hpb=7645d1927c141596242b284b6fba4213264e5775

diff --git a/indirect.xs b/indirect.xs
index bd52eee..3d901d0 100644
--- a/indirect.xs
+++ b/indirect.xs
@@ -167,17 +167,17 @@
 #endif
 
 #if defined(OP_CHECK_MUTEX_LOCK) && defined(OP_CHECK_MUTEX_UNLOCK)
-# define I_CHECK_MUTEX_LOCK   OP_CHECK_MUTEX_LOCK
-# define I_CHECK_MUTEX_UNLOCK OP_CHECK_MUTEX_UNLOCK
+# define I_CHECK_LOCK   OP_CHECK_MUTEX_LOCK
+# define I_CHECK_UNLOCK OP_CHECK_MUTEX_UNLOCK
 #elif I_HAS_PERL(5, 9, 3)
-# define I_CHECK_MUTEX_LOCK   OP_REFCNT_LOCK
-# define I_CHECK_MUTEX_UNLOCK OP_REFCNT_UNLOCK
+# define I_CHECK_LOCK   OP_REFCNT_LOCK
+# define I_CHECK_UNLOCK OP_REFCNT_UNLOCK
 #else
 /* Before perl 5.9.3, indirect_ck_*() calls are already protected by the
  * I_LOADED mutex, which falls back to the OP_REFCNT mutex. Make sure we don't
  * lock it twice. */
-# define I_CHECK_MUTEX_LOCK   NOOP
-# define I_CHECK_MUTEX_UNLOCK NOOP
+# define I_CHECK_LOCK   NOOP
+# define I_CHECK_UNLOCK NOOP
 #endif
 
 typedef OP *(*indirect_ck_t)(pTHX_ OP *);
@@ -190,36 +190,37 @@ typedef OP *(*indirect_ck_t)(pTHX_ OP *);
 
 static void indirect_ck_replace(pTHX_ OPCODE type, indirect_ck_t new_ck, indirect_ck_t *old_ck_p) {
 #define indirect_ck_replace(T, NC, OCP) indirect_ck_replace(aTHX_ (T), (NC), (OCP))
- I_CHECK_MUTEX_LOCK;
+ I_CHECK_LOCK;
  if (!*old_ck_p) {
   *old_ck_p      = PL_check[type];
   PL_check[type] = new_ck;
  }
- I_CHECK_MUTEX_UNLOCK;
+ I_CHECK_UNLOCK;
 }
 
 #endif
 
 static void indirect_ck_restore(pTHX_ OPCODE type, indirect_ck_t *old_ck_p) {
 #define indirect_ck_restore(T, OCP) indirect_ck_restore(aTHX_ (T), (OCP))
- I_CHECK_MUTEX_LOCK;
+ I_CHECK_LOCK;
  if (*old_ck_p) {
   PL_check[type] = *old_ck_p;
   *old_ck_p      = 0;
  }
- I_CHECK_MUTEX_UNLOCK;
+ I_CHECK_UNLOCK;
 }
 
 /* --- Helpers ------------------------------------------------------------- */
 
 /* ... Check if the module is loaded ....................................... */
 
-static U32 indirect_loaded = 0;
+static I32 indirect_loaded = 0;
 
 #if I_THREADSAFE
 
 #define PTABLE_NAME        ptable_loaded
-#define PTABLE_VAL_FREE(V) NOOP
+#define PTABLE_NEED_DELETE 1
+#define PTABLE_NEED_WALK   0
 
 #include "ptable.h"
 
@@ -246,6 +247,7 @@ static int indirect_set_loaded_locked(pTHX_ void *cxt) {
  int global_setup = 0;
 
  if (indirect_loaded <= 0) {
+  assert(indirect_loaded == 0);
   assert(!indirect_loaded_cxts);
   indirect_loaded_cxts = ptable_new();
   global_setup         = 1;
@@ -266,6 +268,7 @@ static int indirect_clear_loaded_locked(pTHX_ void *cxt) {
   ptable_loaded_delete(indirect_loaded_cxts, cxt);
   --indirect_loaded;
  } else if (indirect_loaded_cxts) {
+  assert(indirect_loaded == 1);
   ptable_loaded_free(indirect_loaded_cxts);
   indirect_loaded_cxts = NULL;
   indirect_loaded      = 0;
@@ -318,6 +321,8 @@ typedef SV indirect_hint_t;
 
 #define PTABLE_NAME        ptable_hints
 #define PTABLE_VAL_FREE(V) I_HINT_FREE(V)
+#define PTABLE_NEED_DELETE 0
+#define PTABLE_NEED_WALK   1
 
 #define pPTBL  pTHX
 #define pPTBL_ pTHX_
@@ -344,6 +349,8 @@ typedef struct {
 
 #define PTABLE_NAME        ptable
 #define PTABLE_VAL_FREE(V) if (V) { Safefree(((indirect_op_info_t *) (V))->buf); Safefree(V); }
+#define PTABLE_NEED_DELETE 1
+#define PTABLE_NEED_WALK   0
 
 #define pPTBL  pTHX
 #define pPTBL_ pTHX_
@@ -419,49 +426,10 @@ static void indirect_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) {
  ptable_hints_store(ud->tbl, ent->key, h2);
 }
 
-static void indirect_thread_cleanup(pTHX_ void *ud) {
- int global_teardown;
- dMY_CXT;
-
- global_teardown = indirect_clear_loaded_locked(&MY_CXT);
- assert(!global_teardown);
-
- SvREFCNT_dec(MY_CXT.global_code);
- MY_CXT.global_code = NULL;
-
- ptable_free(MY_CXT.map);
- MY_CXT.map = NULL;
-
- ptable_hints_free(MY_CXT.tbl);
- MY_CXT.tbl = NULL;
-}
-
-static int indirect_endav_free(pTHX_ SV *sv, MAGIC *mg) {
- SAVEDESTRUCTOR_X(indirect_thread_cleanup, NULL);
-
- return 0;
-}
-
-static MGVTBL indirect_endav_vtbl = {
- 0,
- 0,
- 0,
- 0,
- indirect_endav_free
-#if MGf_COPY
- , 0
-#endif
-#if MGf_DUP
- , 0
-#endif
-#if MGf_LOCAL
- , 0
-#endif
-};
-
 #endif /* I_THREADSAFE */
 
 #if I_WORKAROUND_REQUIRE_PROPAGATION
+
 static IV indirect_require_tag(pTHX) {
 #define indirect_require_tag() indirect_require_tag(aTHX)
  const CV *cv, *outside;
@@ -505,6 +473,7 @@ get_enclosing_cv:
 
  return PTR2IV(cv);
 }
+
 #endif /* I_WORKAROUND_REQUIRE_PROPAGATION */
 
 static SV *indirect_tag(pTHX_ SV *value) {
@@ -669,6 +638,68 @@ static void indirect_map_delete(pTHX_ const OP *o) {
   ptable_delete(MY_CXT.map, o);
 }
 
+/* --- Safe version of call_sv() ------------------------------------------- */
+
+static I32 indirect_call_sv(pTHX_ SV *sv, I32 flags) {
+#define indirect_call_sv(S, F) indirect_call_sv(aTHX_ (S), (F))
+ I32          ret, cxix;
+ PERL_CONTEXT saved_cx;
+ SV          *saved_errsv = NULL;
+
+ if (SvTRUE(ERRSV)) {
+  if (IN_PERL_COMPILETIME && PL_errors)
+   sv_catsv(PL_errors, ERRSV);
+  else
+   saved_errsv = newSVsv(ERRSV);
+  SvCUR_set(ERRSV, 0);
+ }
+
+ cxix     = (cxstack_ix < cxstack_max) ? (cxstack_ix + 1) : Perl_cxinc(aTHX);
+ /* The last popped context will be reused by call_sv(), but our callers may
+  * still need its previous value. Back it up so that it isn't clobbered. */
+ saved_cx = cxstack[cxix];
+
+ ret = call_sv(sv, flags | G_EVAL);
+
+ cxstack[cxix] = saved_cx;
+
+ if (SvTRUE(ERRSV)) {
+  /* Discard the old ERRSV, and reuse the variable to temporarily store the
+   * new one. */
+  if (saved_errsv)
+   sv_setsv(saved_errsv, ERRSV);
+  else
+   saved_errsv = newSVsv(ERRSV);
+  SvCUR_set(ERRSV, 0);
+  /* Immediately flush all errors. */
+  if (IN_PERL_COMPILETIME) {
+#if I_HAS_PERL(5, 10, 0) || defined(PL_parser)
+   if (PL_parser)
+    ++PL_parser->error_count;
+#elif defined(PL_error_count)
+   ++PL_error_count;
+#else
+   ++PL_Ierror_count;
+#endif
+   if (PL_errors) {
+    sv_setsv(ERRSV, PL_errors);
+    SvCUR_set(PL_errors, 0);
+   }
+  }
+  sv_catsv(ERRSV, saved_errsv);
+  SvREFCNT_dec(saved_errsv);
+  croak(NULL);
+ } else if (saved_errsv) {
+  /* If IN_PERL_COMPILETIME && PL_errors, then the old ERRSV has already been
+   * added to PL_errors. Otherwise, just restore it to ERRSV, as if no eval
+   * block has ever been executed. */
+  sv_setsv(ERRSV, saved_errsv);
+  SvREFCNT_dec(saved_errsv);
+ }
+
+ return ret;
+}
+
 /* --- Check functions ----------------------------------------------------- */
 
 static int indirect_find(pTHX_ SV *name_sv, const char *line_bufptr, STRLEN *name_pos) {
@@ -1026,7 +1057,7 @@ static OP *indirect_ck_entersub(pTHX_ OP *o) {
    mPUSHu(moi->line);
    PUTBACK;
 
-   call_sv(code, G_VOID);
+   indirect_call_sv(code, G_VOID);
 
    PUTBACK;
 
@@ -1044,11 +1075,6 @@ done:
 static void indirect_teardown(pTHX_ void *interp) {
  dMY_CXT;
 
-#if I_MULTIPLICITY
- if (aTHX != interp)
-  return;
-#endif
-
  I_LOADED_LOCK;
 
  if (indirect_clear_loaded_locked(&MY_CXT)) {
@@ -1065,6 +1091,9 @@ static void indirect_teardown(pTHX_ void *interp) {
 
  I_LOADED_UNLOCK;
 
+ SvREFCNT_dec(MY_CXT.global_code);
+ MY_CXT.global_code = NULL;
+
  ptable_free(MY_CXT.map);
  MY_CXT.map = NULL;
 
@@ -1092,11 +1121,11 @@ static void indirect_setup(pTHX) {
   indirect_ck_replace(OP_LINESEQ, indirect_ck_scope,  &indirect_old_ck_lineseq);
 
   indirect_ck_replace(OP_METHOD,       indirect_ck_method,
-				       &indirect_old_ck_method);
+                                       &indirect_old_ck_method);
   indirect_ck_replace(OP_METHOD_NAMED, indirect_ck_method_named,
-				       &indirect_old_ck_method_named);
+                                       &indirect_old_ck_method_named);
   indirect_ck_replace(OP_ENTERSUB,     indirect_ck_entersub,
-				       &indirect_old_ck_entersub);
+                                       &indirect_old_ck_entersub);
  }
 
  I_LOADED_UNLOCK;
@@ -1117,11 +1146,7 @@ static void indirect_setup(pTHX) {
   MY_CXT.global_code = NULL;
  }
 
-#if I_MULTIPLICITY
- call_atexit(indirect_teardown, aTHX);
-#else
  call_atexit(indirect_teardown, NULL);
-#endif
 
  return;
 }
@@ -1145,7 +1170,6 @@ PROTOTYPE: DISABLE
 PREINIT:
  ptable *t;
  SV     *global_code_dup;
- GV     *gv;
 PPCODE:
  {
   indirect_ptable_clone_ud ud;
@@ -1170,26 +1194,9 @@ PPCODE:
    I_LOADED_UNLOCK;
   }
  }
- gv = gv_fetchpv(__PACKAGE__ "::_THREAD_CLEANUP", 0, SVt_PVCV);
- if (gv) {
-  CV *cv = GvCV(gv);
-  if (!PL_endav)
-   PL_endav = newAV();
-  SvREFCNT_inc(cv);
-  if (!av_store(PL_endav, av_len(PL_endav) + 1, (SV *) cv))
-   SvREFCNT_dec(cv);
-  sv_magicext((SV *) PL_endav, NULL, PERL_MAGIC_ext, &indirect_endav_vtbl, NULL, 0);
- }
  XSRETURN(0);
 
-void
-_THREAD_CLEANUP(...)
-PROTOTYPE: DISABLE
-PPCODE:
- indirect_thread_cleanup(aTHX_ NULL);
- XSRETURN(0);
-
-#endif
+#endif /* I_THREADSAFE */
 
 SV *
 _tag(SV *value)