From: Vincent Pit <vince@profvince.com>
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/?p=perl%2Fmodules%2FScope-Upper.git;a=commitdiff_plain;h=c6e995c68b5384510061cde2d433e9506a3935f5

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<B
 Some rare oddities may still happen when running inside the debugger.
 It may help to use a perl higher than 5.8.9 or 5.10.0, as they contain some context-related fixes.
 
-Calling C<goto> to replace an L</uplevel>'d code frame does not work when a custom runloop is used or when debugging flags are set with C<perl -D>.
-In those two cases, L</uplevel> will look for a C<goto &sub> statement in its callback and, if there is one, throw an exception before executing the code.
+Calling C<goto> to replace an L</uplevel>'d code frame does not work :
+
+=over 4
+
+=item *
+
+for a C<perl> older than the 5.8 series ;
+
+=item *
+
+for a C<DEBUGGING> C<perl> run with debugging flags set (as in C<perl -D ...>) ;
+
+=item *
+
+when the runloop callback is replaced by another module.
+
+=back
+
+In those three cases, L</uplevel> will look for a C<goto &sub> statement in its callback and, if there is one, throw an exception before executing the code.
 
 Moreover, in order to handle C<goto> statements properly, L</uplevel> 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<all> the code executed as the result of the L</uplevel> call (including subroutine calls inside the callback) when a C<goto> statement is found in the L</uplevel> callback.
 Despite this shortcoming, this XS version of L</uplevel> should still run way faster than the pure-Perl version from L<Sub::Uplevel>.
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 {