diff --git a/.gitignore b/.gitignore index e7c640e..f51d037 100644 --- a/.gitignore +++ b/.gitignore @@ -6,3 +6,4 @@ /Data-Dumper-2.145.tar.gz /Data-Dumper-2.151.tar.gz /Data-Dumper-2.154.tar.gz +/Data-Dumper-2.161.tar.gz diff --git a/Data-Dumper-2.154-Upgrade-to-2.158.patch b/Data-Dumper-2.154-Upgrade-to-2.158.patch deleted file mode 100644 index aad23a8..0000000 --- a/Data-Dumper-2.154-Upgrade-to-2.158.patch +++ /dev/null @@ -1,1347 +0,0 @@ -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/Data-Dumper-2.158-Upgrade-to-2.160.patch b/Data-Dumper-2.158-Upgrade-to-2.160.patch deleted file mode 100644 index 45a6e52..0000000 --- a/Data-Dumper-2.158-Upgrade-to-2.160.patch +++ /dev/null @@ -1,929 +0,0 @@ -diff --git a/Dumper.pm b/Dumper.pm -index e884298..13be89d 100644 ---- a/Dumper.pm -+++ b/Dumper.pm -@@ -10,7 +10,7 @@ - package Data::Dumper; - - BEGIN { -- $VERSION = '2.158'; # Don't forget to set version and release -+ $VERSION = '2.160'; # Don't forget to set version and release - } # date in POD below! - - #$| = 1; -@@ -41,6 +41,7 @@ my $IS_ASCII = ord 'A' == 65; - - # module vars and their defaults - $Indent = 2 unless defined $Indent; -+$Trailingcomma = 0 unless defined $Trailingcomma; - $Purity = 0 unless defined $Purity; - $Pad = "" unless defined $Pad; - $Varname = "VAR" unless defined $Varname; -@@ -76,6 +77,7 @@ sub new { - my($s) = { - level => 0, # current recursive depth - indent => $Indent, # various styles of indenting -+ trailingcomma => $Trailingcomma, # whether to add comma after last elem - pad => $Pad, # all lines prefixed by this string - xpad => "", # padding-per-level - apad => "", # added padding for hash keys n such -@@ -413,7 +415,9 @@ sub _dump { - $out .= $pad . $ipad . '#' . $i - if $s->{indent} >= 3; - $out .= $pad . $ipad . $s->_dump($v, $sname); -- $out .= "," if $i++ < $#$val; -+ $out .= "," -+ if $i++ < $#$val -+ || ($s->{trailingcomma} && $s->{indent} >= 1); - } - $out .= $pad . ($s->{xpad} x ($s->{level} - 1)) if $i; - $out .= ($name =~ /^\@/) ? ')' : ']'; -@@ -473,7 +477,7 @@ sub _dump { - if $s->{indent} >= 2; - } - if (substr($out, -1) eq ',') { -- chop $out; -+ chop $out if !$s->{trailingcomma} || !$s->{indent}; - $out .= $pad . ($s->{xpad} x ($s->{level} - 1)); - } - $out .= ($name =~ /^\%/) ? ')' : '}'; -@@ -633,6 +637,11 @@ sub Indent { - } - } - -+sub Trailingcomma { -+ my($s, $v) = @_; -+ defined($v) ? (($s->{trailingcomma} = $v), return $s) : $s->{trailingcomma}; -+} -+ - sub Pair { - my($s, $v) = @_; - defined($v) ? (($s->{pair} = $v), return $s) : $s->{pair}; -@@ -1032,6 +1041,15 @@ consumes twice the number of lines). Style 2 is the default. - - =item * - -+$Data::Dumper::Trailingcomma I I<$OBJ>->Trailingcomma(I<[NEWVAL]>) -+ -+Controls whether a comma is added after the last element of an array or -+hash. Even when true, no comma is added between the last element of an array -+or hash and a closing bracket when they appear on the same line. The default -+is false. -+ -+=item * -+ - $Data::Dumper::Purity I I<$OBJ>->Purity(I<[NEWVAL]>) - - Controls the degree to which the output can be Ced to recreate the -@@ -1454,7 +1472,7 @@ modify it under the same terms as Perl itself. - - =head1 VERSION - --Version 2.158 (March 13 2015) -+Version 2.160 (January 12 2016) - - =head1 SEE ALSO - -diff --git a/Dumper.xs b/Dumper.xs -index 97277f4..8220241 100644 ---- a/Dumper.xs -+++ b/Dumper.xs -@@ -41,19 +41,40 @@ - || (((UV) (c)) >= '0' && ((UV) (c)) <= '9')) - #endif - --static I32 num_q (const char *s, STRLEN slen); --static I32 esc_q (char *dest, const char *src, STRLEN slen); --static I32 esc_q_utf8 (pTHX_ SV *sv, const char *src, STRLEN slen, I32 do_utf8, I32 useqq); -+/* This struct contains almost all the user's desired configuration, and it -+ * is treated as constant by the recursive function. This arrangement has -+ * the advantage of needing less memory than passing all of them on the -+ * stack all the time (as was the case in an earlier implementation). */ -+typedef struct { -+ SV *pad; -+ SV *xpad; -+ SV *sep; -+ SV *pair; -+ SV *sortkeys; -+ SV *freezer; -+ SV *toaster; -+ SV *bless; -+ IV maxrecurse; -+ I32 indent; -+ I32 purity; -+ I32 deepcopy; -+ I32 quotekeys; -+ I32 maxdepth; -+ I32 useqq; -+ int use_sparse_seen_hash; -+ int trailingcomma; -+} Style; -+ -+static STRLEN num_q (const char *s, STRLEN slen); -+static STRLEN esc_q (char *dest, const char *src, STRLEN slen); -+static STRLEN esc_q_utf8 (pTHX_ SV *sv, const char *src, STRLEN slen, I32 do_utf8, I32 useqq); - static bool globname_needs_quote(const char *s, STRLEN len); - static bool key_needs_quote(const char *s, STRLEN len); - static bool safe_decimal_number(const char *p, STRLEN len); - static SV *sv_x (pTHX_ SV *sv, const char *str, STRLEN len, I32 n); - static I32 DD_dump (pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, -- HV *seenhv, AV *postav, I32 *levelp, I32 indent, -- SV *pad, SV *xpad, SV *apad, SV *sep, SV *pair, -- SV *freezer, SV *toaster, -- I32 purity, I32 deepcopy, I32 quotekeys, SV *bless, -- I32 maxdepth, SV *sortkeys, int use_sparse_seen_hash, I32 useqq, IV maxrecurse); -+ HV *seenhv, AV *postav, const I32 level, SV *apad, -+ const Style *style); - - #ifndef HvNAME_get - #define HvNAME_get HvNAME -@@ -196,10 +217,10 @@ safe_decimal_number(const char *p, STRLEN len) { - } - - /* count the number of "'"s and "\"s in string */ --static I32 -+static STRLEN - num_q(const char *s, STRLEN slen) - { -- I32 ret = 0; -+ STRLEN ret = 0; - - while (slen > 0) { - if (*s == '\'' || *s == '\\') -@@ -214,10 +235,10 @@ num_q(const char *s, STRLEN slen) - /* returns number of chars added to escape "'"s and "\"s in s */ - /* slen number of characters in s will be escaped */ - /* destination must be long enough for additional chars */ --static I32 -+static STRLEN - esc_q(char *d, const char *s, STRLEN slen) - { -- I32 ret = 0; -+ STRLEN ret = 0; - - while (slen > 0) { - switch (*s) { -@@ -236,7 +257,7 @@ esc_q(char *d, const char *s, STRLEN slen) - } - - /* this function is also misused for implementing $Useqq */ --static I32 -+static STRLEN - esc_q_utf8(pTHX_ SV* sv, const char *src, STRLEN slen, I32 do_utf8, I32 useqq) - { - char *r, *rstart; -@@ -491,10 +512,7 @@ sv_x(pTHX_ SV *sv, const char *str, STRLEN len, I32 n) - */ - static I32 - DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, -- AV *postav, I32 *levelp, I32 indent, SV *pad, SV *xpad, -- SV *apad, SV *sep, SV *pair, SV *freezer, SV *toaster, I32 purity, -- I32 deepcopy, I32 quotekeys, SV *bless, I32 maxdepth, SV *sortkeys, -- int use_sparse_seen_hash, I32 useqq, IV maxrecurse) -+ AV *postav, const I32 level, SV *apad, const Style *style) - { - char tmpbuf[128]; - Size_t i; -@@ -537,14 +555,14 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, - - /* If a freeze method is provided and the object has it, call - it. Warn on errors. */ -- if (SvOBJECT(SvRV(val)) && freezer && -- SvPOK(freezer) && SvCUR(freezer) && -- gv_fetchmeth(SvSTASH(SvRV(val)), SvPVX_const(freezer), -- SvCUR(freezer), -1) != NULL) -+ if (SvOBJECT(SvRV(val)) && style->freezer && -+ SvPOK(style->freezer) && SvCUR(style->freezer) && -+ gv_fetchmeth(SvSTASH(SvRV(val)), SvPVX_const(style->freezer), -+ SvCUR(style->freezer), -1) != NULL) - { - dSP; ENTER; SAVETMPS; PUSHMARK(sp); - XPUSHs(val); PUTBACK; -- i = perl_call_method(SvPVX_const(freezer), G_EVAL|G_VOID|G_DISCARD); -+ i = perl_call_method(SvPVX_const(style->freezer), G_EVAL|G_VOID|G_DISCARD); - SPAGAIN; - if (SvTRUE(ERRSV)) - warn("WARNING(Freezer method call failed): %"SVf"", ERRSV); -@@ -575,7 +593,7 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, - if ((svp = av_fetch(seenentry, 0, FALSE)) - && (othername = *svp)) - { -- if (purity && *levelp > 0) { -+ if (style->purity && level > 0) { - SV *postentry; - - if (realtype == SVt_PVHV) -@@ -662,7 +680,7 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, - * representation of the thing we are currently examining - * at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)'). - */ -- if (!purity && maxdepth > 0 && *levelp >= maxdepth) { -+ if (!style->purity && style->maxdepth > 0 && level >= style->maxdepth) { - STRLEN vallen; - const char * const valstr = SvPV(val,vallen); - sv_catpvs(retval, "'"); -@@ -671,24 +689,23 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, - return 1; - } - -- if (maxrecurse > 0 && *levelp >= maxrecurse) { -- croak("Recursion limit of %" IVdf " exceeded", maxrecurse); -+ if (style->maxrecurse > 0 && level >= style->maxrecurse) { -+ croak("Recursion limit of %" IVdf " exceeded", style->maxrecurse); - } - - if (realpack && !no_bless) { /* we have a blessed ref */ - STRLEN blesslen; -- const char * const blessstr = SvPV(bless, blesslen); -+ const char * const blessstr = SvPV(style->bless, blesslen); - sv_catpvn(retval, blessstr, blesslen); - sv_catpvs(retval, "( "); -- if (indent >= 2) { -+ if (style->indent >= 2) { - blesspad = apad; - apad = newSVsv(apad); - sv_x(aTHX_ apad, " ", 1, blesslen+2); - } - } - -- (*levelp)++; -- ipad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), *levelp); -+ ipad = sv_x(aTHX_ Nullsv, SvPVX_const(style->xpad), SvCUR(style->xpad), level+1); - - if (is_regex) - { -@@ -759,19 +776,13 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, - if (realpack) { /* blessed */ - sv_catpvs(retval, "do{\\(my $o = "); - DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv, -- postav, levelp, indent, pad, xpad, apad, sep, pair, -- freezer, toaster, purity, deepcopy, quotekeys, bless, -- maxdepth, sortkeys, use_sparse_seen_hash, useqq, -- maxrecurse); -+ postav, level+1, apad, style); - sv_catpvs(retval, ")}"); - } /* plain */ - else { - sv_catpvs(retval, "\\"); - DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv, -- postav, levelp, indent, pad, xpad, apad, sep, pair, -- freezer, toaster, purity, deepcopy, quotekeys, bless, -- maxdepth, sortkeys, use_sparse_seen_hash, useqq, -- maxrecurse); -+ postav, level+1, apad, style); - } - SvREFCNT_dec(namesv); - } -@@ -781,10 +792,7 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, - sv_catpvs(namesv, "}"); - sv_catpvs(retval, "\\"); - DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv, -- postav, levelp, indent, pad, xpad, apad, sep, pair, -- freezer, toaster, purity, deepcopy, quotekeys, bless, -- maxdepth, sortkeys, use_sparse_seen_hash, useqq, -- maxrecurse); -+ postav, level+1, apad, style); - SvREFCNT_dec(namesv); - } - else if (realtype == SVt_PVAV) { -@@ -824,8 +832,8 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, - iname[inamelen++] = '-'; iname[inamelen++] = '>'; - } - iname[inamelen++] = '['; iname[inamelen] = '\0'; -- totpad = newSVsv(sep); -- sv_catsv(totpad, pad); -+ totpad = newSVsv(style->sep); -+ sv_catsv(totpad, style->pad); - sv_catsv(totpad, apad); - - for (ix = 0; ix <= ixmax; ++ix) { -@@ -846,7 +854,7 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, - ilen = ilen + my_sprintf(iname+ilen, "%"IVdf, (IV)ix); - #endif - iname[ilen++] = ']'; iname[ilen] = '\0'; -- if (indent >= 3) { -+ if (style->indent >= 3) { - sv_catsv(retval, totpad); - sv_catsv(retval, ipad); - sv_catpvs(retval, "#"); -@@ -855,15 +863,12 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, - sv_catsv(retval, totpad); - sv_catsv(retval, ipad); - DD_dump(aTHX_ elem, iname, ilen, retval, seenhv, postav, -- levelp, indent, pad, xpad, apad, sep, pair, -- freezer, toaster, purity, deepcopy, quotekeys, bless, -- maxdepth, sortkeys, use_sparse_seen_hash, -- useqq, maxrecurse); -- if (ix < ixmax) -+ level+1, apad, style); -+ if (ix < ixmax || (style->trailingcomma && style->indent >= 1)) - sv_catpvs(retval, ","); - } - if (ixmax >= 0) { -- SV * const opad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), (*levelp)-1); -+ SV * const opad = sv_x(aTHX_ Nullsv, SvPVX_const(style->xpad), SvCUR(style->xpad), level); - sv_catsv(retval, totpad); - sv_catsv(retval, opad); - SvREFCNT_dec(opad); -@@ -881,7 +886,7 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, - SV *sname; - HE *entry = NULL; - char *key; -- I32 klen; -+ STRLEN klen; - SV *hval; - AV *keys = NULL; - -@@ -909,16 +914,14 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, - sv_catpvs(iname, "->"); - } - sv_catpvs(iname, "{"); -- totpad = newSVsv(sep); -- sv_catsv(totpad, pad); -+ totpad = newSVsv(style->sep); -+ sv_catsv(totpad, style->pad); - sv_catsv(totpad, apad); - - /* If requested, get a sorted/filtered array of hash keys */ -- if (sortkeys) { -- if (sortkeys == &PL_sv_yes) { --#if PERL_VERSION < 8 -- sortkeys = sv_2mortal(newSVpvs("Data::Dumper::_sortkeys")); --#else -+ if (style->sortkeys) { -+#if PERL_VERSION >= 8 -+ if (style->sortkeys == &PL_sv_yes) { - keys = newAV(); - (void)hv_iterinit((HV*)ival); - while ((entry = hv_iternext((HV*)ival))) { -@@ -939,17 +942,18 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, - } - else - # endif --#endif - { - sortsv(AvARRAY(keys), - av_len(keys)+1, - Perl_sv_cmp); - } - } -- if (sortkeys != &PL_sv_yes) { -+ else -+#endif -+ { - dSP; ENTER; SAVETMPS; PUSHMARK(sp); - XPUSHs(sv_2mortal(newRV_inc(ival))); PUTBACK; -- i = perl_call_sv(sortkeys, G_SCALAR | G_EVAL); -+ i = perl_call_sv(style->sortkeys, G_SCALAR | G_EVAL); - SPAGAIN; - if (i) { - sv = POPs; -@@ -970,13 +974,13 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, - for (i = 0; 1; i++) { - char *nkey; - char *nkey_buffer = NULL; -- I32 nticks = 0; -+ STRLEN nticks = 0; - SV* keysv; - STRLEN keylen; -- I32 nlen; -+ STRLEN nlen; - bool do_utf8 = FALSE; - -- if (sortkeys) { -+ if (style->sortkeys) { - if (!(keys && (SSize_t)i <= av_len(keys))) break; - } else { - if (!(entry = hv_iternext((HV *)ival))) break; -@@ -985,7 +989,7 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, - if (i) - sv_catpvs(retval, ","); - -- if (sortkeys) { -+ if (style->sortkeys) { - char *key; - svp = av_fetch(keys, i, FALSE); - keysv = svp ? *svp : sv_newmortal(); -@@ -1022,10 +1026,10 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, - their handling of key quoting compatible between XS - and perl. - */ -- if (quotekeys || key_needs_quote(key,keylen)) { -- if (do_utf8 || useqq) { -+ if (style->quotekeys || key_needs_quote(key,keylen)) { -+ if (do_utf8 || style->useqq) { - STRLEN ocur = SvCUR(retval); -- nlen = esc_q_utf8(aTHX_ retval, key, klen, do_utf8, useqq); -+ nlen = esc_q_utf8(aTHX_ retval, key, klen, do_utf8, style->useqq); - nkey = SvPVX(retval) + ocur; - } - else { -@@ -1052,10 +1056,10 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, - sv_catpvn(sname, nkey, nlen); - sv_catpvs(sname, "}"); - -- sv_catsv(retval, pair); -- if (indent >= 2) { -+ sv_catsv(retval, style->pair); -+ if (style->indent >= 2) { - char *extra; -- I32 elen = 0; -+ STRLEN elen = 0; - newapad = newSVsv(apad); - New(0, extra, klen+4+1, char); - while (elen < (klen+4)) -@@ -1068,17 +1072,17 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, - newapad = apad; - - DD_dump(aTHX_ hval, SvPVX_const(sname), SvCUR(sname), retval, seenhv, -- postav, levelp, indent, pad, xpad, newapad, sep, pair, -- freezer, toaster, purity, deepcopy, quotekeys, bless, -- maxdepth, sortkeys, use_sparse_seen_hash, useqq, -- maxrecurse); -+ postav, level+1, newapad, style); - SvREFCNT_dec(sname); - Safefree(nkey_buffer); -- if (indent >= 2) -+ if (style->indent >= 2) - SvREFCNT_dec(newapad); - } - if (i) { -- SV *opad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), *levelp-1); -+ SV *opad = sv_x(aTHX_ Nullsv, SvPVX_const(style->xpad), -+ SvCUR(style->xpad), level); -+ if (style->trailingcomma && style->indent >= 1) -+ sv_catpvs(retval, ","); - sv_catsv(retval, totpad); - sv_catsv(retval, opad); - SvREFCNT_dec(opad); -@@ -1092,7 +1096,7 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, - } - else if (realtype == SVt_PVCV) { - sv_catpvs(retval, "sub { \"DUMMY\" }"); -- if (purity) -+ if (style->purity) - warn("Encountered CODE ref, using dummy placeholder"); - } - else { -@@ -1100,10 +1104,9 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, - } - - if (realpack && !no_bless) { /* free blessed allocs */ -- I32 plen; -- I32 pticks; -+ STRLEN plen, pticks; - -- if (indent >= 2) { -+ if (style->indent >= 2) { - SvREFCNT_dec(apad); - apad = blesspad; - } -@@ -1127,14 +1130,13 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, - sv_catpvn(retval, realpack, strlen(realpack)); - } - sv_catpvs(retval, "' )"); -- if (toaster && SvPOK(toaster) && SvCUR(toaster)) { -+ if (style->toaster && SvPOK(style->toaster) && SvCUR(style->toaster)) { - sv_catpvs(retval, "->"); -- sv_catsv(retval, toaster); -+ sv_catsv(retval, style->toaster); - sv_catpvs(retval, "()"); - } - } - SvREFCNT_dec(ipad); -- (*levelp)--; - } - else { - STRLEN i; -@@ -1168,7 +1170,7 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, - * there is no other reference, duh. This is an optimization. - * Note that we'd have to check for weak-refs, too, but this is - * already the branch for non-refs only. */ -- else if (val != &PL_sv_undef && (!use_sparse_seen_hash || SvREFCNT(val) > 1)) { -+ else if (val != &PL_sv_undef && (!style->use_sparse_seen_hash || SvREFCNT(val) > 1)) { - SV * const namesv = newSVpvs("\\"); - sv_catpvn(namesv, name, namelen); - seenentry = newAV(); -@@ -1219,7 +1221,7 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, - r = SvPVX(retval)+SvCUR(retval); - r[0] = '*'; r[1] = '{'; - SvCUR_set(retval, SvCUR(retval)+2); -- esc_q_utf8(aTHX_ retval, c, i, 1, useqq); -+ esc_q_utf8(aTHX_ retval, c, i, 1, style->useqq); - sv_grow(retval, SvCUR(retval)+2); - r = SvPVX(retval)+SvCUR(retval); - r[0] = '}'; r[1] = '\0'; -@@ -1245,7 +1247,7 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, - } - SvCUR_set(retval, SvCUR(retval)+i); - -- if (purity) { -+ if (style->purity) { - static const char* const entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" }; - static const STRLEN sizes[] = { 8, 7, 6 }; - SV *e; -@@ -1262,7 +1264,6 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, - continue; - - { -- I32 nlevel = 0; - SV *postentry = newSVpvn(r,i); - - sv_setsv(nname, postentry); -@@ -1272,15 +1273,11 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, - e = newRV_inc(e); - - SvCUR_set(newapad, 0); -- if (indent >= 2) -+ if (style->indent >= 2) - (void)sv_x(aTHX_ newapad, " ", 1, SvCUR(postentry)); - - DD_dump(aTHX_ e, SvPVX_const(nname), SvCUR(nname), postentry, -- seenhv, postav, &nlevel, indent, pad, xpad, -- newapad, sep, pair, freezer, toaster, purity, -- deepcopy, quotekeys, bless, maxdepth, -- sortkeys, use_sparse_seen_hash, useqq, -- maxrecurse); -+ seenhv, postav, 0, newapad, style); - SvREFCNT_dec(e); - } - } -@@ -1315,11 +1312,11 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, - * the pure perl code. - * see [perl #74798] - */ -- if (useqq && safe_decimal_number(c, i)) { -+ if (style->useqq && safe_decimal_number(c, i)) { - sv_catsv(retval, val); - } -- else if (DO_UTF8(val) || useqq) -- i += esc_q_utf8(aTHX_ retval, c, i, DO_UTF8(val), useqq); -+ else if (DO_UTF8(val) || style->useqq) -+ i += esc_q_utf8(aTHX_ retval, c, i, DO_UTF8(val), style->useqq); - else { - sv_grow(retval, SvCUR(retval)+3+2*i); /* 3: ""\0 */ - r = SvPVX(retval) + SvCUR(retval); -@@ -1334,7 +1331,7 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, - } - - if (idlen) { -- if (deepcopy) -+ if (style->deepcopy) - (void)hv_delete(seenhv, id, idlen, G_DISCARD); - else if (namelen && seenentry) { - SV *mark = *av_fetch(seenentry, 2, TRUE); -@@ -1363,17 +1360,15 @@ Data_Dumper_Dumpxs(href, ...) - SV *retval, *valstr; - HV *seenhv = NULL; - AV *postav, *todumpav, *namesav; -- I32 level = 0; -- I32 indent, terse, useqq; -+ I32 terse = 0; - SSize_t i, imax, postlen; - SV **svp; -- SV *val, *name, *pad, *xpad, *apad, *sep, *pair, *varname; -- SV *freezer, *toaster, *bless, *sortkeys; -- I32 purity, deepcopy, quotekeys, maxdepth = 0; -- IV maxrecurse = 1000; -+ SV *apad = &PL_sv_undef; -+ Style style; -+ -+ SV *name, *val = &PL_sv_undef, *varname = &PL_sv_undef; - char tmpbuf[1024]; - I32 gimme = GIMME_V; -- int use_sparse_seen_hash = 0; - - if (!SvROK(href)) { /* call new to get an object first */ - if (items < 2) -@@ -1402,13 +1397,15 @@ Data_Dumper_Dumpxs(href, ...) - } - - todumpav = namesav = NULL; -+ style.indent = 2; -+ style.quotekeys = 1; -+ style.maxrecurse = 1000; -+ style.purity = style.deepcopy = style.useqq = style.maxdepth -+ = style.use_sparse_seen_hash = style.trailingcomma = 0; -+ style.pad = style.xpad = style.sep = style.pair = style.sortkeys -+ = style.freezer = style.toaster = style.bless = &PL_sv_undef; - seenhv = NULL; -- val = pad = xpad = apad = sep = pair = varname -- = freezer = toaster = bless = sortkeys = &PL_sv_undef; - name = sv_newmortal(); -- indent = 2; -- terse = purity = deepcopy = useqq = 0; -- quotekeys = 1; - - retval = newSVpvs(""); - if (SvROK(href) -@@ -1418,57 +1415,66 @@ Data_Dumper_Dumpxs(href, ...) - if ((svp = hv_fetch(hv, "seen", 4, FALSE)) && SvROK(*svp)) - seenhv = (HV*)SvRV(*svp); - else -- use_sparse_seen_hash = 1; -+ style.use_sparse_seen_hash = 1; - if ((svp = hv_fetch(hv, "noseen", 6, FALSE))) -- use_sparse_seen_hash = (SvOK(*svp) && SvIV(*svp) != 0); -+ style.use_sparse_seen_hash = (SvOK(*svp) && SvIV(*svp) != 0); - if ((svp = hv_fetch(hv, "todump", 6, FALSE)) && SvROK(*svp)) - todumpav = (AV*)SvRV(*svp); - if ((svp = hv_fetch(hv, "names", 5, FALSE)) && SvROK(*svp)) - namesav = (AV*)SvRV(*svp); - if ((svp = hv_fetch(hv, "indent", 6, FALSE))) -- indent = SvIV(*svp); -+ style.indent = SvIV(*svp); - if ((svp = hv_fetch(hv, "purity", 6, FALSE))) -- purity = SvIV(*svp); -+ style.purity = SvIV(*svp); - if ((svp = hv_fetch(hv, "terse", 5, FALSE))) - terse = SvTRUE(*svp); - if ((svp = hv_fetch(hv, "useqq", 5, FALSE))) -- useqq = SvTRUE(*svp); -+ style.useqq = SvTRUE(*svp); - if ((svp = hv_fetch(hv, "pad", 3, FALSE))) -- pad = *svp; -+ style.pad = *svp; - if ((svp = hv_fetch(hv, "xpad", 4, FALSE))) -- xpad = *svp; -+ style.xpad = *svp; - if ((svp = hv_fetch(hv, "apad", 4, FALSE))) - apad = *svp; - if ((svp = hv_fetch(hv, "sep", 3, FALSE))) -- sep = *svp; -+ style.sep = *svp; - if ((svp = hv_fetch(hv, "pair", 4, FALSE))) -- pair = *svp; -+ style.pair = *svp; - if ((svp = hv_fetch(hv, "varname", 7, FALSE))) - varname = *svp; - if ((svp = hv_fetch(hv, "freezer", 7, FALSE))) -- freezer = *svp; -+ style.freezer = *svp; - if ((svp = hv_fetch(hv, "toaster", 7, FALSE))) -- toaster = *svp; -+ style.toaster = *svp; - if ((svp = hv_fetch(hv, "deepcopy", 8, FALSE))) -- deepcopy = SvTRUE(*svp); -+ style.deepcopy = SvTRUE(*svp); - if ((svp = hv_fetch(hv, "quotekeys", 9, FALSE))) -- quotekeys = SvTRUE(*svp); -+ style.quotekeys = SvTRUE(*svp); -+ if ((svp = hv_fetch(hv, "trailingcomma", 13, FALSE))) -+ style.trailingcomma = SvTRUE(*svp); - if ((svp = hv_fetch(hv, "bless", 5, FALSE))) -- bless = *svp; -+ style.bless = *svp; - if ((svp = hv_fetch(hv, "maxdepth", 8, FALSE))) -- maxdepth = SvIV(*svp); -+ style.maxdepth = SvIV(*svp); - if ((svp = hv_fetch(hv, "maxrecurse", 10, FALSE))) -- maxrecurse = SvIV(*svp); -+ style.maxrecurse = SvIV(*svp); - if ((svp = hv_fetch(hv, "sortkeys", 8, FALSE))) { -- sortkeys = *svp; -- if (! SvTRUE(sortkeys)) -- sortkeys = NULL; -- else if (! (SvROK(sortkeys) && -- SvTYPE(SvRV(sortkeys)) == SVt_PVCV) ) -- { -- /* flag to use qsortsv() for sorting hash keys */ -- sortkeys = &PL_sv_yes; -- } -+ SV *sv = *svp; -+ if (! SvTRUE(sv)) -+ style.sortkeys = NULL; -+ else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) -+ style.sortkeys = sv; -+ else if (PERL_VERSION < 8) -+ /* 5.6 doesn't make sortsv() available to XS code, -+ * so we must use this helper instead. Note that we -+ * always allocate this mortal SV, but it will be -+ * used only if at least one hash is encountered -+ * while dumping recursively; an older version -+ * allocated it lazily as needed. */ -+ style.sortkeys = sv_2mortal(newSVpvs("Data::Dumper::_sortkeys")); -+ else -+ /* flag to use sortsv() for sorting hash keys */ -+ style.sortkeys = &PL_sv_yes; - } - postav = newAV(); - -@@ -1525,7 +1531,7 @@ Data_Dumper_Dumpxs(href, ...) - sv_catpvn(name, tmpbuf, nchars); - } - -- if (indent >= 2 && !terse) { -+ if (style.indent >= 2 && !terse) { - SV * const tmpsv = sv_x(aTHX_ NULL, " ", 1, SvCUR(name)+3); - newapad = newSVsv(apad); - sv_catsv(newapad, tmpsv); -@@ -1536,13 +1542,10 @@ Data_Dumper_Dumpxs(href, ...) - - PUTBACK; - DD_dump(aTHX_ val, SvPVX_const(name), SvCUR(name), valstr, seenhv, -- postav, &level, indent, pad, xpad, newapad, sep, pair, -- freezer, toaster, purity, deepcopy, quotekeys, -- bless, maxdepth, sortkeys, use_sparse_seen_hash, -- useqq, maxrecurse); -+ postav, 0, newapad, &style); - SPAGAIN; - -- if (indent >= 2 && !terse) -+ if (style.indent >= 2 && !terse) - SvREFCNT_dec(newapad); - - postlen = av_len(postav); -@@ -1551,12 +1554,12 @@ Data_Dumper_Dumpxs(href, ...) - sv_insert(valstr, 0, 0, SvPVX_const(name), SvCUR(name)); - sv_catpvs(valstr, ";"); - } -- sv_catsv(retval, pad); -+ sv_catsv(retval, style.pad); - sv_catsv(retval, valstr); -- sv_catsv(retval, sep); -+ sv_catsv(retval, style.sep); - if (postlen >= 0) { - SSize_t i; -- sv_catsv(retval, pad); -+ sv_catsv(retval, style.pad); - for (i = 0; i <= postlen; ++i) { - SV *elem; - svp = av_fetch(postav, i, FALSE); -@@ -1564,13 +1567,13 @@ Data_Dumper_Dumpxs(href, ...) - sv_catsv(retval, elem); - if (i < postlen) { - sv_catpvs(retval, ";"); -- sv_catsv(retval, sep); -- sv_catsv(retval, pad); -+ sv_catsv(retval, style.sep); -+ sv_catsv(retval, style.pad); - } - } - } - sv_catpvs(retval, ";"); -- sv_catsv(retval, sep); -+ sv_catsv(retval, style.sep); - } - sv_setpvn(valstr, "", 0); - if (gimme == G_ARRAY) { -diff --git a/t/huge.t b/t/huge.t -new file mode 100644 -index 0000000..09343b7 ---- /dev/null -+++ b/t/huge.t -@@ -0,0 +1,33 @@ -+#!./perl -w -+# -+# automated tests for Data::Dumper that need large amounts of memory; they -+# are skipped unless PERL_TEST_MEMORY is set, and at least 10 -+# -+ -+use strict; -+use warnings; -+ -+use Test::More; -+ -+use Config; -+use Data::Dumper; -+ -+BEGIN { -+ plan skip_all => 'Data::Dumper was not built' -+ if $Config{extensions} !~ m{\b Data/Dumper \b}x; -+ plan skip_all => 'Need 64-bit pointers for this test' -+ if $Config{ptrsize} < 8; -+ plan skip_all => 'Need ~10 GiB of core for this test' -+ if !$ENV{PERL_TEST_MEMORY} || $ENV{PERL_TEST_MEMORY} < 10; -+} -+ -+plan tests => 1; -+ -+{ -+ my $input = q/'/ x 2**31; -+ my $len = length Dumper($input); -+ # Each single-quote will get backslashed, so the output must have -+ # stricly more than twice as many characters as the input. -+ cmp_ok($len, '>', 2**32, 'correct output for huge all-quotable value'); -+ undef $input; -+} -diff --git a/t/trailing_comma.t b/t/trailing_comma.t -new file mode 100644 -index 0000000..8767bdf ---- /dev/null -+++ b/t/trailing_comma.t -@@ -0,0 +1,116 @@ -+#!./perl -w -+# t/trailing_comma.t - Test TrailingComma() -+ -+BEGIN { -+ if ($ENV{PERL_CORE}){ -+ require Config; import Config; -+ no warnings 'once'; -+ if ($Config{'extensions'} !~ /\bData\/Dumper\b/) { -+ print "1..0 # Skip: Data::Dumper was not built\n"; -+ exit 0; -+ } -+ } -+} -+ -+use strict; -+ -+use Data::Dumper; -+use Test::More; -+use lib qw( ./t/lib ); -+use Testing qw( _dumptostr ); -+ -+my @cases = ({ -+ input => [], -+ output => "[]", -+ desc => 'empty array', -+}, { -+ input => [17], -+ output => "[17]", -+ desc => 'single-element array, no indent', -+ conf => { Indent => 0 }, -+}, { -+ input => [17], -+ output => "[\n 17,\n]", -+ desc => 'single-element array, indent=1', -+ conf => { Indent => 1 }, -+}, { -+ input => [17], -+ output => "[\n 17,\n ]", -+ desc => 'single-element array, indent=2', -+ conf => { Indent => 2 }, -+}, { -+ input => [17, 18], -+ output => "[17,18]", -+ desc => 'two-element array, no indent', -+ conf => { Indent => 0 }, -+}, { -+ input => [17, 18], -+ output => "[\n 17,\n 18,\n]", -+ desc => 'two-element array, indent=1', -+ conf => { Indent => 1 }, -+}, { -+ input => [17, 18], -+ output => "[\n 17,\n 18,\n ]", -+ desc => 'two-element array, indent=2', -+ conf => { Indent => 2 }, -+}, { -+ input => {}, -+ output => "{}", -+ desc => 'empty hash', -+}, { -+ input => {foo => 17}, -+ output => "{'foo' => 17}", -+ desc => 'single-element hash, no indent', -+ conf => { Indent => 0 }, -+}, { -+ input => {foo => 17}, -+ output => "{\n 'foo' => 17,\n}", -+ desc => 'single-element hash, indent=1', -+ conf => { Indent => 1 }, -+}, { -+ input => {foo => 17}, -+ output => "{\n 'foo' => 17,\n }", -+ desc => 'single-element hash, indent=2', -+ conf => { Indent => 2 }, -+}, { -+ input => {foo => 17, quux => 18}, -+ output => "{'foo' => 17,'quux' => 18}", -+ desc => 'two-element hash, no indent', -+ conf => { Indent => 0 }, -+}, { -+ input => {foo => 17, quux => 18}, -+ output => "{\n 'foo' => 17,\n 'quux' => 18,\n}", -+ desc => 'two-element hash, indent=1', -+ conf => { Indent => 1 }, -+}, { -+ input => {foo => 17, quux => 18}, -+ output => "{\n 'foo' => 17,\n 'quux' => 18,\n }", -+ desc => 'two-element hash, indent=2', -+ conf => { Indent => 2 }, -+}); -+ -+my $xs_available = !$Data::Dumper::Useperl; -+my $tests_per_case = $xs_available ? 2 : 1; -+ -+plan tests => $tests_per_case * @cases; -+ -+for my $case (@cases) { -+ run_case($case, $xs_available ? 'XS' : 'PP'); -+ if ($xs_available) { -+ local $Data::Dumper::Useperl = 1; -+ run_case($case, 'PP'); -+ } -+} -+ -+sub run_case { -+ my ($case, $mode) = @_; -+ my ($input, $output, $desc, $conf) = @$case{qw}; -+ my $obj = Data::Dumper->new([$input]); -+ $obj->Trailingcomma(1); # default to on for these tests -+ $obj->Sortkeys(1); -+ for my $k (sort keys %{ $conf || {} }) { -+ $obj->$k($conf->{$k}); -+ } -+ chomp(my $got = _dumptostr($obj)); -+ is($got, "\$VAR1 = $output;", "$desc (in $mode mode)"); -+} diff --git a/perl-Data-Dumper.spec b/perl-Data-Dumper.spec index 713db0f..96dffc7 100644 --- a/perl-Data-Dumper.spec +++ b/perl-Data-Dumper.spec @@ -1,20 +1,19 @@ -%global base_version 2.154 Name: perl-Data-Dumper -Version: 2.160 -Release: 366%{?dist} +Version: 2.161 +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-%{base_version}.tar.gz -# Unbundled from perl 5.21.11 -Patch0: Data-Dumper-2.154-Upgrade-to-2.158.patch -# Unbundled from perl 5.24.0 -Patch1: Data-Dumper-2.158-Upgrade-to-2.160.patch +Source0: http://www.cpan.org/authors/id/S/SM/SMUELLER/Data-Dumper-%{version}.tar.gz +BuildRequires: findutils +BuildRequires: gcc +BuildRequires: make BuildRequires: perl BuildRequires: perl-devel BuildRequires: perl-generators BuildRequires: perl(ExtUtils::MakeMaker) +BuildRequires: sed # Run-time: BuildRequires: perl(B::Deparse) BuildRequires: perl(bytes) @@ -52,9 +51,7 @@ variable is output in a single Perl statement. Handles self-referential structures correctly. %prep -%setup -q -n Data-Dumper-%{base_version} -%patch0 -p1 -%patch1 -p1 +%setup -q -n Data-Dumper-%{version} sed -i '/MAN3PODS/d' Makefile.PL %build @@ -63,8 +60,8 @@ make %{?_smp_mflags} %install make pure_install DESTDIR=$RPM_BUILD_ROOT -find $RPM_BUILD_ROOT -type f -name .packlist -exec rm -f {} \; -find $RPM_BUILD_ROOT -type f -name '*.bs' -size 0 -exec rm -f {} \; +find $RPM_BUILD_ROOT -type f -name .packlist -delete +find $RPM_BUILD_ROOT -type f -name '*.bs' -size 0 -delete %{_fixperms} $RPM_BUILD_ROOT/* %check @@ -79,6 +76,9 @@ make test %{_mandir}/man3/* %changelog +* Tue Jul 12 2016 Petr Pisar - 2.161-1 +- 1.161 bump + * Wed May 18 2016 Jitka Plesnikova - 2.160-366 - Perl 5.24 re-rebuild of bootstrapped packages diff --git a/sources b/sources index 8390767..9714c4a 100644 --- a/sources +++ b/sources @@ -1 +1 @@ -577b4d4e53d7609457d36d674b6169a7 Data-Dumper-2.154.tar.gz +0c18654f06366c494d5c72801eab9393 Data-Dumper-2.161.tar.gz