In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/d8ef3a16edf6875955d642f8f57ad55bddac9c71?hp=a2a7e1732d227dd914f1a6e647809f4180de0b83>
- Log ----------------------------------------------------------------- commit d8ef3a16edf6875955d642f8f57ad55bddac9c71 Author: David Mitchell <[email protected]> Date: Tue Jun 14 14:21:56 2011 +0100 [perl #8611] tied handles and gotos don't mix tied handle method calls, unlike other types of tie, don't push a new stack. This means that a goto within a method to an outer scope "succeeds", and pops back the context stack past the method call. When control (at the C level) eventually passes back to the return from call_method(), we've lost all our relevant stack contents (like all the ENTERs), and corruption ensures. The fix is to add PUSHSTACKi/POPSTACK. The side effect of this is that attempts to goto out of a tied handle method call now give "Can't find label" errors, like non-handle methods already do. ----------------------------------------------------------------------- Summary of changes: pp_sys.c | 22 ++++++++++++++++++++-- t/op/tie.t | 32 ++++++++++++++++++++++++++++++++ 2 files changed, 52 insertions(+), 2 deletions(-) diff --git a/pp_sys.c b/pp_sys.c index 106a443..6ef266f 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -511,6 +511,9 @@ OP * Perl_tied_method(pTHX_ const char *const methname, SV **sp, SV *const sv, const MAGIC *const mg, const U32 flags, U32 argc, ...) { + SV **orig_sp = sp; + I32 ret_args; + PERL_ARGS_ASSERT_TIED_METHOD; /* Ensure that our flag bits do not overlap. */ @@ -518,10 +521,15 @@ Perl_tied_method(pTHX_ const char *const methname, SV **sp, SV *const sv, assert((TIED_METHOD_ARGUMENTS_ON_STACK & G_WANT) == 0); assert((TIED_METHOD_SAY & G_WANT) == 0); + PUTBACK; /* sp is at *foot* of args, so this pops args from old stack */ + PUSHSTACKi(PERLSI_MAGIC); + EXTEND(SP, argc+1); /* object + args */ PUSHMARK(sp); PUSHs(SvTIED_obj(sv, mg)); - if (flags & TIED_METHOD_ARGUMENTS_ON_STACK) + if (flags & TIED_METHOD_ARGUMENTS_ON_STACK) { + Copy(orig_sp + 2, sp + 1, argc, SV*); /* copy args to new stack */ sp += argc; + } else if (argc) { const U32 mortalize_not_needed = flags & TIED_METHOD_MORTALIZE_NOT_NEEDED; @@ -544,7 +552,17 @@ Perl_tied_method(pTHX_ const char *const methname, SV **sp, SV *const sv, SAVEGENERICSV(PL_ors_sv); PL_ors_sv = newSVpvs("\n"); } - call_method(methname, flags & G_WANT); + ret_args = call_method(methname, flags & G_WANT); + SPAGAIN; + orig_sp = sp; + POPSTACK; + SPAGAIN; + if (ret_args) { /* copy results back to original stack */ + EXTEND(sp, ret_args); + Copy(orig_sp - ret_args + 1, sp + 1, ret_args, SV*); + sp += ret_args; + PUTBACK; + } LEAVE_with_name("call_tied_method"); return NORMAL; } diff --git a/t/op/tie.t b/t/op/tie.t index a4f969a..0813791 100644 --- a/t/op/tie.t +++ b/t/op/tie.t @@ -1040,3 +1040,35 @@ TIEHANDLE TIESCALAR ok 1 ok 2 +######## + +# RT #8611 mustn't goto outside the magic stack +sub TIESCALAR { warn "tiescalar\n"; bless [] } +sub FETCH { warn "fetch()\n"; goto FOO; } +tie $f, ""; +warn "before fetch\n"; +my $a = "$f"; +warn "before FOO\n"; +FOO: +warn "after FOO\n"; +EXPECT +tiescalar +before fetch +fetch() +Can't find label FOO at - line 4. +######## + +# RT #8611 mustn't goto outside the magic stack +sub TIEHANDLE { warn "tiehandle\n"; bless [] } +sub PRINT { warn "print()\n"; goto FOO; } +tie *F, ""; +warn "before print\n"; +print F "abc"; +warn "before FOO\n"; +FOO: +warn "after FOO\n"; +EXPECT +tiehandle +before print +print() +Can't find label FOO at - line 4. -- Perl5 Master Repository
