Data-Dumper
view release on metacpan or search on metacpan
# But otherwise use 3 digits
s/($low_controls)/'\\'.sprintf('%03o',ord($1))/eg;
# all but last branch below not supported --BEHAVIOR SUBJECT TO CHANGE--
my $high = shift || "";
if ($high eq "iso8859") { # Doesn't escape the Latin1 printables
if ($IS_ASCII) {
s/([\200-\240])/'\\'.sprintf('%o',ord($1))/eg;
}
else {
my $high_control = utf8::unicode_to_native(0x9F);
s/$high_control/sprintf('\\%o',ord($1))/eg;
}
} elsif ($high eq "utf8") {
# Some discussion of what to do here is in
# https://rt.perl.org/Ticket/Display.html?id=113088
# use utf8;
# $str =~ s/([^\040-\176])/sprintf "\\x{%04x}", ord($1)/ge;
} elsif ($high eq "8bit") {
# leave it as it is
} else {
if (len == 0 || *p < '1' || *p > '9')
return FALSE;
++p;
--len;
if (len > 8)
return FALSE;
while (len > 0) {
/* the perl code checks /\d/ but we don't want unicode digits here */
if (*p < '0' || *p > '9')
return FALSE;
++p;
--len;
}
return TRUE;
}
/* count the number of "'"s and "\"s in string */
static STRLEN
case '\b': *r++ = 'b'; break;
case '\t': *r++ = 't'; break;
case '\n': *r++ = 'n'; break;
case '\f': *r++ = 'f'; break;
case '\r': *r++ = 'r'; break;
case ESC_NATIVE: *r++ = 'e'; break;
default:
/* only ASCII digits matter here, which are invariant,
* since we only encode characters \377 and under, or
* \x177 and under for a unicode string
*/
next_is_digit = (s + 1 < send && isDIGIT(*(s+1)));
/* faster than
* r = r + my_sprintf(r, "%o", k);
*/
if (k <= 7 && !next_is_digit) {
*r++ = (char)k + '0';
} else if (k <= 63 && !next_is_digit) {
*r++ = (char)(k>>3) + '0';
parse_label|5.013007|5.013007|x
parse_listexpr|5.013008|5.013008|x
parse_lparen_question_flags|5.017009||Viu
PARSE_OPTIONAL|5.013007|5.013007|
parser_dup|5.009000|5.009000|u
parser_free|5.009005||Viu
parser_free_nexttoke_ops|5.017006||Viu
parse_stmtseq|5.013006|5.013006|x
parse_subsignature|5.031003|5.031003|x
parse_termexpr|5.013008|5.013008|x
parse_unicode_opts|5.008001||Viu
parse_uniprop_string|5.027011||Viu
PATCHLEVEL|5.003007||Viu
path_is_searchable|5.019001||Vniu
Pause|5.003007||Viu
pause|5.005000||Viu
pclose|5.003007||Viu
peep|5.003007||Viu
pending_ident|5.017004||Viu
PERL_ABS|5.008001|5.003007|p
Perl_acos|5.021004||Viu
PL_threadhook|5.008000||Viu
PL_tmps_floor|5.005000||Viu
PL_tmps_ix|5.005000||Viu
PL_tmps_max|5.005000||Viu
PL_tmps_stack|5.005000||Viu
PL_tokenbuf||5.003007|ponu
PL_top_env|5.005000||Viu
PL_toptarget|5.005000||Viu
PL_TR_SPECIAL_HANDLING_UTF8|5.031007||Viu
PL_underlying_numeric_obj|5.027009||Viu
PL_unicode|5.008001||Viu
PL_unitcheckav|5.009005||Viu
PL_unitcheckav_save|5.009005||Viu
PL_unlockhook|5.007003||Viu
PL_unsafe|5.005000||Viu
PL_UpperLatin1|5.019005||Viu
PLUS|5.003007||Viu
PL_utf8cache|5.009004||Viu
PL_utf8_charname_begin|5.017006||Viu
PL_utf8_charname_continue|5.017006||Viu
PL_utf8_foldclosures|5.013007||Viu
#endif
#ifndef PERL_PV_PRETTY_DUMP
# define PERL_PV_PRETTY_DUMP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE
#endif
#ifndef PERL_PV_PRETTY_REGPROP
# define PERL_PV_PRETTY_REGPROP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_LTGT|PERL_PV_ESCAPE_RE
#endif
/* Hint: pv_escape
* Note that unicode functionality is only backported to
* those perl versions that support it. For older perl
* versions, the implementation will fall back to bytes.
*/
#ifndef pv_escape
#if defined(NEED_pv_escape)
static char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags);
static
#else
extern char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags);
my $replacement;
if (defined $4) { # Literal
$index = ord $4;
$replacement = $4;
}
elsif (defined $3) { # backslash escape
$index = ord eval "\"$3\"";
$replacement = $3;
}
elsif (defined $2) { # Hex
$index = utf8::unicode_to_native(ord eval "\"$2\"");
# But low hex numbers are always in octal. These are all
# controls.
my $format = ($index < ord(" "))
? "\\%o"
: "\\x{%x}";
$replacement = sprintf($format, $index);
}
elsif (defined $1) { # Octal
$index = utf8::unicode_to_native(ord eval "\"$1\"");
$replacement = sprintf("\\%o", $index);
}
else {
die "Unexpected match in convert_to_native()";
}
if (defined $output[$index]) {
print STDERR "ordinal $index already has '$output[$index]'; skipping '$replacement'\n";
next;
}
local $Data::Dumper::Useqq = 1;
TEST_BOTH(q(Data::Dumper->Dumpxs(["\x000"])),
"\\ octal followed by digit",
$want);
$want = <<'EOW';
#$VAR1 = "\x{100}\0000";
EOW
local $Data::Dumper::Useqq = 1;
TEST_BOTH(q(Data::Dumper->Dumpxs(["\x{100}\x000"])),
"\\ octal followed by digit unicode",
$want);
$want = <<'EOW';
#$VAR1 = "\0\x{660}";
EOW
TEST_BOTH(q(Data::Dumper->Dumpxs(["\\x00\\x{0660}"])),
"\\ octal followed by unicode digit",
$want);
# [perl #118933 - handling of digits
$want = <<'EOW';
#$VAR1 = 0;
#$VAR2 = 1;
#$VAR3 = 90;
#$VAR4 = -10;
#$VAR5 = "010";
#$VAR6 = 112345678;
$want);
}
#############
{
# There is special code to handle the single control that in EBCDIC is
# not in the block with all the other controls, when it is UTF-8 and
# there are no variants in it (All controls in EBCDIC are invariant.)
# This tests that. There is no harm in testing this works on ASCII,
# and is better to not have split code paths.
my $outlier = chr utf8::unicode_to_native(0x9F);
my $outlier_hex = sprintf "%x", ord $outlier;
my $want = <<EOT;
#\$VAR1 = \"\\x{$outlier_hex}\";
EOT
$foo = "$outlier\x{100}";
chop $foo;
local $Data::Dumper::Useqq = 1;
TEST_BOTH (q(Data::Dumper::DumperX($foo)),
'EBCDIC outlier control: DumperX',
$want);
( run in 0.870 second using v1.01-cache-2.11-cpan-f29a10751f0 )