#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
-#include "perl.h"
+#include "perl.h"
#include "XSUB.h"
#define __PACKAGE__ "Scope::Upper"
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) {
}
typedef struct {
+ su_uplevel_ud *top;
su_uplevel_ud *root;
I32 count;
} su_uplevel_storage;
sud = su_uplevel_ud_new();
}
+ sud->next = MY_CXT.uplevel_storage.top;
+ MY_CXT.uplevel_storage.top = sud;
+
return 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 {
}
}
-#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]
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));
/* 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++;
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))
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)++;
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;
AvFILLp(old_stack) += ret;
}
- PUTBACK;
-
LEAVE;
return ret;
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;
PPCODE:
{
MY_CXT_CLONE;
+ MY_CXT.uplevel_storage.top = NULL;
MY_CXT.uplevel_storage.root = NULL;
MY_CXT.uplevel_storage.count = 0;
}
projects / perl / modules / Scope-Upper.git / blobdiff