B::perlstring - add support for \e (Fix #17526)

In daf6caf1ef25ff48f871fa1e53adcefc11bf1d08 karl made pv_uni_display()
use the available mnemonic escapes instead of using \x{} style escapes.

This broke B::perlstring() which has an exclusion list of such escapes
to passthrough, and it did not know about \e, so it produced "\\e"
instead of "\e", which of course does not round trip.

This in turn broke Sub::Quote, which in turn breaks Moo, which breaks
a lot of stuff. :-)

Unfortunately B::perlstring() had no tests to detect this, so we only
found out when we got a BBC report that happened to also ticklet this
bug.

This patch adds 'e' to the exclusion list, and also adds tests to see
that the the first 1024 unicode codepoints and all 255 non-unicode
codepoints can round trip through B::perlstring().

This should resolve #17526 and indirectly help us close #17245.

With this patch we bump B.pm to v1.80

4 files changed, 44 insertions, 2 deletions

diff --git a/MANIFEST b/MANIFEST
index 00acbbfc35..1bbab6c850 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -4108,6 +4108,7 @@ ext/B/t/optree_sort.t		inplace sort optimization regression
 ext/B/t/optree_specials.t	BEGIN, END, etc code
 ext/B/t/optree_varinit.t	my,our,local var init optimization
 ext/B/t/OptreeCheck.pm		optree comparison tool
+ext/B/t/perlstring.t	See if B::perlstring output roundtrips properly
 ext/B/t/pragma.t	See if user pragmas work.
 ext/B/t/showlex.t	See if B::ShowLex works
 ext/B/t/strict.t	See if B works with strict and warnings.
diff --git a/ext/B/B.pm b/ext/B/B.pm
index f199a0532a..80c7f858ee 100644
--- a/ext/B/B.pm
+++ b/ext/B/B.pm
@@ -20,7 +20,7 @@ sub import {
 # walkoptree comes from B.xs
 
 BEGIN {
-    $B::VERSION = '1.79';
+    $B::VERSION = '1.80';
     @B::EXPORT_OK = ();
 
     # Our BOOT code needs $VERSION set, and will append to @EXPORT_OK.
diff --git a/ext/B/B.xs b/ext/B/B.xs
index b3d04b8e6a..8a4126545b 100644
--- a/ext/B/B.xs
+++ b/ext/B/B.xs
@@ -258,7 +258,7 @@ cstring(pTHX_ SV *sv, bool perlstyle)
 		sv_catpvs(sstr, "\\@");
 	    else if (*s == '\\')
 	    {
-		if (memCHRs("nrftabx\\",*(s+1)))
+                if (memCHRs("nrftaebx\\",*(s+1)))
 		    sv_catpvn(sstr, s++, 2);
 		else
 		    sv_catpvs(sstr, "\\\\");
diff --git a/ext/B/t/perlstring.t b/ext/B/t/perlstring.t
new file mode 100644
index 0000000000..107a8d7b1b
--- /dev/null
+++ b/ext/B/t/perlstring.t
@@ -0,0 +1,41 @@
+#!./perl
+
+BEGIN {
+    unshift @INC, 't';
+    require Config;
+    if (($Config::Config{'extensions'} !~ /\bB\b/) ){
+        print "1..0 # Skip -- Perl configured without B module\n";
+        exit 0;
+    }
+}
+
+$|  = 1;
+use warnings;
+use strict;
+BEGIN  {
+    eval { require threads; threads->import; }
+}
+use Test::More;
+
+BEGIN { use_ok( 'B' ); }
+
+for my $do_utf8 (""," utf8") {
+    my $max = $do_utf8 ? 1024  : 255;
+    my @bad;
+    for my $cp ( 0 .. $max ) {
+        my $char= chr($cp);
+        utf8::upgrade($char);
+        my $escaped= B::perlstring($char);
+        my $evalled= eval $escaped;
+        push @bad, [ $cp, $evalled, $char, $escaped ] if $evalled ne $char;
+    }
+    is(0+@bad, 0, "Check if any$do_utf8 codepoints fail to round trip through B::perlstring()");
+    if (@bad) {
+        foreach my $tuple (@bad) {
+            my ( $cp, $evalled, $char, $escaped ) = @$tuple;
+            is($evalled, $char, "check if B::perlstring of$do_utf8 codepoint $cp round trips ($escaped)");
+        }
+    }
+}
+
+done_testing();