stop ~ in format modifying format string

Currently, the format parser converts ~ or ~~ in a format string into
blank spaces. Since the previous-but-one commit, it only does it in a copy
rather than the original string, but this still defeats the "if the string
is the same don't recompile" mechanism.

Fix this by leaving the ~ alone in the format string, but instead cause
FF_LITERAL to convert '~' to ' ' when appending to the target.

Also, in S_doparseform(), improve the processing of '~~': previously
it only skipped one '~', and processed the second '~' on the next loop;
this happened to work, but it's less unexpected to process both chars at
once.

I've also added some tests, but these don't actually test whether the
format gets re-compiled: I couldn't think of a way to do that short of
checking the output of perl -Df. Instead the tests I added were based
around making sure I didn't break anything related to ~~ formatting.

I also improved the description string for some of the existing tests.

1 files changed, 31 insertions, 4 deletions

diff --git a/t/op/write.t b/t/op/write.t
index d436730959..646143d529 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 + 6 + 2 + 1 + 1;
+my $bug_tests = 4 + 3 * 3 * 5 * 2 * 3 + 2 + 66 + 2 + 1 + 1;
 
 # number of tests in section 4
 my $hmb_tests = 35;
@@ -542,9 +542,13 @@ for my $tref ( @NumTests ){
 			  "$base\nMoo!\n",) {
 	foreach (['^*', qr/(.+)/], ['@*', qr/(.*?)$/s]) {
 	  my ($format, $re) = @$_;
+	  $format = "1^*2 3${format}4";
 	  foreach my $class ('', 'Count') {
-	    my $name = "$first, $second $format $class";
+	    my $name = qq{swrite("$format", "$first", "$second") class="$class"};
 	    $name =~ s/\n/\\n/g;
+	    $name =~ s{(.)}{
+			ord($1) > 126 ? sprintf("\\x{%x}",ord($1)) : $1
+		    }ge;
 
 	    $first =~ /(.+)/ or die $first;
 	    my $expect = "1${1}2";
@@ -555,12 +559,12 @@ for my $tref ( @NumTests ){
 	      my $copy1 = $first;
 	      my $copy2;
 	      tie $copy2, $class, $second;
-	      is swrite("1^*2 3${format}4", $copy1, $copy2), $expect, $name;
+	      is swrite("$format", $copy1, $copy2), $expect, $name;
 	      my $obj = tied $copy2;
 	      is $obj->[1], 1, 'value read exactly once';
 	    } else {
 	      my ($copy1, $copy2) = ($first, $second);
-	      is swrite("1^*2 3${format}4", $copy1, $copy2), $expect, $name;
+	      is swrite("$format", $copy1, $copy2), $expect, $name;
 	    }
 	  }
 	}
@@ -654,6 +658,29 @@ ok  defined *{$::{CmT}}{FORMAT}, "glob assign";
     $^A ='';
     ::is $format, $orig, "RT91032: don't overwrite orig format string";
 
+    # check that ~ and ~~ are displayed correctly as whitespace,
+    # under the influence of various different types of border
+
+    for my $n (1,2) {
+	for my $lhs (' ', 'Y', '^<<<', '^|||', '^>>>') {
+	    for my $rhs ('', ' ', 'Z', '^<<<', '^|||', '^>>>') {
+		my $fmt = "^<B$lhs" . ('~' x $n) . "$rhs\n";
+		my $sfmt = ($fmt =~ s/~/ /gr);
+		my ($a, $bc, $stop);
+		($a, $bc, $stop) = ('a', 'bc', 's');
+		# $stop is to stop '~~' deleting the whole line
+		formline $sfmt, $stop, $a, $bc;
+		my $exp = $^A;
+		$^A = '';
+		($a, $bc, $stop) = ('a', 'bc', 's');
+		formline $fmt, $stop, $a, $bc;
+		my $got = $^A;
+		$^A = '';
+		$fmt =~ s/\n/\\n/;
+		::is($got, $exp, "chop munging: [$fmt]");
+	    }
+	}
+    }
 }