From 89ac68b90b8b1f62170c63cf90390fc2482e1b68 Mon Sep 17 00:00:00 2001 From: Jitka Plesnikova Date: Wed, 23 May 2018 17:37:07 +0200 Subject: [PATCH] Upgrade to 2.170 --- Changes | 16 ++++++++++- Dumper.pm | 61 +++++++++++++++++++++++------------------ Dumper.xs | 56 +++++++++++++++++++++++--------------- t/dumper.t | 65 +++++++++++++++++++++++++++++++++++++++++++- t/indent.t | 8 +----- t/misc.t | 16 +---------- t/pair.t | 2 +- t/purity_deepcopy_maxdepth.t | 17 +----------- t/quotekeys.t | 5 ++-- t/terse.t | 33 +++++++--------------- 10 files changed, 164 insertions(+), 115 deletions(-) diff --git a/Changes b/Changes index a5430d5..95e3a8a 100644 --- a/Changes +++ b/Changes @@ -6,7 +6,21 @@ Changes - public release history for Data::Dumper =over 8 -=item 2,166 (Nov 29 2016) +=item 2.167_02 (Aug 4 2017) + +Attempt to work around XS deparse issues on old perls. +According to the few old perls at my disposure, this now repairs, +for example 5.18, but 5.8.9 still barfs. My debugging hasn't +really come up with much since all changes other than the deparse +change look benign to me. +Can someone who uses ancient perls please step up and take a look? +--Steffen + +=item 2.167_01 (Jul 31 2017) + +CPAN dev release with the accumulated changes from core perl. + +=item 2.166 (Nov 29 2016) Reduce memory usage by not importing from Carp Reduce memory usage by removing unused overload require. diff --git a/Dumper.pm b/Dumper.pm index 00f6326..00c99ec 100644 --- a/Dumper.pm +++ b/Dumper.pm @@ -10,7 +10,7 @@ package Data::Dumper; BEGIN { - $VERSION = '2.167'; # Don't forget to set version and release + $VERSION = '2.170'; # Don't forget to set version and release } # date in POD below! #$| = 1; @@ -18,6 +18,8 @@ BEGIN { use 5.006_001; require Exporter; +use constant IS_PRE_520_PERL => $] < 5.020; + use Carp (); BEGIN { @@ -224,12 +226,19 @@ sub Names { sub DESTROY {} sub Dump { - return &Dumpxs - unless $Data::Dumper::Useperl || (ref($_[0]) && $_[0]->{useperl}) + # On old versions of perl, the xs-deparse support can fail + # mysteriously. Barring copious spare time, it's best to revert + # to the previously standard behavior of using the pure perl dumper + # for deparsing on old perls. --Steffen + if (IS_PRE_520_PERL and ($Data::Dumper::Deparse or (ref($_[0]) && $_[0]->{deparse}))) { + return &Dumpperl; + } + return &Dumpxs + unless $Data::Dumper::Useperl || (ref($_[0]) && $_[0]->{useperl}) # Use pure perl version on earlier releases on EBCDIC platforms || (! $IS_ASCII && $] lt 5.021_010); - return &Dumpperl; + return &Dumpperl; } # @@ -527,8 +536,8 @@ sub _dump { $ref = \$val; if (ref($ref) eq 'GLOB') { # glob my $name = substr($val, 1); - if ($name =~ /^[A-Za-z_][\w:]*$/ && $name ne 'main::') { - $name =~ s/^main::/::/; + $name =~ s/^main::(?!\z)/::/; + if ($name =~ /\A(?:[A-Z_a-z][0-9A-Z_a-z]*)?::(?:[0-9A-Z_a-z]+::)*[0-9A-Z_a-z]*\z/ && $name ne 'main::') { $sname = $name; } else { @@ -618,7 +627,7 @@ sub Reset { sub Indent { my($s, $v) = @_; - if (defined($v)) { + if (@_ >= 2) { if ($v == 0) { $s->{xpad} = ""; $s->{sep} = ""; @@ -637,92 +646,92 @@ sub Indent { sub Trailingcomma { my($s, $v) = @_; - defined($v) ? (($s->{trailingcomma} = $v), return $s) : $s->{trailingcomma}; + @_ >= 2 ? (($s->{trailingcomma} = $v), return $s) : $s->{trailingcomma}; } sub Pair { my($s, $v) = @_; - defined($v) ? (($s->{pair} = $v), return $s) : $s->{pair}; + @_ >= 2 ? (($s->{pair} = $v), return $s) : $s->{pair}; } sub Pad { my($s, $v) = @_; - defined($v) ? (($s->{pad} = $v), return $s) : $s->{pad}; + @_ >= 2 ? (($s->{pad} = $v), return $s) : $s->{pad}; } sub Varname { my($s, $v) = @_; - defined($v) ? (($s->{varname} = $v), return $s) : $s->{varname}; + @_ >= 2 ? (($s->{varname} = $v), return $s) : $s->{varname}; } sub Purity { my($s, $v) = @_; - defined($v) ? (($s->{purity} = $v), return $s) : $s->{purity}; + @_ >= 2 ? (($s->{purity} = $v), return $s) : $s->{purity}; } sub Useqq { my($s, $v) = @_; - defined($v) ? (($s->{useqq} = $v), return $s) : $s->{useqq}; + @_ >= 2 ? (($s->{useqq} = $v), return $s) : $s->{useqq}; } sub Terse { my($s, $v) = @_; - defined($v) ? (($s->{terse} = $v), return $s) : $s->{terse}; + @_ >= 2 ? (($s->{terse} = $v), return $s) : $s->{terse}; } sub Freezer { my($s, $v) = @_; - defined($v) ? (($s->{freezer} = $v), return $s) : $s->{freezer}; + @_ >= 2 ? (($s->{freezer} = $v), return $s) : $s->{freezer}; } sub Toaster { my($s, $v) = @_; - defined($v) ? (($s->{toaster} = $v), return $s) : $s->{toaster}; + @_ >= 2 ? (($s->{toaster} = $v), return $s) : $s->{toaster}; } sub Deepcopy { my($s, $v) = @_; - defined($v) ? (($s->{deepcopy} = $v), return $s) : $s->{deepcopy}; + @_ >= 2 ? (($s->{deepcopy} = $v), return $s) : $s->{deepcopy}; } sub Quotekeys { my($s, $v) = @_; - defined($v) ? (($s->{quotekeys} = $v), return $s) : $s->{quotekeys}; + @_ >= 2 ? (($s->{quotekeys} = $v), return $s) : $s->{quotekeys}; } sub Bless { my($s, $v) = @_; - defined($v) ? (($s->{'bless'} = $v), return $s) : $s->{'bless'}; + @_ >= 2 ? (($s->{'bless'} = $v), return $s) : $s->{'bless'}; } sub Maxdepth { my($s, $v) = @_; - defined($v) ? (($s->{'maxdepth'} = $v), return $s) : $s->{'maxdepth'}; + @_ >= 2 ? (($s->{'maxdepth'} = $v), return $s) : $s->{'maxdepth'}; } sub Maxrecurse { my($s, $v) = @_; - defined($v) ? (($s->{'maxrecurse'} = $v), return $s) : $s->{'maxrecurse'}; + @_ >= 2 ? (($s->{'maxrecurse'} = $v), return $s) : $s->{'maxrecurse'}; } sub Useperl { my($s, $v) = @_; - defined($v) ? (($s->{'useperl'} = $v), return $s) : $s->{'useperl'}; + @_ >= 2 ? (($s->{'useperl'} = $v), return $s) : $s->{'useperl'}; } sub Sortkeys { my($s, $v) = @_; - defined($v) ? (($s->{'sortkeys'} = $v), return $s) : $s->{'sortkeys'}; + @_ >= 2 ? (($s->{'sortkeys'} = $v), return $s) : $s->{'sortkeys'}; } sub Deparse { my($s, $v) = @_; - defined($v) ? (($s->{'deparse'} = $v), return $s) : $s->{'deparse'}; + @_ >= 2 ? (($s->{'deparse'} = $v), return $s) : $s->{'deparse'}; } sub Sparseseen { my($s, $v) = @_; - defined($v) ? (($s->{'noseen'} = $v), return $s) : $s->{'noseen'}; + @_ >= 2 ? (($s->{'noseen'} = $v), return $s) : $s->{'noseen'}; } # used by qquote below @@ -1465,7 +1474,7 @@ modify it under the same terms as Perl itself. =head1 VERSION -Version 2.167 (January 4 2017) +Version 2.170 =head1 SEE ALSO diff --git a/Dumper.xs b/Dumper.xs index 0e7142e..174562c 100644 --- a/Dumper.xs +++ b/Dumper.xs @@ -12,6 +12,14 @@ # define DD_USE_OLD_ID_FORMAT #endif +#ifndef strlcpy +# ifdef my_strlcpy +# define strlcpy(d,s,l) my_strlcpy(d,s,l) +# else +# define strlcpy(d,s,l) strcpy(d,s) +# endif +#endif + /* These definitions are ASCII only. But the pure-perl .pm avoids * calling this .xs file for releases where they aren't defined */ @@ -41,6 +49,17 @@ || (((UV) (c)) >= '0' && ((UV) (c)) <= '9')) #endif +/* SvPVCLEAR only from perl 5.25.6 */ +#ifndef SvPVCLEAR +# define SvPVCLEAR(sv) sv_setpvs((sv), "") +#endif + +#ifndef memBEGINs +# define memBEGINs(s1, l, s2) \ + ( (l) >= sizeof(s2) - 1 \ + && memEQ(s1, "" s2 "", sizeof(s2)-1)) +#endif + /* 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 @@ -851,7 +870,7 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, SV * const ixsv = newSViv(0); /* allowing for a 24 char wide array index */ New(0, iname, namelen+28, char); - (void)strcpy(iname, name); + (void) strlcpy(iname, name, namelen+28); inamelen = namelen; if (name[0] == '@') { sv_catpvs(retval, "("); @@ -1285,7 +1304,7 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, else if (realtype == SVt_PVGV) {/* GLOBs can end up with scribbly names */ c = SvPV(val, i); if(i) ++c, --i; /* just get the name */ - if (i >= 6 && strncmp(c, "main::", 6) == 0) { + if (memBEGINs(c, i, "main::")) { c += 4; #if PERL_VERSION < 7 if (i == 6 || (i == 7 && c[6] == '\0')) @@ -1295,37 +1314,30 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, i = 0; else i -= 4; } if (globname_needs_quote(c,i)) { -#ifdef GvNAMEUTF8 - if (GvNAMEUTF8(val)) { - sv_grow(retval, SvCUR(retval)+2); + sv_grow(retval, SvCUR(retval)+3); r = SvPVX(retval)+SvCUR(retval); - r[0] = '*'; r[1] = '{'; + r[0] = '*'; r[1] = '{'; r[2] = 0; SvCUR_set(retval, SvCUR(retval)+2); - esc_q_utf8(aTHX_ retval, c, i, 1, style->useqq); + i = 3 + esc_q_utf8(aTHX_ retval, c, i, +#ifdef GvNAMEUTF8 + !!GvNAMEUTF8(val) +#else + 0 +#endif + , style->useqq); sv_grow(retval, SvCUR(retval)+2); r = SvPVX(retval)+SvCUR(retval); r[0] = '}'; r[1] = '\0'; - i = 1; - } - else -#endif - { - sv_grow(retval, SvCUR(retval)+6+2*i); - r = SvPVX(retval)+SvCUR(retval); - r[0] = '*'; r[1] = '{'; r[2] = '\''; - i += esc_q(r+3, c, i); - i += 3; - r[i++] = '\''; r[i++] = '}'; - r[i] = '\0'; - } + SvCUR_set(retval, SvCUR(retval)+1); + r = r+1 - i; } else { sv_grow(retval, SvCUR(retval)+i+2); r = SvPVX(retval)+SvCUR(retval); - r[0] = '*'; strcpy(r+1, c); + r[0] = '*'; strlcpy(r+1, c, SvLEN(retval)); i++; + SvCUR_set(retval, SvCUR(retval)+i); } - SvCUR_set(retval, SvCUR(retval)+i); if (style->purity) { static const char* const entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" }; diff --git a/t/dumper.t b/t/dumper.t index 643160a..e09a2dd 100644 --- a/t/dumper.t +++ b/t/dumper.t @@ -108,7 +108,7 @@ sub SKIP_TEST { ++$TNUM; print "ok $TNUM # skip $reason\n"; } -$TMAX = 450; +$TMAX = 468; # 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 @@ -1740,3 +1740,66 @@ EOT TEST (qq(Dumper("\n")), '\n alone'); TEST (qq(Data::Dumper::DumperX("\n")), '\n alone') if $XS; } +############# +our @globs = map { $_, \$_ } map { *$_ } map { $_, "s::$_" } + "foo", "\1bar", "L\x{e9}on", "m\x{100}cron", "snow\x{2603}"; +$WANT = <<'EOT'; +#$globs = [ +# *::foo, +# \*::foo, +# *s::foo, +# \*s::foo, +# *{"::\1bar"}, +# \*{"::\1bar"}, +# *{"s::\1bar"}, +# \*{"s::\1bar"}, +# *{"::L\351on"}, +# \*{"::L\351on"}, +# *{"s::L\351on"}, +# \*{"s::L\351on"}, +# *{"::m\x{100}cron"}, +# \*{"::m\x{100}cron"}, +# *{"s::m\x{100}cron"}, +# \*{"s::m\x{100}cron"}, +# *{"::snow\x{2603}"}, +# \*{"::snow\x{2603}"}, +# *{"s::snow\x{2603}"}, +# \*{"s::snow\x{2603}"} +#]; +EOT +{ + local $Data::Dumper::Useqq = 1; + TEST (q(Data::Dumper->Dump([\@globs], ["globs"])), 'globs: Dump()'); + TEST (q(Data::Dumper->Dumpxs([\@globs], ["globs"])), 'globs: Dumpxs()') + if $XS; +} +############# +$WANT = <<'EOT'; +#$v = { +# a => \*::ppp, +# b => \*{'::a/b'}, +# c => \*{"::a\x{2603}b"} +#}; +#*::ppp = { +# a => 1 +#}; +#*{'::a/b'} = { +# b => 3 +#}; +#*{"::a\x{2603}b"} = { +# c => 5 +#}; +EOT +{ + *ppp = { a => 1 }; + *{"a/b"} = { b => 3 }; + *{"a\x{2603}b"} = { c => 5 }; + our $v = { a => \*ppp, b => \*{"a/b"}, c => \*{"a\x{2603}b"} }; + local $Data::Dumper::Purity = 1; + TEST (q(Data::Dumper->Dump([$v], ["v"])), 'glob purity: Dump()'); + TEST (q(Data::Dumper->Dumpxs([$v], ["v"])), 'glob purity: Dumpxs()') if $XS; + $WANT =~ tr/'/"/; + local $Data::Dumper::Useqq = 1; + TEST (q(Data::Dumper->Dump([$v], ["v"])), 'glob purity: Dump()'); + TEST (q(Data::Dumper->Dumpxs([$v], ["v"])), 'glob purity: Dumpxs()') if $XS; +} diff --git a/t/indent.t b/t/indent.t index bcfa251..2814f0b 100644 --- a/t/indent.t +++ b/t/indent.t @@ -14,7 +14,7 @@ BEGIN { use strict; use Data::Dumper; -use Test::More tests => 10; +use Test::More tests => 9; use lib qw( ./t/lib ); use Testing qw( _dumptostr ); @@ -34,10 +34,6 @@ $dumper = Data::Dumper->new([$hash]); $dumper->Indent(); $dumpstr{indent_no_arg} = _dumptostr($dumper); -$dumper = Data::Dumper->new([$hash]); -$dumper->Indent(undef); -$dumpstr{indent_undef} = _dumptostr($dumper); - $dumper = Data::Dumper->new([$hash]); $dumper->Indent(0); $dumpstr{indent_0} = _dumptostr($dumper); @@ -59,8 +55,6 @@ $dumpstr{indent_2} = _dumptostr($dumper); is($dumpstr{noindent}, $dumpstr{indent_no_arg}, "absence of Indent is same as Indent()"); -is($dumpstr{noindent}, $dumpstr{indent_undef}, - "absence of Indent is same as Indent(undef)"); isnt($dumpstr{noindent}, $dumpstr{indent_0}, "absence of Indent is different from Indent(0)"); isnt($dumpstr{indent_0}, $dumpstr{indent_1}, diff --git a/t/misc.t b/t/misc.t index 2ce81ac..54a89e6 100644 --- a/t/misc.t +++ b/t/misc.t @@ -15,7 +15,7 @@ BEGIN { use strict; use Data::Dumper; -use Test::More tests => 20; +use Test::More tests => 18; use lib qw( ./t/lib ); use Testing qw( _dumptostr ); @@ -76,17 +76,10 @@ note("Argument validation for new()"); $obj = Data::Dumper->new([$a,$b]); $dumps{'noprev'} = _dumptostr($obj); - $obj = Data::Dumper->new([$a,$b]); - $obj->Pad(undef); - $dumps{'undef'} = _dumptostr($obj); - $obj = Data::Dumper->new([$a,$b]); $obj->Pad(''); $dumps{'emptystring'} = _dumptostr($obj); - is($dumps{'noprev'}, $dumps{'undef'}, - "No setting for \$Data::Dumper::Pad and Pad(undef) give same result"); - is($dumps{'noprev'}, $dumps{'emptystring'}, "No setting for \$Data::Dumper::Pad and Pad('') give same result"); @@ -113,17 +106,10 @@ note("Argument validation for new()"); $obj = Data::Dumper->new([$a,$b]); $dumps{'noprev'} = _dumptostr($obj); - $obj = Data::Dumper->new([$a,$b]); - $obj->Varname(undef); - $dumps{'undef'} = _dumptostr($obj); - $obj = Data::Dumper->new([$a,$b]); $obj->Varname(''); $dumps{'emptystring'} = _dumptostr($obj); - is($dumps{'noprev'}, $dumps{'undef'}, - "No setting for \$Data::Dumper::Varname and Varname(undef) give same result"); - # Because Varname defaults to '$VAR', providing an empty argument to # Varname produces a non-default result. isnt($dumps{'noprev'}, $dumps{'emptystring'}, diff --git a/t/pair.t b/t/pair.t index 9559bdd..c7eafe4 100644 --- a/t/pair.t +++ b/t/pair.t @@ -15,7 +15,7 @@ BEGIN { } use strict; -use vars qw($want_colon $want_comma); +our ($want_colon, $want_comma); use Test::More tests => 9; no warnings qw(once); diff --git a/t/purity_deepcopy_maxdepth.t b/t/purity_deepcopy_maxdepth.t index f287101..3a7dc49 100644 --- a/t/purity_deepcopy_maxdepth.t +++ b/t/purity_deepcopy_maxdepth.t @@ -16,7 +16,7 @@ BEGIN { use strict; use Data::Dumper; -use Test::More tests => 24; +use Test::More tests => 22; use lib qw( ./t/lib ); use Testing qw( _dumptostr ); @@ -80,14 +80,6 @@ note("\$Data::Dumper::Purity and Purity()"); is($dumps{'noprev'}, $dumps{'objzero'}, "No previous Purity setting equivalent to Purity(0)"); - - $purity = undef; - $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]); - $obj->Purity($purity); - $dumps{'objundef'} = _dumptostr($obj); - - is($dumps{'noprev'}, $dumps{'objundef'}, - "No previous Purity setting equivalent to Purity(undef)"); } { @@ -364,13 +356,6 @@ note("\$Data::Dumper::Maxdepth and Maxdepth()"); is($dumps{'noprev'}, $dumps{'maxdepthempty'}, "No previous Maxdepth setting equivalent to Maxdepth() with no argument"); - $obj = Data::Dumper->new([$f], [qw(f)]); - $obj->Maxdepth(undef); - $dumps{'maxdepthundef'} = _dumptostr($obj); - - is($dumps{'noprev'}, $dumps{'maxdepthundef'}, - "No previous Maxdepth setting equivalent to Maxdepth(undef)"); - $maxdepth = 3; $obj = Data::Dumper->new([$f], [qw(f)]); $obj->Maxdepth($maxdepth); diff --git a/t/quotekeys.t b/t/quotekeys.t index 0f6313a..076cdf6 100644 --- a/t/quotekeys.t +++ b/t/quotekeys.t @@ -86,10 +86,9 @@ sub run_tests_for_quotekeys { $obj->Quotekeys($quotekeys); $dumps{'objqkundef'} = _dumptostr($obj); - note("Quotekeys(undef) will fall back to the default value\nfor \$Data::Dumper::Quotekeys, which is a true value."); - isnt($dumps{'ddqkundef'}, $dumps{'objqkundef'}, + is($dumps{'ddqkundef'}, $dumps{'objqkundef'}, "\$Data::Dumper::Quotekeys = undef and Quotekeys(undef) are equivalent"); - isnt($dumps{'ddqkzero'}, $dumps{'objqkundef'}, + is($dumps{'ddqkzero'}, $dumps{'objqkundef'}, "\$Data::Dumper::Quotekeys = undef and = 0 are equivalent"); %dumps = (); diff --git a/t/terse.t b/t/terse.t index a5be980..a815c36 100644 --- a/t/terse.t +++ b/t/terse.t @@ -3,7 +3,7 @@ use strict; use warnings; use Data::Dumper; -use Test::More tests => 6; +use Test::More tests => 10; use lib qw( ./t/lib ); use Testing qw( _dumptostr ); @@ -23,39 +23,26 @@ for my $useperl (0..1) { WANT } -my (%dumpstr); my $dumper; $dumper = Data::Dumper->new([$hash]); -$dumpstr{noterse} = _dumptostr($dumper); -# $VAR1 = { -# 'foo' => 42 -# }; +my $dumpstr_noterse = _dumptostr($dumper); $dumper = Data::Dumper->new([$hash]); $dumper->Terse(); -$dumpstr{terse_no_arg} = _dumptostr($dumper); +is _dumptostr($dumper), $dumpstr_noterse; $dumper = Data::Dumper->new([$hash]); $dumper->Terse(0); -$dumpstr{terse_0} = _dumptostr($dumper); +is _dumptostr($dumper), $dumpstr_noterse; $dumper = Data::Dumper->new([$hash]); $dumper->Terse(1); -$dumpstr{terse_1} = _dumptostr($dumper); -# { -# 'foo' => 42 -# } +isnt _dumptostr($dumper), $dumpstr_noterse; $dumper = Data::Dumper->new([$hash]); -$dumper->Terse(undef); -$dumpstr{terse_undef} = _dumptostr($dumper); - -is($dumpstr{noterse}, $dumpstr{terse_no_arg}, - "absence of Terse is same as Terse()"); -is($dumpstr{noterse}, $dumpstr{terse_0}, - "absence of Terse is same as Terse(0)"); -isnt($dumpstr{noterse}, $dumpstr{terse_1}, - "absence of Terse is different from Terse(1)"); -is($dumpstr{noterse}, $dumpstr{terse_undef}, - "absence of Terse is same as Terse(undef)"); +is $dumper->Terse(1), $dumper; +is $dumper->Terse, 1; +is $dumper->Terse(undef), $dumper; +is $dumper->Terse, undef; +is _dumptostr($dumper), $dumpstr_noterse; -- 2.14.3