From: Vincent Pit Date: Fri, 16 Sep 2011 19:16:54 +0000 (+0200) Subject: Fix calling goto to replace an uplevel'd subroutine frame X-Git-Tag: v0.17~7 X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=514b3cc42d4717ad8c48f61664e18d2fe656857d;p=perl%2Fmodules%2FScope-Upper.git Fix calling goto to replace an uplevel'd subroutine frame --- diff --git a/Upper.xs b/Upper.xs index 9ab1eaa..bdeac4e 100644 --- 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 189bc6c..ebe24a1 100644 --- 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 to replace an L'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 (standard since perl 5.006). diff --git a/t/61-uplevel-args.t b/t/61-uplevel-args.t index d4ee2ed..5ef1f83 100644 --- 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; @@ -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 {