diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Dumpvalue.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/Dumpvalue.pm | 42 |
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); |