fix stack handling in write() [perl #73690]

I'm not sure about that POPs at the beginning of pp_leavewrite, but it
seems to work. As far as I can tell, executing the format always leaves
an extra value on the stack, but I'm not sure where that happens
exactly, so I'm just fixing it up there.

diff --git a/pp_sys.c b/pp_sys.c
index 79ef266..2340a35 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -1379,7 +1379,7 @@ PP(pp_enterwrite)
        DIE(aTHX_ "Undefined format \"%"SVf"\" called", SVfARG(tmpsv));
     }
     IoFLAGS(io) &= ~IOf_DIDTOP;
-    return doform(cv,gv,PL_op->op_next);
+    RETURNOP(doform(cv,gv,PL_op->op_next));
 }
 
 PP(pp_leavewrite)
@@ -1394,6 +1394,12 @@ PP(pp_leavewrite)
     register PERL_CONTEXT *cx;
     OP *retop;
 
+    /* I'm not sure why, but executing the format leaves an extra value on the
+     * stack. There's probably a better place to be handling this (probably
+     * by avoiding pushing it in the first place!) but I don't quite know
+     * where to look. -doy */
+    POPs;
+
     if (!io || !(ofp = IoOFP(io)))
         goto forget_top;
 
@@ -1463,7 +1469,7 @@ PP(pp_leavewrite)
            gv_efullname4(sv, fgv, NULL, FALSE);
            DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv));
        }
-       return doform(cv, gv, PL_op);
+       RETURNOP(doform(cv, gv, PL_op));
     }
 
   forget_top:
@@ -1497,10 +1503,9 @@ PP(pp_leavewrite)
     }
     /* bad_ofp: */
     PL_formtarget = PL_bodytarget;
-    PUTBACK;
     PERL_UNUSED_VAR(newsp);
     PERL_UNUSED_VAR(gimme);
-    return retop;
+    RETURNOP(retop);
 }
 
 PP(pp_prtf)

diff --git a/t/op/write.t b/t/op/write.t
index 64831ea..b0bbc00 100644 (file)
--- a/t/op/write.t
+++ b/t/op/write.t
@@ -61,7 +61,7 @@ for my $tref ( @NumTests ){
 my $bas_tests = 20;
 
 # number of tests in section 3
-my $bug_tests = 8 + 3 * 3 * 5 * 2 * 3 + 2 + 66 + 4 + 2 + 3;
+my $bug_tests = 8 + 3 * 3 * 5 * 2 * 3 + 2 + 66 + 4 + 2 + 3 + 16;
 
 # number of tests in section 4
 my $hmb_tests = 35;
@@ -822,6 +822,56 @@ printf ">%s<\n", ref $zamm;
 print "$zamm->[0]\n";
 EOP
 
+# [perl #73690]
+
+select +(select(RT73690), do {
+    open(RT73690, '>Op_write.tmp') || die "Can't create Op_write.tmp";
+    format RT73690 =
+@<< @<<
+11, 22
+.
+
+    my @ret;
+    @ret = write;
+    is(scalar(@ret), 1);
+    ok($ret[0]);
+    @ret = scalar(write);
+    is(scalar(@ret), 1);
+    ok($ret[0]);
+    @ret = write(RT73690);
+    is(scalar(@ret), 1);
+    ok($ret[0]);
+    @ret = scalar(write(RT73690));
+    is(scalar(@ret), 1);
+    ok($ret[0]);
+
+    close RT73690 or die "Could not close: $!";
+})[0];
+
+select +(select(RT73690_2), do {
+    open(RT73690_2, '>Op_write.tmp') || die "Can't create Op_write.tmp";
+    format RT73690_2 =
+@<< @<<
+return
+.
+
+    my @ret;
+    @ret = write;
+    is(scalar(@ret), 1);
+    ok(!$ret[0]);
+    @ret = scalar(write);
+    is(scalar(@ret), 1);
+    ok(!$ret[0]);
+    @ret = write(RT73690_2);
+    is(scalar(@ret), 1);
+    ok(!$ret[0]);
+    @ret = scalar(write(RT73690_2));
+    is(scalar(@ret), 1);
+    ok(!$ret[0]);
+
+    close RT73690_2 or die "Could not close: $!";
+})[0];
+
 #############################
 ## Section 4
 ## Add new tests *above* here