X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=Upper.xs;h=b68b08f24fe9d226189e42ad994f841e2c3d15c7;hb=refs%2Ftags%2Fv0.17;hp=9ab1eaad745b124bd14672ed000951b917553e7e;hpb=aa7f19d0069d057cf99b963b2db36e7caccb6b2b;p=perl%2Fmodules%2FScope-Upper.git

diff --git a/Upper.xs b/Upper.xs
index 9ab1eaa..b68b08f 100644
--- a/Upper.xs
+++ b/Upper.xs
@@ -3,7 +3,7 @@
 
 #define PERL_NO_GET_CONTEXT
 #include "EXTERN.h"
-#include "perl.h" 
+#include "perl.h"
 #include "XSUB.h"
 
 #define __PACKAGE__ "Scope::Upper"
@@ -209,8 +209,9 @@ typedef struct {
 
  COP *old_curcop;
 
- bool old_catch;
- OP  *old_op;
+ runops_proc_t  old_runops;
+ bool           old_catch;
+ OP            *old_op;
 } su_uplevel_ud;
 
 STATIC su_uplevel_ud *su_uplevel_ud_new(pTHX) {
@@ -245,6 +246,7 @@ STATIC void su_uplevel_ud_delete(pTHX_ su_uplevel_ud *sud) {
 }
 
 typedef struct {
+ su_uplevel_ud *top;
  su_uplevel_ud *root;
  I32            count;
 } su_uplevel_storage;
@@ -974,6 +976,9 @@ STATIC su_uplevel_ud *su_uplevel_storage_new(pTHX) {
   sud = su_uplevel_ud_new();
  }
 
+ sud->next = MY_CXT.uplevel_storage.top;
+ MY_CXT.uplevel_storage.top = sud;
+
  return sud;
 }
 
@@ -981,6 +986,8 @@ STATIC void su_uplevel_storage_delete(pTHX_ su_uplevel_ud *sud) {
 #define su_uplevel_storage_delete(S) su_uplevel_storage_delete(aTHX_ (S))
  dMY_CXT;
 
+ MY_CXT.uplevel_storage.top = sud->next;
+
  if (MY_CXT.uplevel_storage.count >= SU_UPLEVEL_STORAGE_SIZE) {
   su_uplevel_ud_delete(sud);
  } else {
@@ -990,25 +997,84 @@ STATIC void su_uplevel_storage_delete(pTHX_ su_uplevel_ud *sud) {
  }
 }
 
-#define SU_HAS_EXT_MAGIC SU_HAS_PERL(5, 8, 0)
+STATIC int su_uplevel_goto_static(const OP *o) {
+ for (; o; o = o->op_sibling) {
+  /* goto ops are unops with kids. */
+  if (!(o->op_flags & OPf_KIDS))
+   continue;
 
-#if SU_HAS_EXT_MAGIC && !SU_HAS_PERL(5, 13, 7)
-
-STATIC int su_uplevel_restore_free(pTHX_ SV *sv, MAGIC *mg) {
- su_uplevel_storage_delete((su_uplevel_ud *) mg->mg_ptr);
+  switch (o->op_type) {
+   case OP_LEAVEEVAL:
+   case OP_LEAVETRY:
+    /* Don't care about gotos inside eval, as they are forbidden at run time. */
+    break;
+   case OP_GOTO:
+    return 1;
+   default:
+    if (su_uplevel_goto_static(cUNOPo->op_first))
+     return 1;
+    break;
+  }
+ }
 
  return 0;
 }
 
-STATIC MGVTBL su_uplevel_restore_vtbl = {
- 0,
- 0,
- 0,
- 0,
- su_uplevel_restore_free
-};
+STATIC int su_uplevel_goto_runops(pTHX) {
+#define su_uplevel_goto_runops() su_uplevel_goto_runops(aTHX)
+ register OP *op;
+ dVAR;
+
+ op = PL_op;
+ do {
+  if (op->op_type == OP_GOTO) {
+   AV  *argarray = NULL;
+   I32  cxix;
+
+   for (cxix = cxstack_ix; cxix >= 0; --cxix) {
+    const PERL_CONTEXT *cx = cxstack + cxix;
+
+    switch (CxTYPE(cx)) {
+     case CXt_SUB:
+      if (CxHASARGS(cx)) {
+       argarray = cx->blk_sub.argarray;
+       goto done;
+      }
+      break;
+     case CXt_EVAL:
+     case CXt_FORMAT:
+      goto done;
+     default:
+      break;
+    }
+   }
+
+done:
+   if (argarray) {
+    dMY_CXT;
 
-#endif /* SU_HAS_EXT_MAGIC && !SU_HAS_PERL(5, 13, 7) */
+    if (MY_CXT.uplevel_storage.top->cxix == cxix) {
+     AV  *args  = GvAV(PL_defgv);
+     I32  items = AvFILLp(args);
+
+     av_extend(argarray, items);
+     Copy(AvARRAY(args), AvARRAY(argarray), items + 1, SV *);
+     AvFILLp(argarray) = items;
+    }
+   }
+  }
+
+  PL_op = op = op->op_ppaddr(aTHX);
+
+#if !SU_HAS_PERL(5, 13, 0)
+  PERL_ASYNC_CHECK();
+#endif
+ } while (op);
+
+ TAINT_NOT;
+
+ return 0;
+}
 
 #define su_at_underscore(C) AvARRAY(AvARRAY(CvPADLIST(C))[CvDEPTH(C)])[0]
 
@@ -1017,6 +1083,9 @@ STATIC void su_uplevel_restore(pTHX_ void *sus_) {
  PERL_SI *cur = sud->old_curstackinfo;
  PERL_SI *si  = sud->si;
 
+ if (PL_runops == su_uplevel_goto_runops)
+  PL_runops = sud->old_runops;
+
  if (sud->callback) {
   PERL_CONTEXT *cx = cxstack + sud->cxix;
   AV     *argarray = MUTABLE_AV(su_at_underscore(sud->callback));
@@ -1149,20 +1218,12 @@ found_it:
  /* This issue has been fixed in perl with commit 8f89e5a9, which was made
   * public in perl 5.13.7. */
  su_uplevel_storage_delete(sud);
-#elif SU_HAS_EXT_MAGIC
- /* If 'ext' magic is available, we work around this by attaching the state
-  * data to a scalar that will be freed "soon". */
- {
-  SV *sv = sv_newmortal();
-
-  sv_magicext(sv, NULL, PERL_MAGIC_ext, &su_uplevel_restore_vtbl,
-                        (const char *) sud, 0);
- }
 #else
  /* Otherwise, we just enqueue it back in the global storage list. */
  {
   dMY_CXT;
 
+  MY_CXT.uplevel_storage.top  = sud->next;
   sud->next = MY_CXT.uplevel_storage.root;
   MY_CXT.uplevel_storage.root = sud;
   MY_CXT.uplevel_storage.count++;
@@ -1200,10 +1261,15 @@ STATIC CV *su_cv_clone(pTHX_ CV *proto, GV *gv) {
   Perl_sv_add_backref(aTHX_ CvSTASH(proto), MUTABLE_SV(cv));
 #endif
 
- OP_REFCNT_LOCK;
- CvROOT(cv)        = OpREFCNT_inc(CvROOT(proto));
- OP_REFCNT_UNLOCK;
- CvSTART(cv)       = CvSTART(proto);
+ if (CvISXSUB(proto)) {
+  CvXSUB(cv)       = CvXSUB(proto);
+  CvXSUBANY(cv)    = CvXSUBANY(proto);
+ } else {
+  OP_REFCNT_LOCK;
+  CvROOT(cv)       = OpREFCNT_inc(CvROOT(proto));
+  OP_REFCNT_UNLOCK;
+  CvSTART(cv)      = CvSTART(proto);
+ }
  CvOUTSIDE(cv)     = CvOUTSIDE(proto);
 #ifdef CVf_WEAKOUTSIDE
  if (!(CvFLAGS(proto) & CVf_WEAKOUTSIDE))
@@ -1330,12 +1396,17 @@ STATIC I32 su_uplevel(pTHX_ CV *callback, I32 cxix, I32 args) {
 
  SU_UPLEVEL_SAVE(op, (OP *) &sub_op);
 
+ sud->old_runops = PL_runops;
+
  sud->old_catch = CATCH_GET;
  CATCH_SET(TRUE);
 
  if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX))) {
   PERL_CONTEXT *sub_cx = cxstack + cxstack_ix;
 
+  /* If pp_entersub() returns a non-null OP, it means that the callback is not
+   * an XSUB. */
+
   sud->callback = MUTABLE_CV(SvREFCNT_inc(callback));
   CvDEPTH(callback)++;
 
@@ -1356,15 +1427,24 @@ STATIC I32 su_uplevel(pTHX_ CV *callback, I32 cxix, I32 args) {
    SvREFCNT_inc_simple_void(sub_cx->blk_sub.argarray);
   }
 
-  CALLRUNOPS(aTHX);
+  if (su_uplevel_goto_static(CvROOT(renamed))) {
+   if (PL_runops != Perl_runops_standard) {
+    if (PL_runops == Perl_runops_debug) {
+     if (PL_debug)
+      croak("uplevel() can't execute code that calls goto when debugging flags are set");
+    } else if (PL_runops != su_uplevel_goto_runops)
+     croak("uplevel() can't execute code that calls goto with a custom runloop");
+   }
+
+   PL_runops = su_uplevel_goto_runops;
+  }
 
-  ret = PL_stack_sp - (PL_stack_base + new_mark);
+  CALLRUNOPS(aTHX);
  }
 
  sud->died = 0;
 
- SPAGAIN;
-
+ ret = PL_stack_sp - (PL_stack_base + new_mark);
  if (ret > 0) {
   AV *old_stack = sud->old_curstackinfo->si_stack;
 
@@ -1379,8 +1459,6 @@ STATIC I32 su_uplevel(pTHX_ CV *callback, I32 cxix, I32 args) {
   AvFILLp(old_stack) += ret;
  }
 
- PUTBACK;
-
  LEAVE;
 
  return ret;
@@ -1420,6 +1498,7 @@ STATIC void su_setup(pTHX) {
  MY_CXT.unwind_storage.proxy_op.op_type   = OP_STUB;
  MY_CXT.unwind_storage.proxy_op.op_ppaddr = NULL;
 
+ MY_CXT.uplevel_storage.top   = NULL;
  MY_CXT.uplevel_storage.root  = NULL;
  MY_CXT.uplevel_storage.count = 0;
 
@@ -1558,6 +1637,7 @@ PROTOTYPE: DISABLE
 PPCODE:
  {
   MY_CXT_CLONE;
+  MY_CXT.uplevel_storage.top   = NULL;
   MY_CXT.uplevel_storage.root  = NULL;
   MY_CXT.uplevel_storage.count = 0;
  }