Fix calling goto to replace an uplevel'd subroutine frame

diff --git a/Upper.xs b/Upper.xs
index 9ab1eaad745b124bd14672ed000951b917553e7e..bdeac4e2f578f88d28a1089f8fc87f0b75bc5599 100644 (file)
--- a/Upper.xs
+++ b/Upper.xs
@@ -202,6 +202,7 @@ typedef struct {
 
  CV  *callback;
  CV  *renamed;
+ AV  *args;
 
  PERL_SI *si;
  PERL_SI *old_curstackinfo;
@@ -211,6 +212,10 @@ typedef struct {
 
  bool old_catch;
  OP  *old_op;
+
+ OP  *goto_op;
+ CV  *goto_code;
+ U32  goto_perldb;
 } su_uplevel_ud;
 
 STATIC su_uplevel_ud *su_uplevel_ud_new(pTHX) {
@@ -1225,6 +1230,156 @@ STATIC CV *su_cv_clone(pTHX_ CV *proto, GV *gv) {
  return cv;
 }
 
+#if SU_HAS_PERL(5, 8, 0)
+
+STATIC int su_uplevel_guard_free(pTHX_ SV *sv, MAGIC *mg) {
+ MAGIC         *omg = (MAGIC *)          mg->mg_ptr;
+ su_uplevel_ud *sud = (su_uplevel_ud *) omg->mg_ptr;
+ AV *args;
+
+ /* This code should be triggered by the FREETMPS in the first
+  * nextstate/dbstate op of the goto'd code. Its job is to reset the sub
+  * arguments to what the uplevel'd code was called with. */
+
+ if (PL_op != CvSTART(sud->goto_code))
+  croak("su_uplevel_guard_free() was called at an incorrect time");
+ sud->goto_code = NULL;
+
+ /* get_db_sub() has called save_item() on the SV member of the fake GV we
+  * used to replace PL_DBsub, so we can't kill it yet. Since set magic will
+  * be called when the item is restored, we save the fake GV so that we can
+  * correctly drop its refcount just after the restore. */
+ omg->mg_obj = MUTABLE_SV(PL_DBsub);
+ PL_DBsub    = NULL;
+
+ args = sud->args;
+ if (args) {
+  PERL_CONTEXT *cx;
+  I32 items = AvFILLp(args);
+  AV *argarray;
+  dSP;
+
+  EXTEND(SP, items + 2);
+  Copy(AvARRAY(args), SP + 1, items + 1, SV *);
+
+  cx       = cxstack + cxstack_ix;
+  argarray = cx->blk_sub.argarray;
+  av_extend(argarray, items);
+  Copy(AvARRAY(args), AvARRAY(argarray), items + 1, SV *);
+  AvFILLp(argarray) = items;
+ }
+
+ return 0;
+}
+
+STATIC MGVTBL su_uplevel_guard_vtbl = {
+ 0,
+ 0,
+ 0,
+ 0,
+ su_uplevel_guard_free
+};
+
+STATIC int su_uplevel_dbsv_get(pTHX_ SV *sv, MAGIC *mg) {
+ su_uplevel_ud *sud = (su_uplevel_ud *) mg->mg_ptr;
+ SV *guard;
+
+ /* This code should be called at the very end of pp_goto, after the
+  * SAVETMPS enclosing the sub was isseud and the blk_sub.cv member is set.
+  * It creates a magical mortal guard that will be destroyed soon at the next
+  * FREETMPS. */
+
+ if (PL_op != sud->goto_op)
+  croak("su_uplevel_dbsv_get() was called at an incorrect time");
+ sud->goto_op   = NULL;
+
+ sud->goto_code = cxstack[cxstack_ix].blk_sub.cv;
+ PL_perldb      = sud->goto_perldb;
+
+ guard = sv_newmortal();
+ sv_magicext(guard, 0, PERL_MAGIC_ext, &su_uplevel_guard_vtbl,
+                       (const char *) mg, 0);
+
+ return 0;
+}
+
+STATIC int su_uplevel_dbsv_set(pTHX_ SV *sv, MAGIC *mg) {
+ su_uplevel_ud *sud = (su_uplevel_ud *) mg->mg_ptr;
+ SV *guard;
+
+ /* This handler is supposed to be executed when the saved GvSV(PL_DBsub)
+  * is restored, which happens when the goto'd code terminates. Its aim is
+  * just to clean up after our hack. */
+
+ if (sud->goto_op)
+  croak("su_uplevel_dbsv_set() called before su_uplevel_dbsv_get");
+ if (sud->goto_code)
+  croak("su_uplevel_dbsv_set() called before su_uplevel_goto_2_free");
+
+ /* Don't free the current magical SV right now, because the mg_*() calls above
+  * us may still need it. */
+ sv_2mortal(sv);
+ SvREFCNT_dec(mg->mg_obj);
+
+ return 0;
+}
+
+STATIC MGVTBL su_uplevel_dbsv_vtbl = {
+ su_uplevel_dbsv_get,
+ su_uplevel_dbsv_set,
+ 0,
+ 0,
+ 0
+};
+
+#ifndef GvSVn
+# ifdef PERL_DONT_CREATE_GVSV
+#  define GvSVn(gv)       (*(GvGP(gv)->gp_sv ? \
+                           &(GvGP(gv)->gp_sv) : \
+                           &(GvGP(gv_SVadd(gv))->gp_sv)))
+# else
+#  define GvSVn(gv)       GvSV(gv)
+# endif
+#endif
+
+STATIC void su_uplevel_goto_handler(pTHX_ void *ud_) {
+ su_uplevel_ud *sud = ud_;
+
+ if (PL_op && PL_op->op_type == OP_GOTO && !PL_DBsub) {
+  SV *dbsv;
+
+  sud->goto_op     = PL_op;
+  sud->goto_code   = NULL;
+  sud->goto_perldb = PL_perldb;
+
+  PL_DBsub  = (GV *) newSV(0);
+  gv_init(PL_DBsub, NULL, "", 0, 0);
+  PL_perldb = PERLDBf_SUB;
+
+  dbsv = GvSVn(PL_DBsub);
+  sv_magicext(dbsv, NULL, PERL_MAGIC_ext, &su_uplevel_dbsv_vtbl,
+                          (const char *) sud, 0);
+  SvREFCNT_inc(dbsv);
+ }
+}
+
+#else /* SU_HAS_PERL(5, 8, 0) */
+
+STATIC void su_uplevel_goto_handler(pTHX_ void *ud_) {
+ su_uplevel_ud *sud = ud_;
+
+ if (PL_op && PL_op->op_type == OP_GOTO) {
+  /* Don't let the last sub context in an mixed state while we throw an
+   * exception, as this may cause double free errors (the blk_sub.cv member
+   * is still the renamed CV). Let our su_uplevel_restore() properly handle the
+   * destruction. */
+  cxstack[cxstack_ix].blk_sub.cv = NULL;
+  croak("Can't goto to an uplevel'd stack frame on perl 5.6");
+ }
+}
+
+#endif /* !SU_HAS_PERL(5, 8, 0) */
+
 STATIC I32 su_uplevel(pTHX_ CV *callback, I32 cxix, I32 args) {
 #define su_uplevel(C, I, A) su_uplevel(aTHX_ (C), (I), (A))
  su_uplevel_ud *sud;
@@ -1254,6 +1409,7 @@ STATIC I32 su_uplevel(pTHX_ CV *callback, I32 cxix, I32 args) {
  sud->died     = 1;
  sud->callback = NULL;
  sud->renamed  = NULL;
+ sud->args     = NULL;
  SAVEDESTRUCTOR_X(su_uplevel_restore, sud);
 
  si = sud->si;
@@ -1355,6 +1511,9 @@ STATIC I32 su_uplevel(pTHX_ CV *callback, I32 cxix, I32 args) {
   } else {
    SvREFCNT_inc_simple_void(sub_cx->blk_sub.argarray);
   }
+  sud->args = GvAV(PL_defgv);
+
+  SAVEDESTRUCTOR_X(su_uplevel_goto_handler, sud);
 
   CALLRUNOPS(aTHX);
 

diff --git a/lib/Scope/Upper.pm b/lib/Scope/Upper.pm
index 189bc6c400d179a1148ef36e6b0824968e131d4e..ebe24a1b1dc534754f43af4b1227704e7cff26b7 100644 (file)
--- a/lib/Scope/Upper.pm
+++ b/lib/Scope/Upper.pm
@@ -520,6 +520,9 @@ 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 does not work reliably on perl 5.6 yet.
+An exception will be thrown to prevent you from doing so.
+
 =head1 DEPENDENCIES
 
 L<XSLoader> (standard since perl 5.006).

diff --git a/t/61-uplevel-args.t b/t/61-uplevel-args.t
index d4ee2edde3bd5829735a1a844776689e2071d2cf..5ef1f8324c09785ad09a6156ef255ac5b0e63ba6 100644 (file)
--- a/t/61-uplevel-args.t
+++ b/t/61-uplevel-args.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 9 + 4 * 7 + 3 + 2 + 6;
+use Test::More tests => 9 + 4 * 7 + 3 + ((5 * 4 * 4) * 3 + 1) + 2 + 6;
 
 use Scope::Upper qw<uplevel HERE>;
 
@@ -144,6 +144,94 @@ sub {
  is $s, 'xyz', 'aliasing, two layers 2';
 }->('dummy');
 
+# goto
+
+SKIP: {
+ if ("$]" < 5.008) {
+  my $cb = sub { fail "should not be executed" };
+  local $@;
+  eval { sub { uplevel { goto $cb } HERE }->() };
+  like $@, qr/^Can't goto to an uplevel'd stack frame on perl 5\.6/,
+           "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' ],      [ ]          ],
+  [ [ 'b' ],      [ 'n' ]      ],
+  [ [ 'c' ],      [ 'o', 'p' ] ],
+  [ [ 'd', 'e' ], [ 'q' ]      ],
+ );
+
+ for my $args (@args) {
+  my ($out, $in) = @$args;
+
+  my @out  = @$out;
+  my @in   = @$in;
+
+  for my $reify_out (0, 1) {
+   for my $reify_in (0, 1) {
+    my $desc;
+
+    my $base_test = sub {
+     if ($reify_in) {
+      is_deeply \@_, $in, "$desc: \@_ inside";
+     } else {
+      is "@_", "@in", "$desc: \@_ inside";
+     }
+    };
+
+    my $goto_test         = sub { goto $base_test };
+    my $uplevel_test      = sub { &uplevel($base_test, @_, HERE) };
+    my $goto_uplevel_test = sub { &uplevel($goto_test, @_, HERE) };
+
+    my @tests = (
+     [ 'goto'                    => sub { goto $base_test }         ],
+     [ 'goto in goto'            => sub { goto $goto_test }         ],
+     [ 'uplevel in goto'         => sub { goto $uplevel_test }      ],
+     [ 'goto in uplevel in goto' => sub { goto $goto_uplevel_test } ],
+    );
+
+    for my $test (@tests) {
+     ($desc, my $cb) = @$test;
+     $desc .= ' (' . @out . ' out, ' . @in . ' in';
+     $desc .= ', reify out' if $reify_out;
+     $desc .= ', reify in'  if $reify_in;
+     $desc .= ')';
+
+     local $@;
+     eval {
+      sub {
+       &uplevel($cb, @in, HERE);
+       if ($reify_out) {
+        is_deeply \@_, $out, "$desc: \@_ outside";
+       } else {
+        is "@_", "@out", "$desc: \@_ outside";
+       }
+      }->(@out);
+     };
+     is $@, '', "$desc: no error";
+    }
+   }
+  }
+ }
+
+ sub {
+  my $s  = 'caesar';
+  my $cb = sub {
+   $_[0] = 'brutus';
+  };
+  sub {
+   uplevel {
+    goto $cb;
+   } $_[0], HERE;
+  }->($s);
+  is $s, 'brutus', 'aliasing and goto';
+ }->('dummy');
+}
+
 # Magic
 
 {