From 44b7e78a9416df5de92da12988790f8e11c1b6f4 Mon Sep 17 00:00:00 2001 From: Father Chrysostomos Date: Thu, 24 May 2012 12:45:58 -0700 Subject: [PATCH] Use the same top format error for "" MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit 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. :-) --- pp_sys.c | 5 +---- t/op/write.t | 41 +++++++++++++++++++++++++++++++++++++++-- t/porting/diag.t | 1 - 3 files changed, 40 insertions(+), 7 deletions(-) diff --git a/pp_sys.c b/pp_sys.c index 0071e3b..3ddf5e2 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 4d63a98..64831ea 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 c075626..d86282a 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) -- 1.8.3.1