Use the same top format error for ""

See also the previous commit.

2dd78f96 added the ‘Undefined top format called’ message for those
cases where a GV doesn’t have a name.  That was a bug that used to
happen with *{$io}, which can’t happen any more.

The code that 2dd78f96 added ended up changing a zero-length name to
be treated the same way as no name.  It also checked the length by
cheating and checking the first character instead.

Now that we have support for embedded nulls, that logic ends up wrong
for names like "\0foo".  And there is no need to treat "" differently
from "foo" anyway.

So this patch restores things the way they were before 2dd78f96.

It also improves the tests for ‘Undefined format’.

Writing tests for ‘Undefined top format’ was quite painful, as that
error seems to leave the internal state out of synch.  I suspect
PL_formtarget needs to be localised, or the error just needs to come
earlier in pp_leavewrite.  But I’ll save that for later, or for Dave
Mitchell. :-)

3 files changed, 40 insertions, 7 deletions

diff --git a/pp_sys.c b/pp_sys.c
index 0071e3b9cf..3ddf5e2d70 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -1452,10 +1452,7 @@ PP(pp_leavewrite)
 	if (!cv) {
 	    SV * const sv = sv_newmortal();
 	    gv_efullname4(sv, fgv, NULL, FALSE);
-	    if (SvPOK(sv) && *SvPV_nolen_const(sv))
-		DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv));
-	    else
-		DIE(aTHX_ "Undefined top format called");
+	    DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv));
 	}
 	return doform(cv, gv, PL_op);
     }
diff --git a/t/op/write.t b/t/op/write.t
index 4d63a98903..64831ead4e 100644
--- 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 = 4 + 3 * 3 * 5 * 2 * 3 + 2 + 66 + 4 + 2 + 3;
+my $bug_tests = 8 + 3 * 3 * 5 * 2 * 3 + 2 + 66 + 4 + 2 + 3;
 
 # number of tests in section 4
 my $hmb_tests = 35;
@@ -506,11 +506,48 @@ for my $tref ( @NumTests ){
     eval { write };
     like $@, qr/Undefined format ""/, 'format with 0-length name';
 
+    $~ = "\0foo";
+    eval { write };
+    like $@, qr/Undefined format "\0foo"/,
+	'no such format beginning with null';
+
     $~ = "NOSUCHFORMAT";
     eval { write };
-    like $@, qr/Undefined format/, 'no such format';
+    like $@, qr/Undefined format "NOSUCHFORMAT"/, 'no such format';
 }
 
+select +(select(OUT21), do {
+    open(OUT21, '>Op_write.tmp') || die "Can't create Op_write.tmp";
+
+    format OUT21 =
+@<<
+$_
+.
+
+    local $^ = '';
+    local $= = 1;
+    $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) };
+    like $@, qr/Undefined top format ""/, 'top format with 0-length name';
+
+    $^ = "\0foo";
+    # For some reason, we have to do this twice to get the error again.
+    $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) };
+    $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) };
+    like $@, qr/Undefined top format "\0foo"/,
+	'no such top format beginning with null';
+
+    $^ = "NOSUCHFORMAT";
+    $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) };
+    $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) };
+    like $@, qr/Undefined top format "NOSUCHFORMAT"/, 'no such top format';
+
+    # reset things;
+    eval { write(OUT21) };
+    undef $^A;
+
+    close OUT21 or die "Could not close: $!";
+})[0];
+
 {
   package Count;
 
diff --git a/t/porting/diag.t b/t/porting/diag.t
index c075626387..d86282a287 100644
--- a/t/porting/diag.t
+++ b/t/porting/diag.t
@@ -453,7 +453,6 @@ The telldir() function is not implemented on NetWare
 Too deeply nested ()-groups in %s
 Too many args on %s line of "%s"
 U0 mode on a byte string
-Undefined top format called
 Unstable directory path, current directory changed unexpectedly
 Unterminated compressed integer in unpack
 Usage: CODE(0x%x)(%s)