summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Dumpvalue.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Dumpvalue.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Dumpvalue.pm42
1 files changed, 33 insertions, 9 deletions
diff --git a/Master/tlpkg/tlperl/lib/Dumpvalue.pm b/Master/tlpkg/tlperl/lib/Dumpvalue.pm
index ca40548ce56..eef9b27157b 100644
--- a/Master/tlpkg/tlperl/lib/Dumpvalue.pm
+++ b/Master/tlpkg/tlperl/lib/Dumpvalue.pm
@@ -1,9 +1,20 @@
use 5.006_001; # for (defined ref) and $#$v and our
package Dumpvalue;
use strict;
-our $VERSION = '1.17';
+our $VERSION = '1.18';
our(%address, $stab, @stab, %stab, %subs);
+sub ASCII { return ord('A') == 65; }
+
+# This module will give incorrect results for some inputs on EBCDIC platforms
+# before v5.8
+*to_native = ($] lt "5.008")
+ ? sub { return shift }
+ : sub { return utf8::unicode_to_native(shift) };
+
+my $APC = chr to_native(0x9F);
+my $backslash_c_question = (ASCII) ? '\177' : $APC;
+
# documentation nits, handle complex data structures better by chromatic
# translate control chars to ^X - Randal Schwartz
# Modifications to print types by Peter Gordon v1.0
@@ -78,7 +89,8 @@ sub unctrl {
local($_) = @_;
return \$_ if ref \$_ eq "GLOB";
- s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg;
+ s/([\000-\037])/'^' . chr(to_native(ord($1)^64))/eg;
+ s/ $backslash_c_question /^?/xg;
$_;
}
@@ -95,9 +107,8 @@ sub stringify {
if $self->{bareStringify} and ref $_
and %overload:: and defined &{'overload::StrVal'};
}
-
if ($tick eq 'auto') {
- if (/[\000-\011\013-\037\177]/) {
+ if (/[^[:^cntrl:]\n]/) { # All ASCII controls but \n get '"'
$tick = '"';
} else {
$tick = "'";
@@ -107,20 +118,33 @@ sub stringify {
s/([\'\\])/\\$1/g;
} elsif ($self->{unctrl} eq 'unctrl') {
s/([\"\\])/\\$1/g ;
- s/([\000-\037\177])/'^'.pack('c',ord($1)^64)/eg;
- s/([\200-\377])/'\\0x'.sprintf('%2X',ord($1))/eg
+ $_ = &unctrl($_);
+ s/([[:^ascii:]])/'\\0x'.sprintf('%2X',ord($1))/eg
if $self->{quoteHighBit};
} elsif ($self->{unctrl} eq 'quote') {
s/([\"\\\$\@])/\\$1/g if $tick eq '"';
- s/\033/\\e/g;
- s/([\000-\037\177])/'\\c'.chr(ord($1)^64)/eg;
+ s/\e/\\e/g;
+ s/([\000-\037$backslash_c_question])/'\\c'._escaped_ord($1)/eg;
}
- s/([\200-\377])/'\\'.sprintf('%3o',ord($1))/eg if $self->{quoteHighBit};
+ s/([[:^ascii:]])/'\\'.sprintf('%3o',ord($1))/eg if $self->{quoteHighBit};
($noticks || /^\d+(\.\d*)?\Z/)
? $_
: $tick . $_ . $tick;
}
+# Ensure a resulting \ is escaped to be \\
+sub _escaped_ord {
+ my $chr = shift;
+ if ($chr eq $backslash_c_question) {
+ $chr = '?';
+ }
+ else {
+ $chr = chr(to_native(ord($chr)^64));
+ $chr =~ s{\\}{\\\\}g;
+ }
+ return $chr;
+}
+
sub DumpElem {
my ($self, $v) = (shift, shift);
my $short = $self->stringify($v, ref $v);