Deparse bug introduced by #14615: the fix is just a workaround,

I suspect there to be another deeper bug, must distill simpler
test case.

p4raw-id: //depot/perl@14693

2 files changed, 10 insertions, 7 deletions

diff --git a/ext/B/B/Deparse.pm b/ext/B/B/Deparse.pm
index 7710919453..19e798c5e0 100644
--- a/ext/B/B/Deparse.pm
+++ b/ext/B/B/Deparse.pm
@@ -3038,7 +3038,7 @@ sub re_uninterp_extended {
 # character escapes, but not delimiters that might need to be escaped
 sub escape_str { # ASCII, UTF8
     my($str) = @_;
-    $str =~ s/(.)/ord($1)>255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
+    $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
     $str =~ s/\a/\\a/g;
 #    $str =~ s/\cH/\\b/g; # \b means something different in a regex 
     $str =~ s/\t/\\t/g;
@@ -3046,8 +3046,8 @@ sub escape_str { # ASCII, UTF8
     $str =~ s/\e/\\e/g;
     $str =~ s/\f/\\f/g;
     $str =~ s/\r/\\r/g;
-    $str =~ s/([\cA-\cZ])/'\\c' . chr(ord('@') + ord($1))/ge;
-    $str =~ s/([^[:print:]])/'\\' . sprintf("%03o", ord($1))/ge;
+    $str =~ s/([\cA-\cZ])/sprintf("\\c%c", ord('@') + ord($1))/ge;
+    $str =~ s/([[:^print:]])/sprintf("\\%03o", ord($1))/ge;
     return $str;
 }
 
@@ -3055,8 +3055,8 @@ sub escape_str { # ASCII, UTF8
 # Leave whitespace unmangled.
 sub escape_extended_re {
     my($str) = @_;
-    $str =~ s/(.)/ord($1)>255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
-    $str =~ s/([^[:print:]])/'\\' . sprintf("%03o", ord($1))/ge;
+    $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
+    $str =~ s/([[:^print:]])/sprintf("\\%03o", ord($1))/ge;
     $str =~ s/\n/\n\f/g;
     return $str;
 }
@@ -3074,7 +3074,7 @@ sub re_unback {
     my($str) = @_;
 
     # the insane complexity here is due to the behaviour of "\c\"
-    $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[^[:print:]])/$1$2/g;
+    $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[[:^print:]])/$1$2/g;
     return $str;
 }
 
diff --git a/ext/B/t/deparse.t b/ext/B/t/deparse.t
index 22bd782bf7..768257a264 100644
--- a/ext/B/t/deparse.t
+++ b/ext/B/t/deparse.t
@@ -15,7 +15,7 @@ use warnings;
 use strict;
 use Config;
 
-print "1..16\n";
+print "1..17\n";
 
 use B::Deparse;
 my $deparse = B::Deparse->new() or print "not ";
@@ -184,3 +184,6 @@ $x{warn()};
 # 13
 my $foo;
 $_ .= <ARGV> . <$foo>;
+####
+# 14
+my $foo = "Ab\x{100}\200\x{200}\377Cd\000Ef\x{1000}\cA\x{2000}\cZ";