X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=indirect.xs;h=ec533170104b8d1479aa1f7e894701d3cc92d911;hb=6edfe5477c8d5f0fc681c7c317124380948f5300;hp=ffb8a221c3610f4cce0ebb7037ab4e09b8daf7d0;hpb=42991cca70b2f98cbfc9e7cd1470df0e40842a8d;p=perl%2Fmodules%2Findirect.git

diff --git a/indirect.xs b/indirect.xs
index ffb8a22..ec53317 100644
--- a/indirect.xs
+++ b/indirect.xs
@@ -101,6 +101,12 @@
 # endif
 #endif
 
+#ifdef DEBUGGING
+# define I_ASSERT(C) assert(C)
+#else
+# define I_ASSERT(C)
+#endif
+
 #ifndef I_WORKAROUND_REQUIRE_PROPAGATION
 # define I_WORKAROUND_REQUIRE_PROPAGATION !I_HAS_PERL(5, 10, 1)
 #endif
@@ -219,7 +225,8 @@ 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,13 +253,13 @@ 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);
+  I_ASSERT(indirect_loaded == 0);
+  I_ASSERT(!indirect_loaded_cxts);
   indirect_loaded_cxts = ptable_new();
   global_setup         = 1;
  }
  ++indirect_loaded;
- assert(indirect_loaded_cxts);
+ I_ASSERT(indirect_loaded_cxts);
  ptable_loaded_store(indirect_loaded_cxts, cxt, cxt);
 
  return global_setup;
@@ -263,11 +270,11 @@ static int indirect_clear_loaded_locked(pTHX_ void *cxt) {
  int global_teardown = 0;
 
  if (indirect_loaded > 1) {
-  assert(indirect_loaded_cxts);
+  I_ASSERT(indirect_loaded_cxts);
   ptable_loaded_delete(indirect_loaded_cxts, cxt);
   --indirect_loaded;
  } else if (indirect_loaded_cxts) {
-  assert(indirect_loaded == 1);
+  I_ASSERT(indirect_loaded == 1);
   ptable_loaded_free(indirect_loaded_cxts);
   indirect_loaded_cxts = NULL;
   indirect_loaded      = 0;
@@ -320,6 +327,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_
@@ -346,6 +355,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_
@@ -633,6 +644,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) {
@@ -990,7 +1063,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;
 
@@ -1123,7 +1196,7 @@ PPCODE:
    int global_setup;
    I_LOADED_LOCK;
    global_setup = indirect_set_loaded_locked(&MY_CXT);
-   assert(!global_setup);
+   I_ASSERT(!global_setup);
    I_LOADED_UNLOCK;
   }
  }