Slight tweaks to regexp tests so that they still produce sane TAP with test.pl

Explicitly escape non-printable characters in test descriptions, instead of
relying on some part of the TAP generation code to do so. Use diag() instead of
passing 3 arguments to ok(). Add a mininal diag() implementation to ReTest.pl

4 files changed, 34 insertions, 30 deletions

diff --git a/t/re/ReTest.pl b/t/re/ReTest.pl
index b4338a6e1a..2d77a1c8fb 100644
--- a/t/re/ReTest.pl
+++ b/t/re/ReTest.pl
@@ -154,6 +154,10 @@ sub isneq ($$;$) {
 *is = \&iseq;
 *isnt = \&isneq;
 
+sub diag {
+    print STDERR "# $_[0]\n";
+}
+
 sub like ($$$) {
     my (undef, $expected, $name) = @_;
     my ($pass, $error);
diff --git a/t/re/pat.t b/t/re/pat.t
index e260af47f6..1cd801e67b 100644
--- a/t/re/pat.t
+++ b/t/re/pat.t
@@ -33,26 +33,26 @@ run_tests() unless caller;
 sub run_tests {
 
     {
-
         my $x = "abc\ndef\n";
+	(my $x_pretty = $x) =~ s/\n/\\n/g;
 
-        ok $x =~ /^abc/,  qq ["$x" =~ /^abc/];
-        ok $x !~ /^def/,  qq ["$x" !~ /^def/];
+        ok $x =~ /^abc/,  qq ["$x_pretty" =~ /^abc/];
+        ok $x !~ /^def/,  qq ["$x_pretty" !~ /^def/];
 
         # used to be a test for $*
-        ok $x =~ /^def/m, qq ["$x" =~ /^def/m];
+        ok $x =~ /^def/m, qq ["$x_pretty" =~ /^def/m];
 
-        nok $x =~ /^xxx/, qq ["$x" =~ /^xxx/];
-        nok $x !~ /^abc/, qq ["$x" !~ /^abc/];
+        nok $x =~ /^xxx/, qq ["$x_pretty" =~ /^xxx/];
+        nok $x !~ /^abc/, qq ["$x_pretty" !~ /^abc/];
 
-         ok $x =~ /def/, qq ["$x" =~ /def/];
-        nok $x !~ /def/, qq ["$x" !~ /def/];
+         ok $x =~ /def/, qq ["$x_pretty" =~ /def/];
+        nok $x !~ /def/, qq ["$x_pretty" !~ /def/];
 
-         ok $x !~ /.def/, qq ["$x" !~ /.def/];
-        nok $x =~ /.def/, qq ["$x" =~ /.def/];
+         ok $x !~ /.def/, qq ["$x_pretty" !~ /.def/];
+        nok $x =~ /.def/, qq ["$x_pretty" =~ /.def/];
 
-         ok $x =~ /\ndef/, qq ["$x" =~ /\ndef/];
-        nok $x !~ /\ndef/, qq ["$x" !~ /\ndef/];
+         ok $x =~ /\ndef/, qq ["$x_pretty" =~ /\\ndef/];
+        nok $x !~ /\ndef/, qq ["$x_pretty" !~ /\\ndef/];
     }
 
     {
@@ -84,7 +84,7 @@ sub run_tests {
 
     {
         # used to be a test for $*
-        ok "ab\ncd\n" =~ /^cd/m, qq ["ab\ncd\n" =~ /^cd/m];
+        ok "ab\ncd\n" =~ /^cd/m, q ["ab\ncd\n" =~ /^cd/m];
     }
 
     {
@@ -444,7 +444,7 @@ sub run_tests {
 	my $res = eval { "xx" =~ /(?$code)/o };
 	{
 	    no warnings 'uninitialized';
-	    my $message = "$message '$@', '$res', '$blah'";
+	    chomp $@; my $message = "$message '$@', '$res', '$blah'";
 	    ok($@ && $@ =~ /not allowed at runtime/ && $blah == 12, $message);
 	}
 
@@ -966,11 +966,11 @@ sub run_tests {
         sub new {bless []}
 
         my $message  = "Ref stringification";
-      ::ok(do { \my $v} =~ /^SCALAR/,   "Scalar ref stringification", $message);
-      ::ok(do {\\my $v} =~ /^REF/,      "Ref ref stringification", $message);
-      ::ok([]           =~ /^ARRAY/,    "Array ref stringification", $message);
-      ::ok({}           =~ /^HASH/,     "Hash ref stringification", $message);
-      ::ok('S' -> new   =~ /^Object S/, "Object stringification", $message);
+      ::ok(do { \my $v} =~ /^SCALAR/,   "Scalar ref stringification") or diag($message);
+      ::ok(do {\\my $v} =~ /^REF/,      "Ref ref stringification") or diag($message);
+      ::ok([]           =~ /^ARRAY/,    "Array ref stringification") or diag($message);
+      ::ok({}           =~ /^HASH/,     "Hash ref stringification") or diag($message);
+      ::ok('S' -> new   =~ /^Object S/, "Object stringification") or diag($message);
     }
 
 
diff --git a/t/re/pat_advanced.t b/t/re/pat_advanced.t
index 82b3f63648..8eb872dc11 100644
--- a/t/re/pat_advanced.t
+++ b/t/re/pat_advanced.t
@@ -1042,7 +1042,7 @@ sub run_tests {
 
         undef $w;
         eval q [ok "\0" !~ /[\N{EMPTY-STR}XY]/,
-                   "Zerolength charname in charclass doesn't match \\0"];
+                   "Zerolength charname in charclass doesn't match \\\\0"];
         ok $w && $w =~ /Ignoring zero length/,
                  'Ignoring zero length \N{} in character class warning';
 
@@ -1475,8 +1475,8 @@ sub run_tests {
         ok "\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{Uppercase}/i,  "i =~ Uppercase under /i";
         ok "\N{SMALL ROMAN NUMERAL ONE}" !~ /\p{Titlecase}/,  "i !~ Titlecase";
         ok "\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{Titlecase}/i,  "i =~ Titlecase under /i";
-        ok "\N{ROMAN NUMERAL ONE}" =~ /\p{Lowercase}/i,  "I =~ Lowercase under
-        /i";
+        ok "\N{ROMAN NUMERAL ONE}" =~ /\p{Lowercase}/i,  "I =~ Lowercase under /i";
+
         ok "\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{Lowercase}/,  "i =~ Lowercase";
         ok "\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{IDStart}/,    "i =~ ID_Start";
         ok "\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{IDContinue}/, "i =~ ID_Continue"
diff --git a/t/re/pat_rt_report.t b/t/re/pat_rt_report.t
index a115264e7c..33ab876270 100644
--- a/t/re/pat_rt_report.t
+++ b/t/re/pat_rt_report.t
@@ -147,7 +147,7 @@ sub run_tests {
 
         # Amazingly vertical tabulator is the same in ASCII and EBCDIC.
         for ("\n", "\t", "\014", "\r") {
-            unlike($_, qr/[[:print:]]/, "'$_' not in [[:print:]]; Bug 20010619.003");
+            unlike($_, qr/[[:print:]]/, sprintf "\\%03o not in [[:print:]]; Bug 20010619.003", ord $_);
         }
         for (" ") {
             like($_, qr/[[:print:]]/, "'$_' in [[:print:]]; Bug 20010619.003");
@@ -232,10 +232,10 @@ sub run_tests {
         $num =~ /\d/;
         for (0 .. 1) {
             my $match = m?? + 0;
-            ok $match != $_, $message, 
-                sprintf "'match one' %s on %s iteration" =>
-                               $match ? 'succeeded' : 'failed',
-                               $_     ? 'second'    : 'first';
+            ok($match != $_, $message)
+                or diag(sprintf "'match one' %s on %s iteration" =>
+			$match ? 'succeeded' : 'failed',
+			$_     ? 'second'    : 'first');
         }
         $num =~ /(\d)/;
         my $result = join "" => $num =~ //g;
@@ -251,9 +251,9 @@ sub run_tests {
             for my $len (32000, 32768, 33000) {
                 my  $s = $char . "f" x $len;
                 my  $r = $s =~ /$char([f]*)/gc;
-                ok  $r, $message, "<$type x $len>";
-                ok !$r || pos ($s) == $len + 1, $message,
-                        "<$type x $len>; pos = @{[pos $s]}";
+                ok($r, $message) or diag("<$type x $len>");
+                ok(!$r || pos ($s) == $len + 1, $message)
+		    or diag("<$type x $len>; pos = @{[pos $s]}");
             }
         }
     }