From: Vincent Pit Date: Sat, 8 Oct 2011 20:55:31 +0000 (+0200) Subject: Don't rely on accessing the values of Perl_runops_{standard,debug} X-Git-Tag: v0.18~5 X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;ds=sidebyside;h=c6e995c68b5384510061cde2d433e9506a3935f5;p=perl%2Fmodules%2FScope-Upper.git Don't rely on accessing the values of Perl_runops_{standard,debug} This doesn't work on Windows, so we have to use PL_runops_{std,dbg} instead. But those two variables are not available before perl 5.8, so we have to forbid the whole goto handling altogether on those perls for consistency. --- diff --git a/Upper.xs b/Upper.xs index b68b08f..0ae07f0 100644 --- a/Upper.xs +++ b/Upper.xs @@ -191,6 +191,8 @@ typedef struct { /* --- uplevel() data tokens and global storage ---------------------------- */ +#define SU_UPLEVEL_HIJACKS_RUNOPS SU_HAS_PERL(5, 8, 0) + typedef struct { void *next; @@ -209,7 +211,9 @@ typedef struct { COP *old_curcop; +#if SU_UPLEVEL_HIJACKS_RUNOPS runops_proc_t old_runops; +#endif bool old_catch; OP *old_op; } su_uplevel_ud; @@ -1020,6 +1024,8 @@ STATIC int su_uplevel_goto_static(const OP *o) { return 0; } +#if SU_UPLEVEL_HIJACKS_RUNOPS + STATIC int su_uplevel_goto_runops(pTHX) { #define su_uplevel_goto_runops() su_uplevel_goto_runops(aTHX) register OP *op; @@ -1076,6 +1082,8 @@ done: return 0; } +#endif /* SU_UPLEVEL_HIJACKS_RUNOPS */ + #define su_at_underscore(C) AvARRAY(AvARRAY(CvPADLIST(C))[CvDEPTH(C)])[0] STATIC void su_uplevel_restore(pTHX_ void *sus_) { @@ -1083,8 +1091,10 @@ STATIC void su_uplevel_restore(pTHX_ void *sus_) { PERL_SI *cur = sud->old_curstackinfo; PERL_SI *si = sud->si; +#if SU_UPLEVEL_HIJACKS_RUNOPS if (PL_runops == su_uplevel_goto_runops) PL_runops = sud->old_runops; +#endif if (sud->callback) { PERL_CONTEXT *cx = cxstack + sud->cxix; @@ -1396,7 +1406,9 @@ STATIC I32 su_uplevel(pTHX_ CV *callback, I32 cxix, I32 args) { SU_UPLEVEL_SAVE(op, (OP *) &sub_op); +#if SU_UPLEVEL_HIJACKS_RUNOPS sud->old_runops = PL_runops; +#endif sud->old_catch = CATCH_GET; CATCH_SET(TRUE); @@ -1428,8 +1440,9 @@ STATIC I32 su_uplevel(pTHX_ CV *callback, I32 cxix, I32 args) { } if (su_uplevel_goto_static(CvROOT(renamed))) { - if (PL_runops != Perl_runops_standard) { - if (PL_runops == Perl_runops_debug) { +#if SU_UPLEVEL_HIJACKS_RUNOPS + if (PL_runops != PL_runops_std) { + if (PL_runops == PL_runops_dbg) { 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) @@ -1437,6 +1450,9 @@ STATIC I32 su_uplevel(pTHX_ CV *callback, I32 cxix, I32 args) { } PL_runops = su_uplevel_goto_runops; +#else /* SU_UPLEVEL_HIJACKS_RUNOPS */ + croak("uplevel() can't execute code that calls goto before perl 5.8"); +#endif /* !SU_UPLEVEL_HIJACKS_RUNOPS */ } CALLRUNOPS(aTHX); diff --git a/lib/Scope/Upper.pm b/lib/Scope/Upper.pm index 377e434..6ef56c0 100644 --- a/lib/Scope/Upper.pm +++ b/lib/Scope/Upper.pm @@ -520,8 +520,25 @@ However, it's possible to hook the end of the current scope compilation with L to replace an L'd code frame does not work when a custom runloop is used or when debugging flags are set with C. -In those two cases, L will look for a C statement in its callback and, if there is one, throw an exception before executing the code. +Calling C to replace an L'd code frame does not work : + +=over 4 + +=item * + +for a C older than the 5.8 series ; + +=item * + +for a C C run with debugging flags set (as in C) ; + +=item * + +when the runloop callback is replaced by another module. + +=back + +In those three cases, L will look for a C statement in its callback and, if there is one, throw an exception before executing the code. Moreover, in order to handle C statements properly, L currently has to suffer a run-time overhead proportional to the size of the the callback in every case (with a small ratio), and proportional to the size of B the code executed as the result of the L call (including subroutine calls inside the callback) when a C statement is found in the L callback. Despite this shortcoming, this XS version of L should still run way faster than the pure-Perl version from L. diff --git a/t/61-uplevel-args.t b/t/61-uplevel-args.t index a1a72fd..8a81c21 100644 --- a/t/61-uplevel-args.t +++ b/t/61-uplevel-args.t @@ -147,7 +147,17 @@ sub { # goto -{ +SKIP: { + if ("$]" < 5.008) { + my $cb = sub { fail 'should not be executed' }; + local $@; + eval { sub { uplevel { goto $cb } HERE }->() }; + like $@, qr/^uplevel\(\) can't execute code that calls goto before perl 5\.8/, + 'goto croaks'; + skip "goto to an uplevel'd stack frame does not work on perl 5\.6" + => ((5 * 4 * 4) * 3 + 1) - 1; + } + my @args = ( [ [ ], [ 'm' ] ], [ [ 'a' ], [ ] ], @@ -225,7 +235,10 @@ sub { # goto XS -{ +SKIP: { + skip "goto to an uplevel'd stack frame does not work on perl 5\.6" => 5 + if "$]" < 5.008; + my $desc = 'uplevel() calling goto &uplevel'; local $@; eval {