diff --git a/Data-Dumper-2.154-Upgrade-to-2.158.patch b/Data-Dumper-2.154-Upgrade-to-2.158.patch new file mode 100644 index 0000000..aad23a8 --- /dev/null +++ b/Data-Dumper-2.154-Upgrade-to-2.158.patch @@ -0,0 +1,1347 @@ +From deda932ecee93bbd318efaaaf66d2860f01ccd44 Mon Sep 17 00:00:00 2001 +From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= +Date: Wed, 6 May 2015 12:49:40 +0200 +Subject: [PATCH] Upgrade to 2.158 +MIME-Version: 1.0 +Content-Type: text/plain; charset=UTF-8 +Content-Transfer-Encoding: 8bit + +Signed-off-by: Petr Písař +--- + Changes | 18 +--- + Dumper.pm | 89 ++++++++++++------ + Dumper.xs | 256 +++++++++++++++++++++++++++++++++----------------- + t/dumper.t | 297 ++++++++++++++++++++++++++++++++++------------------------ + t/quotekeys.t | 18 +++- + 5 files changed, 421 insertions(+), 257 deletions(-) + +diff --git a/Changes b/Changes +index 628ef6a..eca3bb9 100644 +--- a/Changes ++++ b/Changes +@@ -6,22 +6,6 @@ Changes - public release history for Data::Dumper + + =over 8 + +-=item 2.154 (Sep 18 2014) +- +-Most notably, this release fixes CVE-2014-4330: +- +- Don't recurse infinitely in Data::Dumper +- +- Add a configuration variable/option to limit recursion when dumping +- deep data structures. +- [...] +- This patch addresses CVE-2014-4330. This bug was found and +- reported by: LSE Leading Security Experts GmbH employee Markus +- Vervier. +- +-On top of that, there are several minor big fixes and improvements, +-see "git log" if the core perl distribution for details. +- + =item 2.151 (Mar 7 2014) + + A "useqq" implementation for the XS version of Data::Dumper. +@@ -344,7 +328,7 @@ C. + MLDBM example removed (as its own module, it has a separate CPAN + reality now). + +-Fixed bugs in handling keys with wierd characters. Perl can be ++Fixed bugs in handling keys with weird characters. Perl can be + tripped up in its implicit quoting of the word before '=>'. The + fix: C, when set, always triggers quotes + around hash keys. +diff --git a/Dumper.pm b/Dumper.pm +index 520dfd4..e884298 100644 +--- a/Dumper.pm ++++ b/Dumper.pm +@@ -10,7 +10,7 @@ + package Data::Dumper; + + BEGIN { +- $VERSION = '2.154'; # Don't forget to set version and release ++ $VERSION = '2.158'; # Don't forget to set version and release + } # date in POD below! + + #$| = 1; +@@ -37,6 +37,8 @@ BEGIN { + or $Useperl = 1; + } + ++my $IS_ASCII = ord 'A' == 65; ++ + # module vars and their defaults + $Indent = 2 unless defined $Indent; + $Purity = 0 unless defined $Purity; +@@ -222,8 +224,11 @@ sub DESTROY {} + + sub Dump { + return &Dumpxs +- unless $Data::Dumper::Useperl || (ref($_[0]) && $_[0]->{useperl}) || +- $Data::Dumper::Deparse || (ref($_[0]) && $_[0]->{deparse}); ++ unless $Data::Dumper::Useperl || (ref($_[0]) && $_[0]->{useperl}) ++ || $Data::Dumper::Deparse || (ref($_[0]) && $_[0]->{deparse}) ++ ++ # Use pure perl version on earlier releases on EBCDIC platforms ++ || (! $IS_ASCII && $] lt 5.021_010); + return &Dumpperl; + } + +@@ -724,41 +729,71 @@ my %esc = ( + "\e" => "\\e", + ); + ++my $low_controls = ($IS_ASCII) ++ ++ # This includes \177, because traditionally it has been ++ # output as octal, even though it isn't really a "low" ++ # control ++ ? qr/[\0-\x1f\177]/ ++ ++ # EBCDIC low controls. ++ : qr/[\0-\x3f]/; ++ + # put a string value in double quotes + sub qquote { + local($_) = shift; + s/([\\\"\@\$])/\\$1/g; ++ ++ # This efficiently changes the high ordinal characters to \x{} if the utf8 ++ # flag is on. On ASCII platforms, the high ordinals are all the ++ # non-ASCII's. On EBCDIC platforms, we don't include in these the non-ASCII ++ # controls whose ordinals are less than SPACE, excluded below by the range ++ # \0-\x3f. On ASCII platforms this range just compiles as part of :ascii:. ++ # On EBCDIC platforms, there is just one outlier high ordinal control, and ++ # it gets output as \x{}. + my $bytes; { use bytes; $bytes = length } +- s/([[:^ascii:]])/'\x{'.sprintf("%x",ord($1)).'}'/ge if $bytes > length; +- return qq("$_") unless +- /[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~]/; # fast exit ++ s/([^[:ascii:]\0-\x3f])/sprintf("\\x{%x}",ord($1))/ge ++ if $bytes > length + +- my $high = shift || ""; ++ # The above doesn't get the EBCDIC outlier high ordinal control when ++ # the string is UTF-8 but there are no UTF-8 variant characters in it. ++ # We want that to come out as \x{} anyway. We need is_utf8() to do ++ # this. ++ || (! $IS_ASCII && $] ge 5.008_001 && utf8::is_utf8($_)); ++ ++ return qq("$_") unless /[[:^print:]]/; # fast exit if only printables ++ ++ # Here, there is at least one non-printable to output. First, translate the ++ # escapes. + s/([\a\b\t\n\f\r\e])/$esc{$1}/g; + +- if (ord('^')==94) { # ascii +- # no need for 3 digits in escape for these +- s/([\0-\037])(?!\d)/'\\'.sprintf('%o',ord($1))/eg; +- s/([\0-\037\177])/'\\'.sprintf('%03o',ord($1))/eg; ++ # no need for 3 digits in escape for octals not followed by a digit. ++ s/($low_controls)(?!\d)/'\\'.sprintf('%o',ord($1))/eg; ++ ++ # But otherwise use 3 digits ++ s/($low_controls)/'\\'.sprintf('%03o',ord($1))/eg; ++ + # all but last branch below not supported --BEHAVIOR SUBJECT TO CHANGE-- +- if ($high eq "iso8859") { +- s/([\200-\240])/'\\'.sprintf('%o',ord($1))/eg; ++ my $high = shift || ""; ++ if ($high eq "iso8859") { # Doesn't escape the Latin1 printables ++ if ($IS_ASCII) { ++ s/([\200-\240])/'\\'.sprintf('%o',ord($1))/eg; ++ } ++ elsif ($] ge 5.007_003) { ++ 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 { +- s/([\200-\377])/'\\'.sprintf('%03o',ord($1))/eg; +- s/([^\040-\176])/sprintf "\\x{%04x}", ord($1)/ge; ++ s/([[:^ascii:]])/'\\'.sprintf('%03o',ord($1))/eg; ++ #s/([^\040-\176])/sprintf "\\x{%04x}", ord($1)/ge; + } +- } +- else { # ebcdic +- s{([^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~])(?!\d)} +- {my $v = ord($1); '\\'.sprintf(($v <= 037 ? '%o' : '%03o'), $v)}eg; +- s{([^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~])} +- {'\\'.sprintf('%03o',ord($1))}eg; +- } + + return qq("$_"); + } +@@ -1025,9 +1060,7 @@ $Data::Dumper::Useqq I I<$OBJ>->Useqq(I<[NEWVAL]>) + When set, enables the use of double quotes for representing string values. + Whitespace other than space will be represented as C<[\n\t\r]>, "unsafe" + characters will be backslashed, and unprintable characters will be output as +-quoted octal integers. Since setting this variable imposes a performance +-penalty, the default is 0. C will run slower if this flag is set, +-since the fast XSUB implementation doesn't support it yet. ++quoted octal integers. The default is 0. + + =item * + +@@ -1391,8 +1424,8 @@ to have, you can use the C method to pre-seed the internal reference + table and make the dumped output point to them, instead. See L + above. + +-The C and C flags makes Dump() run slower, since the +-XSUB implementation does not support them. ++The C flag makes Dump() run slower, since the XSUB ++implementation does not support it. + + SCALAR objects have the weirdest looking C workaround. + +@@ -1421,7 +1454,7 @@ modify it under the same terms as Perl itself. + + =head1 VERSION + +-Version 2.154 (September 18 2014) ++Version 2.158 (March 13 2015) + + =head1 SEE ALSO + +diff --git a/Dumper.xs b/Dumper.xs +index 2ffa867..97277f4 100644 +--- a/Dumper.xs ++++ b/Dumper.xs +@@ -12,8 +12,33 @@ + # define DD_USE_OLD_ID_FORMAT + #endif + ++/* These definitions are ASCII only. But the pure-perl .pm avoids ++ * calling this .xs file for releases where they aren't defined */ ++ ++#ifndef isASCII ++# define isASCII(c) (((UV) (c)) < 128) ++#endif ++ ++#ifndef ESC_NATIVE /* \e */ ++# define ESC_NATIVE 27 ++#endif ++ ++#ifndef isPRINT ++# define isPRINT(c) (((UV) (c)) >= ' ' && ((UV) (c)) < 127) ++#endif ++ ++#ifndef isALPHA ++# define isALPHA(c) ( (((UV) (c)) >= 'a' && ((UV) (c)) <= 'z') \ ++ || (((UV) (c)) <= 'Z' && ((UV) (c)) >= 'A')) ++#endif ++ ++#ifndef isIDFIRST ++# define isIDFIRST(c) (isALPHA(c) || (c) == '_') ++#endif ++ + #ifndef isWORDCHAR +-# define isWORDCHAR(c) isALNUM(c) ++# define isWORDCHAR(c) (isIDFIRST(c) \ ++ || (((UV) (c)) >= '0' && ((UV) (c)) <= '9')) + #endif + + static I32 num_q (const char *s, STRLEN slen); +@@ -40,12 +65,6 @@ static I32 DD_dump (pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, + + #if PERL_VERSION <= 6 /* Perl 5.6 and earlier */ + +-# ifdef EBCDIC +-# define UNI_TO_NATIVE(ch) (((ch) > 255) ? (ch) : ASCII_TO_NATIVE(ch)) +-# else +-# define UNI_TO_NATIVE(ch) (ch) +-# endif +- + UV + Perl_utf8_to_uvchr_buf(pTHX_ U8 *s, U8 *send, STRLEN *retlen) + { +@@ -72,8 +91,7 @@ Perl_utf8_to_uvchr_buf(pTHX_ U8 *s, U8 *send, STRLEN *retlen) + * end of the buffer if there is a malformation that indicates the + * character is longer than the space available */ + +- const UV uv = utf8_to_uvchr(s, retlen); +- return UNI_TO_NATIVE(uv); ++ return utf8_to_uvchr(s, retlen); + } + + # if !defined(PERL_IMPLICIT_CONTEXT) +@@ -234,55 +252,90 @@ esc_q_utf8(pTHX_ SV* sv, const char *src, STRLEN slen, I32 do_utf8, I32 useqq) + STRLEN qq_escapables = 0; /* " $ @ will need a \ in "" strings. */ + STRLEN normal = 0; + int increment; +- UV next; +- +- /* this will need EBCDICification */ +- for (s = src; s < send; do_utf8 ? s += increment : s++) { +- const UV k = do_utf8 ? utf8_to_uvchr_buf((U8*)s, (U8*) send, NULL) : *(U8*)s; + +- /* check for invalid utf8 */ +- increment = (k == 0 && *s != '\0') ? 1 : UTF8SKIP(s); ++ for (s = src; s < send; s += increment) { /* Sizing pass */ ++ UV k = *(U8*)s; + +- /* this is only used to check if the next character is an +- * ASCII digit, which are invariant, so if the following collects +- * a UTF-8 start byte it does no harm +- */ +- next = (s + increment >= send ) ? 0 : *(U8*)(s+increment); ++ increment = 1; /* Will override if necessary for utf-8 */ + +-#ifdef EBCDIC +- if (!isprint(k) || k > 256) { +-#else +- if (k > 127) { +-#endif +- /* 4: \x{} then count the number of hex digits. */ +- grow += 4 + (k <= 0xFF ? 2 : k <= 0xFFF ? 3 : k <= 0xFFFF ? 4 : ++ if (isPRINT(k)) { ++ if (k == '\\') { ++ backslashes++; ++ } else if (k == '\'') { ++ single_quotes++; ++ } else if (k == '"' || k == '$' || k == '@') { ++ qq_escapables++; ++ } else { ++ normal++; ++ } ++ } ++ else if (! isASCII(k) && k > ' ') { ++ /* High ordinal non-printable code point. (The test that k is ++ * above SPACE should be optimized out by the compiler on ++ * non-EBCDIC platforms; otherwise we could put an #ifdef around ++ * it, but it's better to have just a single code path when ++ * possible. All but one of the non-ASCII EBCDIC controls are low ++ * ordinal; that one is the only one above SPACE.) ++ * ++ * If UTF-8, output as hex, regardless of useqq. This means there ++ * is an overhead of 4 chars '\x{}'. Then count the number of hex ++ * digits. */ ++ if (do_utf8) { ++ k = utf8_to_uvchr_buf((U8*)s, (U8*) send, NULL); ++ ++ /* treat invalid utf8 byte by byte. This loop iteration gets the ++ * first byte */ ++ increment = (k == 0 && *s != '\0') ? 1 : UTF8SKIP(s); ++ ++ grow += 4 + (k <= 0xFF ? 2 : k <= 0xFFF ? 3 : k <= 0xFFFF ? 4 : + #if UVSIZE == 4 +- 8 /* We may allocate a bit more than the minimum here. */ ++ 8 /* We may allocate a bit more than the minimum here. */ + #else +- k <= 0xFFFFFFFF ? 8 : UVSIZE * 4 +-#endif +- ); +-#ifndef EBCDIC +- } else if (useqq && +- /* we can't use the short form like '\0' if followed by a digit */ +- (((k >= 7 && k <= 10) || k == 12 || k == 13 || k == 27) +- || (k < 8 && (next < '0' || next > '9')))) { +- grow += 2; +- } else if (useqq && k <= 31 && (next < '0' || next > '9')) { +- grow += 3; +- } else if (useqq && (k <= 31 || k >= 127)) { +- grow += 4; ++ k <= 0xFFFFFFFF ? 8 : UVSIZE * 4 + #endif +- } else if (k == '\\') { +- backslashes++; +- } else if (k == '\'') { +- single_quotes++; +- } else if (k == '"' || k == '$' || k == '@') { +- qq_escapables++; +- } else { ++ ); ++ } ++ else if (useqq) { /* Not utf8, must be <= 0xFF, hence 2 hex ++ * digits. */ ++ grow += 4 + 2; ++ } ++ else { /* Non-qq generates 3 octal digits plus backslash */ ++ grow += 4; ++ } ++ } /* End of high-ordinal non-printable */ ++ else if (! useqq) { /* Low ordinal, non-printable, non-qq just ++ * outputs the raw char */ + normal++; + } +- } ++ else { /* Is qq, low ordinal, non-printable. Output escape ++ * sequences */ ++ if ( k == '\a' || k == '\b' || k == '\t' || k == '\n' || k == '\r' ++ || k == '\f' || k == ESC_NATIVE) ++ { ++ grow += 2; /* 1 char plus backslash */ ++ } ++ else /* The other low ordinals are output as an octal escape ++ * sequence */ ++ if (s + 1 >= send || ( *(U8*)(s+1) >= '0' ++ && *(U8*)(s+1) <= '9')) ++ { ++ /* When the following character is a digit, use 3 octal digits ++ * plus backslash, as using fewer digits would concatenate the ++ * following char into this one */ ++ grow += 4; ++ } ++ else if (k <= 7) { ++ grow += 2; /* 1 octal digit, plus backslash */ ++ } ++ else if (k <= 077) { ++ grow += 3; /* 2 octal digits plus backslash */ ++ } ++ else { ++ grow += 4; /* 3 octal digits plus backslash */ ++ } ++ } ++ } /* End of size-calculating loop */ ++ + if (grow || useqq) { + /* We have something needing hex. 3 is ""\0 */ + sv_grow(sv, cur + 3 + grow + 2*backslashes + single_quotes +@@ -291,38 +344,78 @@ esc_q_utf8(pTHX_ SV* sv, const char *src, STRLEN slen, I32 do_utf8, I32 useqq) + + *r++ = '"'; + +- for (s = src; s < send; do_utf8 ? s += UTF8SKIP(s) : s++) { +- const UV k = do_utf8 ? utf8_to_uvchr_buf((U8*)s, (U8*) send, NULL) : *(U8*)s; ++ for (s = src; s < send; s += increment) { ++ UV k; ++ ++ if (do_utf8 ++ && ! isASCII(*s) ++ /* Exclude non-ASCII low ordinal controls. This should be ++ * optimized out by the compiler on ASCII platforms; if not ++ * could wrap it in a #ifdef EBCDIC, but better to avoid ++ * #if's if possible */ ++ && *(U8*)s > ' ' ++ ) { ++ ++ /* When in UTF-8, we output all non-ascii chars as \x{} ++ * reqardless of useqq, except for the low ordinal controls on ++ * EBCDIC platforms */ ++ k = utf8_to_uvchr_buf((U8*)s, (U8*) send, NULL); ++ ++ /* treat invalid utf8 byte by byte. This loop iteration gets the ++ * first byte */ ++ increment = (k == 0 && *s != '\0') ? 1 : UTF8SKIP(s); ++ ++#if PERL_VERSION < 10 ++ sprintf(r, "\\x{%"UVxf"}", k); ++ r += strlen(r); ++ /* my_sprintf is not supported by ppport.h */ ++#else ++ r = r + my_sprintf(r, "\\x{%"UVxf"}", k); ++#endif ++ continue; ++ } ++ ++ /* Here 1) isn't UTF-8; or ++ * 2) the current character is ASCII; or ++ * 3) it is an EBCDIC platform and is a low ordinal ++ * non-ASCII control. ++ * In each case the character occupies just one byte */ ++ k = *(U8*)s; ++ increment = 1; ++ ++ if (isPRINT(k)) { ++ /* These need a backslash escape */ ++ if (k == '"' || k == '\\' || k == '$' || k == '@') { ++ *r++ = '\\'; ++ } + +- if (k == '"' || k == '\\' || k == '$' || k == '@') { +- *r++ = '\\'; + *r++ = (char)k; + } +- else +-#ifdef EBCDIC +- if (isprint(k) && k < 256) +-#else +- if (useqq && (k <= 31 || k == 127 || (!do_utf8 && k > 127))) { ++ else if (! useqq) { /* non-qq, non-printable, low-ordinal is ++ * output raw */ ++ *r++ = (char)k; ++ } ++ else { /* Is qq means use escape sequences */ + bool next_is_digit; + + *r++ = '\\'; + switch (k) { +- case 7: *r++ = 'a'; break; +- case 8: *r++ = 'b'; break; +- case 9: *r++ = 't'; break; +- case 10: *r++ = 'n'; break; +- case 12: *r++ = 'f'; break; +- case 13: *r++ = 'r'; break; +- case 27: *r++ = 'e'; break; ++ case '\a': *r++ = 'a'; break; ++ 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: +- increment = (k == 0 && *s != '\0') ? 1 : UTF8SKIP(s); + + /* 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 = (s+increment < send) ? *(U8*)(s+increment) : 0; +- next_is_digit = next >= '0' && next <= '9'; ++ next_is_digit = (s + 1 >= send ) ++ ? FALSE ++ : (*(U8*)(s+1) >= '0' && *(U8*)(s+1) <= '9'); + + /* faster than + * r = r + my_sprintf(r, "%o", k); +@@ -339,18 +432,6 @@ esc_q_utf8(pTHX_ SV* sv, const char *src, STRLEN slen, I32 do_utf8, I32 useqq) + } + } + } +- else if (k < 0x80) +-#endif +- *r++ = (char)k; +- else { +-#if PERL_VERSION < 10 +- sprintf(r, "\\x{%"UVxf"}", k); +- r += strlen(r); +- /* my_sprintf is not supported by ppport.h */ +-#else +- r = r + my_sprintf(r, "\\x{%"UVxf"}", k); +-#endif +- } + } + *r++ = '"'; + } else { +@@ -440,7 +521,7 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, + if (!val) + return 0; + +- /* If the ouput buffer has less than some arbitrary amount of space ++ /* If the output buffer has less than some arbitrary amount of space + remaining, then enlarge it. For the test case (25M of output), + *1.1 was slower, *2.0 was the same, so the first guess of 1.5 is + deemed to be good enough. */ +@@ -798,7 +879,7 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, + else if (realtype == SVt_PVHV) { + SV *totpad, *newapad; + SV *sname; +- HE *entry; ++ HE *entry = NULL; + char *key; + I32 klen; + SV *hval; +@@ -1106,8 +1187,7 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, + len = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"IVdf, SvIV(val)); + if (SvPOK(val)) { + /* Need to check to see if this is a string such as " 0". +- I'm assuming from sprintf isn't going to clash with utf8. +- Is this valid on EBCDIC? */ ++ I'm assuming from sprintf isn't going to clash with utf8. */ + STRLEN pvlen; + const char * const pv = SvPV(val, pvlen); + if (pvlen != len || memNE(pv, tmpbuf, len)) +@@ -1270,7 +1350,7 @@ MODULE = Data::Dumper PACKAGE = Data::Dumper PREFIX = Data_Dumper_ + # + # This is the exact equivalent of Dump. Well, almost. The things that are + # different as of now (due to Laziness): +-# * doesn't deparse yet.' ++# * doesn't do deparse yet.' + # + + void +@@ -1292,7 +1372,7 @@ Data_Dumper_Dumpxs(href, ...) + I32 purity, deepcopy, quotekeys, maxdepth = 0; + IV maxrecurse = 1000; + char tmpbuf[1024]; +- I32 gimme = GIMME; ++ I32 gimme = GIMME_V; + int use_sparse_seen_hash = 0; + + if (!SvROK(href)) { /* call new to get an object first */ +@@ -1504,7 +1584,7 @@ Data_Dumper_Dumpxs(href, ...) + } + else + croak("Call to new() method failed to return HASH ref"); +- if (gimme == G_SCALAR) ++ if (gimme != G_ARRAY) + XPUSHs(sv_2mortal(retval)); + } + +diff --git a/t/dumper.t b/t/dumper.t +index f452ad2..643160a 100644 +--- a/t/dumper.t ++++ b/t/dumper.t +@@ -16,7 +16,6 @@ local $Data::Dumper::Sortkeys = 1; + + use Data::Dumper; + use Config; +-my $Is_ebcdic = defined($Config{'ebcdic'}) && $Config{'ebcdic'} eq 'define'; + + $Data::Dumper::Pad = "#"; + my $TMAX; +@@ -24,6 +23,61 @@ my $XS; + my $TNUM = 0; + my $WANT = ''; + ++sub convert_to_native($) { ++ my $input = shift; ++ ++ # unicode_to_native() not available before this release; hence won't work ++ # on EBCDIC platforms for earlier. ++ return $input if $] lt 5.007_003; ++ ++ my @output; ++ ++ # The input should always be one of the following constructs ++ while ($input =~ m/ ( \\ [0-7]+ ) ++ | ( \\ x \{ [[:xdigit:]]+ } ) ++ | ( \\ . ) ++ | ( . ) /gx) ++ { ++ #print STDERR __LINE__, ": ", $&, "\n"; ++ my $index; ++ 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; ++ } ++ ++ $output[$index] = $replacement; ++ } ++ ++ return join "", grep { defined } @output; ++} ++ + sub TEST { + my $string = shift; + my $name = shift; +@@ -31,42 +85,19 @@ sub TEST { + ++$TNUM; + $t =~ s/([A-Z]+)\(0x[0-9a-f]+\)/$1(0xdeadbeef)/g + if ($WANT =~ /deadbeef/); +- if ($Is_ebcdic) { +- # these data need massaging with non ascii character sets +- # because of hashing order differences +- $WANT = join("\n",sort(split(/\n/,$WANT))); +- $WANT =~ s/\,$//mg; +- $t = join("\n",sort(split(/\n/,$t))); +- $t =~ s/\,$//mg; +- } + $name = $name ? " - $name" : ''; + print( ($t eq $WANT and not $@) ? "ok $TNUM$name\n" + : "not ok $TNUM$name\n--Expected--\n$WANT\n--Got--\n$@$t\n"); + + ++$TNUM; +- if ($Is_ebcdic) { # EBCDIC. +- if ($TNUM == 311 || $TNUM == 314) { +- eval $string; +- } else { +- eval $t; +- } +- } else { +- eval "$t"; +- } +- print $@ ? "not ok $TNUM\n# \$@ says: $@\n" : "ok $TNUM\n"; ++ eval "$t"; ++ print $@ ? "not ok $TNUM\n# \$@ says: $@\n" : "ok $TNUM - no eval error\n"; + + $t = eval $string; + ++$TNUM; + $t =~ s/([A-Z]+)\(0x[0-9a-f]+\)/$1(0xdeadbeef)/g + if ($WANT =~ /deadbeef/); +- if ($Is_ebcdic) { +- # here too there are hashing order differences +- $WANT = join("\n",sort(split(/\n/,$WANT))); +- $WANT =~ s/\,$//mg; +- $t = join("\n",sort(split(/\n/,$t))); +- $t =~ s/\,$//mg; +- } +- print( ($t eq $WANT and not $@) ? "ok $TNUM\n" ++ print( ($t eq $WANT and not $@) ? "ok $TNUM - works a 2nd time after intervening eval\n" + : "not ok $TNUM\n--Expected--\n$WANT\n--Got--\n$@$t\n"); + } + +@@ -77,17 +108,20 @@ sub SKIP_TEST { + ++$TNUM; print "ok $TNUM # skip $reason\n"; + } + ++$TMAX = 450; ++ + # Force Data::Dumper::Dump to use perl. We test Dumpxs explicitly by calling + # it direct. Out here it lets us knobble the next if to test that the perl + # only tests do work (and count correctly) + $Data::Dumper::Useperl = 1; + if (defined &Data::Dumper::Dumpxs) { + print "### XS extension loaded, will run XS tests\n"; +- $TMAX = 438; $XS = 1; ++ $XS = 1; + } + else { + print "### XS extensions not loaded, will NOT run XS tests\n"; +- $TMAX = 219; $XS = 0; ++ $TMAX /= 2; ++ $XS = 0; + } + + print "1..$TMAX\n"; +@@ -104,7 +138,7 @@ $b->{a} = $a; + $b->{b} = $a->[1]; + $b->{c} = $a->[2]; + +-############# 1 ++############# + ## + $WANT = <<'EOT'; + #$a = [ +@@ -138,7 +172,7 @@ SCOPE: { + } + + +-############# 7 ++############# + ## + $WANT = <<'EOT'; + #@a = ( +@@ -174,7 +208,7 @@ SCOPE: { + if $XS; + } + +-############# 13 ++############# + ## + $WANT = <<'EOT'; + #%b = ( +@@ -200,7 +234,7 @@ TEST (q(Data::Dumper->Dumpxs([$b, $a], [qw(*b a)])), + 'basic test with dereferenced hash: Dumpxs()') + if $XS; + +-############# 19 ++############# + ## + $WANT = <<'EOT'; + #$a = [ +@@ -236,7 +270,7 @@ if ($XS) { + } + + +-############# 25 ++############# + ## + $WANT = <<'EOT'; + #$a = [ +@@ -266,7 +300,7 @@ TEST (q( $d->Reset; $d->Dumpxs ), + 'Indent(3): Purity(0)->Quotekeys(0): Dumpxs()') + if $XS; + +-############# 31 ++############# + ## + $WANT = <<'EOT'; + #$VAR1 = [ +@@ -288,7 +322,7 @@ EOT + TEST (q(Dumper($a)), 'Dumper'); + TEST (q(Data::Dumper::DumperX($a)), 'DumperX') if $XS; + +-############# 37 ++############# + ## + $WANT = <<'EOT'; + #[ +@@ -316,7 +350,7 @@ EOT + } + + +-############# 43 ++############# + ## + $WANT = <<'EOT'; + #$VAR1 = { +@@ -348,7 +382,7 @@ $foo = { "abc\000\'\efg" => "mno\000", + $foo{d} = \%foo; + $foo[2] = \%foo; + +-############# 49 ++############# + ## + $WANT = <<'EOT'; + #$foo = \*::foo; +@@ -383,7 +417,7 @@ EOT + 'Purity 1: Indent 3: Dumpxs()') + if $XS; + +-############# 55 ++############# + ## + $WANT = <<'EOT'; + #$foo = \*::foo; +@@ -414,7 +448,7 @@ EOT + 'Purity 1: Indent 1: Dumpxs()') + if $XS; + +-############# 61 ++############# + ## + $WANT = <<'EOT'; + #@bar = ( +@@ -444,7 +478,7 @@ EOT + 'array|hash|glob dereferenced: Dumpxs()') + if $XS; + +-############# 67 ++############# + ## + $WANT = <<'EOT'; + #$bar = [ +@@ -474,7 +508,7 @@ EOT + 'array|hash|glob: not dereferenced: Dumpxs()') + if $XS; + +-############# 73 ++############# + ## + $WANT = <<'EOT'; + #$foo = \*::foo; +@@ -499,7 +533,7 @@ EOT + 'Purity 0: Quotekeys 0: dereferenced: Dumpxs') + if $XS; + +-############# 79 ++############# + ## + $WANT = <<'EOT'; + #$foo = \*::foo; +@@ -537,7 +571,7 @@ EOT + $mutts = \%kennel; + $mutts = $mutts; # avoid warning + +-############# 85 ++############# + ## + $WANT = <<'EOT'; + #%kennels = ( +@@ -567,7 +601,7 @@ EOT + 'constructor: hash|array|scalar: Dumpxs()'); + } + +-############# 91 ++############# + ## + $WANT = <<'EOT'; + #%kennels = %kennels; +@@ -578,7 +612,7 @@ EOT + TEST q($d->Dump), 'object call: Dump'; + TEST q($d->Dumpxs), 'object call: Dumpxs' if $XS; + +-############# 97 ++############# + ## + $WANT = <<'EOT'; + #%kennels = ( +@@ -598,7 +632,7 @@ EOT + TEST (q($d->Reset; $d->Dumpxs), 'Reset and Dumpxs separate calls'); + } + +-############# 103 ++############# + ## + $WANT = <<'EOT'; + #@dogs = ( +@@ -628,14 +662,14 @@ EOT + 'constructor: array|hash|scalar: Dumpxs()'); + } + +-############# 109 ++############# + ## + TEST q($d->Reset->Dump), 'Reset Dump chained'; + if ($XS) { + TEST q($d->Reset->Dumpxs), 'Reset Dumpxs chained'; + } + +-############# 115 ++############# + ## + $WANT = <<'EOT'; + #@dogs = ( +@@ -673,7 +707,7 @@ EOT + sub z { print "foo\n" } + $c = [ \&z ]; + +-############# 121 ++############# + ## + $WANT = <<'EOT'; + #$a = $b; +@@ -688,7 +722,7 @@ TEST (q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'b' => \&z})->Dumpxs;), + 'Seen: scalar: Dumpxs') + if $XS; + +-############# 127 ++############# + ## + $WANT = <<'EOT'; + #$a = \&b; +@@ -703,7 +737,7 @@ TEST (q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'*b' => \&z})->Dumpxs;), + 'Seen: glob: Dumpxs') + if $XS; + +-############# 133 ++############# + ## + $WANT = <<'EOT'; + #*a = \&b; +@@ -725,7 +759,7 @@ TEST (q(Data::Dumper->new([\&z,$c],['*a','*c'])->Seen({'*b' => + $a = []; + $a->[1] = \$a->[0]; + +-############# 139 ++############# + ## + $WANT = <<'EOT'; + #@a = ( +@@ -746,7 +780,7 @@ TEST (q(Data::Dumper->new([$a],['*a'])->Purity(1)->Dumpxs;), + $a = \\\\\'foo'; + $b = $$$a; + +-############# 145 ++############# + ## + $WANT = <<'EOT'; + #$a = \\\\\'foo'; +@@ -764,7 +798,7 @@ TEST (q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dumpxs;), + $a = [{ a => \$b }, { b => undef }]; + $b = [{ c => \$b }, { d => \$a }]; + +-############# 151 ++############# + ## + $WANT = <<'EOT'; + #$a = [ +@@ -799,7 +833,7 @@ TEST (q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dumpxs;), + $b = $a->[0][0]; + $c = $${$b->[0][0]}; + +-############# 157 ++############# + ## + $WANT = <<'EOT'; + #$a = [ +@@ -830,7 +864,7 @@ TEST (q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Purity(1)->Dumpxs;), + $b = { 'c' => $c }; + $a = { 'b' => $b }; + +-############# 163 ++############# + ## + $WANT = <<'EOT'; + #$a = { +@@ -852,7 +886,7 @@ TEST (q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(4)->Dumpxs;), + 'Maxdepth(4): Dumpxs()') + if $XS; + +-############# 169 ++############# + ## + $WANT = <<'EOT'; + #$a = { +@@ -875,7 +909,7 @@ TEST (q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(1)->Dumpxs;), + $a = \$a; + $b = [$a]; + +-############# 175 ++############# + ## + $WANT = <<'EOT'; + #$b = [ +@@ -889,7 +923,7 @@ TEST (q(Data::Dumper->new([$b],['b'])->Purity(0)->Dumpxs;), + 'Purity(0): Dumpxs()') + if $XS; + +-############# 181 ++############# + ## + $WANT = <<'EOT'; + #$b = [ +@@ -908,7 +942,7 @@ TEST (q(Data::Dumper->new([$b],['b'])->Purity(1)->Dumpxs;), + + { + $a = "\x{09c10}"; +-############# 187 ++############# + ## XS code was adding an extra \0 + $WANT = <<'EOT'; + #$a = "\x{9c10}"; +@@ -927,7 +961,7 @@ EOT + $i = 0; + $a = { map { ("$_$_$_", ++$i) } 'I'..'Q' }; + +-############# 193 ++############# + ## + $WANT = <<'EOT'; + #$VAR1 = { +@@ -959,7 +993,7 @@ TEST (q(Data::Dumper->new([$a])->Dumpxs;), + return [ sort { $b <=> $a } keys %$hash ]; + } + +-############# 199 ++############# + ## + $WANT = <<'EOT'; + #$VAR1 = { +@@ -993,7 +1027,7 @@ TEST q(Data::Dumper->new([$c])->Dumpxs;), "sortkeys sub (XS)" + ]; + } + +-############# 205 ++############# + ## + $WANT = <<'EOT'; + #$VAR1 = [ +@@ -1033,7 +1067,7 @@ TEST q(Data::Dumper->new([[$c, $d]])->Dumpxs;), "more sortkeys sub (XS)" + local $Data::Dumper::Deparse = 1; + local $Data::Dumper::Indent = 2; + +-############# 211 ++############# + ## + $WANT = <<'EOT'; + #$VAR1 = { +@@ -1051,7 +1085,7 @@ EOT + } + } + +-############# 214 ++############# + ## + + # This is messy. +@@ -1293,7 +1327,7 @@ if ($XS) { + + { + $a = "1\n"; +-############# 310 ++############# + ## Perl code was using /...$/ and hence missing the \n. + $WANT = <<'EOT'; + my $VAR1 = '42 +@@ -1322,7 +1356,7 @@ EOT + -2147483648, + -2147483649, + ); +-############# 316 ++############# + ## Perl code flips over at 10 digits. + $WANT = <<'EOT'; + #$VAR1 = 999999999; +@@ -1379,42 +1413,27 @@ EOT + } + } + +-#XXX} + { +- if ($Is_ebcdic) { + $b = "Bad. XS didn't escape dollar sign"; +-############# 322 +- $WANT = <<"EOT"; # Careful. This is '' string written inside '' here doc +-#\$VAR1 = '\$b\"\@\\\\\xB1'; +-EOT +- $a = "\$b\"\@\\\xB1\x{100}"; +- chop $a; +- TEST q(Data::Dumper->Dump([$a])), "utf8 flag with \" and \$"; +- if ($XS) { +- $WANT = <<'EOT'; # While this is "" string written inside "" here doc +-#$VAR1 = "\$b\"\@\\\x{b1}"; +-EOT +- TEST q(Data::Dumper->Dumpxs([$a])), "XS utf8 flag with \" and \$"; +- } +- } else { +- $b = "Bad. XS didn't escape dollar sign"; +-############# 322 +- $WANT = <<"EOT"; # Careful. This is '' string written inside '' here doc +-#\$VAR1 = '\$b\"\@\\\\\xA3'; ++############# ++ # B6 is chosen because it is UTF-8 variant on ASCII and all 3 EBCDIC ++ # platforms that Perl currently purports to work on. It also is the only ++ # such code point that has the same meaning on all 4, the paragraph sign. ++ $WANT = <<"EOT"; # Careful. This is '' string written inside "" here doc ++#\$VAR1 = '\$b\"\@\\\\\xB6'; + EOT + +- $a = "\$b\"\@\\\xA3\x{100}"; +- chop $a; +- TEST q(Data::Dumper->Dump([$a])), "utf8 flag with \" and \$"; +- if ($XS) { +- $WANT = <<'EOT'; # While this is "" string written inside "" here doc +-#$VAR1 = "\$b\"\@\\\x{a3}"; ++ $a = "\$b\"\@\\\xB6\x{100}"; ++ chop $a; ++ TEST q(Data::Dumper->Dump([$a])), "utf8 flag with \" and \$"; ++ if ($XS) { ++ $WANT = <<'EOT'; # While this is "" string written inside "" here doc ++#$VAR1 = "\$b\"\@\\\x{b6}"; + EOT +- TEST q(Data::Dumper->Dumpxs([$a])), "XS utf8 flag with \" and \$"; +- } +- } ++ TEST q(Data::Dumper->Dumpxs([$a])), "XS utf8 flag with \" and \$"; ++ } + # XS used to produce "$b\"' which is 4 chars, not 3. [ie wrongly qq(\$b\\\")] +-############# 328 ++############# + $WANT = <<'EOT'; + #$VAR1 = '$b"'; + EOT +@@ -1429,7 +1448,7 @@ EOT + + # XS used to produce 'D'oh!' which is well, D'oh! + # Andreas found this one, which in turn discovered the previous two. +-############# 334 ++############# + $WANT = <<'EOT'; + #$VAR1 = 'D\'oh!'; + EOT +@@ -1492,7 +1511,7 @@ EOT + TEST q(Data::Dumper->Dumpxs([\\%foo])), + "XS quotekeys == 0 for utf8 flagged ASCII" if $XS; + } +-############# 358 ++############# + { + $WANT = <<'EOT'; + #$VAR1 = [ +@@ -1507,7 +1526,7 @@ EOT + TEST q(Data::Dumper->Dumpxs([\@foo])), 'Richard Clamp, Message-Id: <20030104005247.GA27685@mirth.demon.co.uk>: Dumpxs()'if $XS; + } + +-############# 364 ++############# + # Make sure $obj->Dumpxs returns the right thing in list context. This was + # broken by the initial attempt to fix [perl #74170]. + $WANT = <<'EOT'; +@@ -1517,11 +1536,13 @@ TEST q(join " ", new Data::Dumper [[]],[] =>->Dumpxs), + '$obj->Dumpxs in list context' + if $XS; + +-############# 366 ++############# + { +- $WANT = <<'EOT'; +-#$VAR1 = [ +-# "\0\1\2\3\4\5\6\a\b\t\n\13\f\r\16\17\20\21\22\23\24\25\26\27\30\31\32\e\34\35\36\37 !\"#\$%&'()*+,-./0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~\177\200\201\202\203\204\205\206\207\210\211\212\213\214\215\216\217\220\221\222\223\224\225\226\227\230\231\232\233\234\235\236\237\240\241\242\243\244\245\246\247\250\251\252\253\254\255\256\257\260\261\262\263\264\265\266\267\270\271\272\273\274\275\276\277\300\301\302\303\304\305\306\307\310\311\312\313\314\315\316\317\320\321\322\323\324\325\326\327\330\331\332\333\334\335\336\337\340\341\342\343\344\345\346\347\350\351\352\353\354\355\356\357\360\361\362\363\364\365\366\367\370\371\372\373\374\375\376\377" ++ $WANT = '\0\1\2\3\4\5\6\a\b\t\n\13\f\r\16\17\20\21\22\23\24\25\26\27\30\31\32\e\34\35\36\37 !\"#\$%&\'()*+,-./0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\\]^_`abcdefghijklmnopqrstuvwxyz{|}~\177\200\201\202\203\204\205\206\207\210\211\212\213\214\215\216\217\220\221\222\223\224\225\226\227\230\231\232\233\234\235\236\237\240\241\242\243\244\245\246\247\250\251\252\253\254\255\256\257\260\261\262\263\264\265\266\267\270\271\272\273\274\275\276\277\300\301\302\303\304\305\306\307\310\311\312\313\314\315\316\317\320\321\322\323\324\325\326\327\330\331\332\333\334\335\336\337\340\341\342\343\344\345\346\347\350\351\352\353\354\355\356\357\360\361\362\363\364\365\366\367\370\371\372\373\374\375\376\377'; ++ $WANT = convert_to_native($WANT); ++ $WANT = <?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~\177\x{80}\x{81}\x{82}\x{83}\x{84}\x{85}\x{86}\x{87}\x{88}\x{89}\x{8a}\x{8b}\x{8c}\x{8d}\x{8e}\x{8f}\x{90}\x{91}\x{92}\x{93}\x{94}\x{95}\x{96}\x{97}\x{98}\x{99}\x{9a}\x{9b}\x{9c}\x{9d}\x{9e}\x{9f}\x{a0}\x{a1}\x{a2}\x{a3}\x{a4}\x{a5}\x{a6}\x{a7}\x{a8}\x{a9}\x{aa}\x{ab}\x{ac}\x{ad}\x{ae}\x{af}\x{b0}\x{b1}\x{b2}\x{b3}\x{b4}\x{b5}\x{b6}\x{b7}\x{b8}\x{b9}\x{ba}\x{bb}\x{bc}\x{bd}\x{be}\x{bf}\x{c0}\x{c1}\x{c2}\x{c3}\x{c4}\x{c5}\x{c6}\x{c7}\x{c8}\x{c9}\x{ca}\x{cb}\x{cc}\x{cd}\x{ce}\x{cf}\x{d0}\x{d1}\x{d2}\x{d3}\x{d4}\x{d5}\x{d6}\x{d7}\x{d8}\x{d9}\x{da}\x{db}\x{dc}\x{dd}\x{de}\x{df}\x{e0}\x{e1}\x{e2}\x{e3}\x{e4}\x{e5}\x{e6}\x{e7}\x{e8}\x{e9}\x{ea}\x{eb}\x{ec}\x{ed}\x{ee}\x{ef}\x{f0}\x{f1}\x{f2}\x{f3}\x{f4}\x{f5}\x{f6}\x{f7}\x{f8}\x{f9}\x{fa}\x{fb}\x{fc}\x{fd}\x{fe}\x{ff}\x{20ac}" ++ $WANT = '\0\1\2\3\4\5\6\a\b\t\n\13\f\r\16\17\20\21\22\23\24\25\26\27\30\31\32\e\34\35\36\37 !\"#\$%&\'()*+,-./0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\\]^_`abcdefghijklmnopqrstuvwxyz{|}~\177\x{80}\x{81}\x{82}\x{83}\x{84}\x{85}\x{86}\x{87}\x{88}\x{89}\x{8a}\x{8b}\x{8c}\x{8d}\x{8e}\x{8f}\x{90}\x{91}\x{92}\x{93}\x{94}\x{95}\x{96}\x{97}\x{98}\x{99}\x{9a}\x{9b}\x{9c}\x{9d}\x{9e}\x{9f}\x{a0}\x{a1}\x{a2}\x{a3}\x{a4}\x{a5}\x{a6}\x{a7}\x{a8}\x{a9}\x{aa}\x{ab}\x{ac}\x{ad}\x{ae}\x{af}\x{b0}\x{b1}\x{b2}\x{b3}\x{b4}\x{b5}\x{b6}\x{b7}\x{b8}\x{b9}\x{ba}\x{bb}\x{bc}\x{bd}\x{be}\x{bf}\x{c0}\x{c1}\x{c2}\x{c3}\x{c4}\x{c5}\x{c6}\x{c7}\x{c8}\x{c9}\x{ca}\x{cb}\x{cc}\x{cd}\x{ce}\x{cf}\x{d0}\x{d1}\x{d2}\x{d3}\x{d4}\x{d5}\x{d6}\x{d7}\x{d8}\x{d9}\x{da}\x{db}\x{dc}\x{dd}\x{de}\x{df}\x{e0}\x{e1}\x{e2}\x{e3}\x{e4}\x{e5}\x{e6}\x{e7}\x{e8}\x{e9}\x{ea}\x{eb}\x{ec}\x{ed}\x{ee}\x{ef}\x{f0}\x{f1}\x{f2}\x{f3}\x{f4}\x{f5}\x{f6}\x{f7}\x{f8}\x{f9}\x{fa}\x{fb}\x{fc}\x{fd}\x{fe}\x{ff}\x{20ac}'; ++ $WANT = convert_to_native($WANT); ++ $WANT = <Dumpxs([\*finkle])), 'blessed overloaded globs (xs)' + if $XS; + } +-############# 390 ++############# + { + # [perl #74798] uncovered behaviour + $WANT = <<'EOW'; +@@ -1653,7 +1677,7 @@ EOW + "numbers and number-like scalars" + if $XS; + } +-############# 426 ++############# + { + # [perl #82948] + # re::regexp_pattern was moved to universal.c in v5.10.0-252-g192c1e2 +@@ -1669,7 +1693,7 @@ OLD + TEST q(Data::Dumper->Dumpxs([ qr/abc/, qr/abc/i ])), "qr// xs" + if $XS; + } +-############# 432 ++############# + + { + sub foo {} +@@ -1682,4 +1706,37 @@ EOW + TEST q(Data::Dumper->new([ \&foo, \\&foo ], [ "*a", "b" ])->Dumpxs), "name of code in *foo xs" + if $XS; + } +-############# 436 ++############# ++ ++{ ++ if($] lt 5.007_003) { ++ SKIP_TEST "Test is only problematic for EBCDIC, which only works for >= 5.8"; ++ SKIP_TEST "Test is only problematic for EBCDIC, which only works for >= 5.8"; ++ } ++ else { ++ # 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; ++ $WANT = < 'a', + ); + ++my $is_ascii = ord("A") == 65; ++ + run_tests_for_quotekeys(); + SKIP: { + skip "XS version was unavailable, so we already ran with pure Perl", 5 +@@ -110,25 +112,33 @@ sub run_tests_for_quotekeys { + ); + + is(Dumper(\%qkdata), +- q($VAR1 = {'0' => 1,'012345' => 1,'12' => 1,'123456789' => 1,'1234567890' => 1,"1\x{660}" => 1,'::de::fg' => 1,'ab' => 1,'hi::12' => 1};), ++ (($is_ascii) # Sort order is different on EBCDIC platforms ++ ? q($VAR1 = {'0' => 1,'012345' => 1,'12' => 1,'123456789' => 1,'1234567890' => 1,"1\x{660}" => 1,'::de::fg' => 1,'ab' => 1,'hi::12' => 1};) ++ : q($VAR1 = {'::de::fg' => 1,'ab' => 1,'hi::12' => 1,'0' => 1,'012345' => 1,'12' => 1,'123456789' => 1,'1234567890' => 1,"1\x{660}" => 1};)), + "always quote when quotekeys true"); + + { + local $Data::Dumper::Useqq = 1; + is(Dumper(\%qkdata), +- q($VAR1 = {"0" => 1,"012345" => 1,"12" => 1,"123456789" => 1,"1234567890" => 1,"1\x{660}" => 1,"::de::fg" => 1,"ab" => 1,"hi::12" => 1};), ++ (($is_ascii) ++ ? q($VAR1 = {"0" => 1,"012345" => 1,"12" => 1,"123456789" => 1,"1234567890" => 1,"1\x{660}" => 1,"::de::fg" => 1,"ab" => 1,"hi::12" => 1};) ++ : q($VAR1 = {"::de::fg" => 1,"ab" => 1,"hi::12" => 1,"0" => 1,"012345" => 1,"12" => 1,"123456789" => 1,"1234567890" => 1,"1\x{660}" => 1};)), + "always quote when quotekeys true (useqq)"); + } + + local $Data::Dumper::Quotekeys = 0; + + is(Dumper(\%qkdata), +- q($VAR1 = {0 => 1,'012345' => 1,12 => 1,123456789 => 1,'1234567890' => 1,"1\x{660}" => 1,'::de::fg' => 1,ab => 1,'hi::12' => 1};), ++ (($is_ascii) ++ ? q($VAR1 = {0 => 1,'012345' => 1,12 => 1,123456789 => 1,'1234567890' => 1,"1\x{660}" => 1,'::de::fg' => 1,ab => 1,'hi::12' => 1};) ++ : q($VAR1 = {'::de::fg' => 1,ab => 1,'hi::12' => 1,0 => 1,'012345' => 1,12 => 1,123456789 => 1,'1234567890' => 1,"1\x{660}" => 1};)), + "avoid quotes when quotekeys false"); + { + local $Data::Dumper::Useqq = 1; + is(Dumper(\%qkdata), +- q($VAR1 = {0 => 1,"012345" => 1,12 => 1,123456789 => 1,"1234567890" => 1,"1\x{660}" => 1,"::de::fg" => 1,ab => 1,"hi::12" => 1};), ++ (($is_ascii) ++ ? q($VAR1 = {0 => 1,"012345" => 1,12 => 1,123456789 => 1,"1234567890" => 1,"1\x{660}" => 1,"::de::fg" => 1,ab => 1,"hi::12" => 1};) ++ : q($VAR1 = {"::de::fg" => 1,ab => 1,"hi::12" => 1,0 => 1,"012345" => 1,12 => 1,123456789 => 1,"1234567890" => 1,"1\x{660}" => 1};)), + "avoid quotes when quotekeys false (useqq)"); + } + } +-- +2.1.0 + diff --git a/perl-Data-Dumper.spec b/perl-Data-Dumper.spec index 3a83544..d181ac5 100644 --- a/perl-Data-Dumper.spec +++ b/perl-Data-Dumper.spec @@ -1,12 +1,14 @@ -%global cpan_version 2.154 +%global base_version 2.154 Name: perl-Data-Dumper -Version: %(echo '%{cpan_version}' | tr '_' '.') +Version: 2.158 Release: 1%{?dist} Summary: Stringify perl data structures, suitable for printing and eval License: GPL+ or Artistic Group: Development/Libraries URL: http://search.cpan.org/dist/Data-Dumper/ -Source0: http://www.cpan.org/authors/id/S/SM/SMUELLER/Data-Dumper-%{cpan_version}.tar.gz +Source0: http://www.cpan.org/authors/id/S/SM/SMUELLER/Data-Dumper-%{base_version}.tar.gz +# Unbundled from perl 5.21.11 +Patch0: Data-Dumper-2.154-Upgrade-to-2.158.patch BuildRequires: perl BuildRequires: perl(ExtUtils::MakeMaker) # Run-time: @@ -46,7 +48,8 @@ variable is output in a single Perl statement. Handles self-referential structures correctly. %prep -%setup -q -n Data-Dumper-%{cpan_version} +%setup -q -n Data-Dumper-%{base_version} +%patch0 -p1 sed -i '/MAN3PODS/d' Makefile.PL %build @@ -71,6 +74,9 @@ make test %{_mandir}/man3/* %changelog +* Wed May 06 2015 Petr Pisar - 2.158-1 +- 2.158 bump in order to dual-live with perl 5.22 + * Fri Sep 19 2014 Petr Pisar - 2.154-1 - 2.154 bump (fixes CVE-2014-4330 (limit recursion when dumping deep data structures))