This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #8611] tied handles and gotos don't mix
authorDavid Mitchell <davem@iabyn.com>
Tue, 14 Jun 2011 13:21:56 +0000 (14:21 +0100)
committerDavid Mitchell <davem@iabyn.com>
Tue, 14 Jun 2011 13:31:35 +0000 (14:31 +0100)
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.

pp_sys.c
t/op/tie.t

index 106a443..6ef266f 100644 (file)
--- 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;
 }
index a4f969a..0813791 100644 (file)
@@ -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.