diff -uNrp perl-5.16.3.orig/dist/Data-Dumper/Dumper.pm perl-5.16.3/dist/Data-Dumper/Dumper.pm
--- perl-5.16.3.orig/dist/Data-Dumper/Dumper.pm 2013-03-04 10:16:21.000000000 -0500
+++ perl-5.16.3/dist/Data-Dumper/Dumper.pm 2014-10-06 15:01:45.864997882 -0400
@@ -10,8 +10,8 @@
package Data::Dumper;
BEGIN {
- $VERSION = '2.135_06'; # Don't forget to set version and release
-} # date in POD!
+ $VERSION = '2.154'; # Don't forget to set version and release
+} # date in POD below!
#$| = 1;
@@ -30,9 +30,9 @@ BEGIN {
# XSLoader should be attempted to load, or the pure perl flag
# toggled on load failure.
eval {
- require XSLoader;
- XSLoader::load( 'Data::Dumper' );
- 1
+ require XSLoader;
+ XSLoader::load( 'Data::Dumper' );
+ 1
}
or $Useperl = 1;
}
@@ -55,6 +55,8 @@ $Pair = ' => ' unless defined $
$Useperl = 0 unless defined $Useperl;
$Sortkeys = 0 unless defined $Sortkeys;
$Deparse = 0 unless defined $Deparse;
+$Sparseseen = 0 unless defined $Sparseseen;
+$Maxrecurse = 1000 unless defined $Maxrecurse;
#
# expects an arrayref of values to be dumped.
@@ -65,36 +67,38 @@ $Deparse = 0 unless defined $
sub new {
my($c, $v, $n) = @_;
- croak "Usage: PACKAGE->new(ARRAYREF, [ARRAYREF])"
+ croak "Usage: PACKAGE->new(ARRAYREF, [ARRAYREF])"
unless (defined($v) && (ref($v) eq 'ARRAY'));
$n = [] unless (defined($n) && (ref($n) eq 'ARRAY'));
- my($s) = {
- level => 0, # current recursive depth
- indent => $Indent, # various styles of indenting
- pad => $Pad, # all lines prefixed by this string
- xpad => "", # padding-per-level
- apad => "", # added padding for hash keys n such
- sep => "", # list separator
- pair => $Pair, # hash key/value separator: defaults to ' => '
- seen => {}, # local (nested) refs (id => [name, val])
- todump => $v, # values to dump []
- names => $n, # optional names for values []
- varname => $Varname, # prefix to use for tagging nameless ones
- purity => $Purity, # degree to which output is evalable
- useqq => $Useqq, # use "" for strings (backslashitis ensues)
- terse => $Terse, # avoid name output (where feasible)
- freezer => $Freezer, # name of Freezer method for objects
- toaster => $Toaster, # name of method to revive objects
- deepcopy => $Deepcopy, # dont cross-ref, except to stop recursion
- quotekeys => $Quotekeys, # quote hash keys
- 'bless' => $Bless, # keyword to use for "bless"
-# expdepth => $Expdepth, # cutoff depth for explicit dumping
- maxdepth => $Maxdepth, # depth beyond which we give up
- useperl => $Useperl, # use the pure Perl implementation
- sortkeys => $Sortkeys, # flag or filter for sorting hash keys
- deparse => $Deparse, # use B::Deparse for coderefs
- };
+ my($s) = {
+ level => 0, # current recursive depth
+ indent => $Indent, # various styles of indenting
+ pad => $Pad, # all lines prefixed by this string
+ xpad => "", # padding-per-level
+ apad => "", # added padding for hash keys n such
+ sep => "", # list separator
+ pair => $Pair, # hash key/value separator: defaults to ' => '
+ seen => {}, # local (nested) refs (id => [name, val])
+ todump => $v, # values to dump []
+ names => $n, # optional names for values []
+ varname => $Varname, # prefix to use for tagging nameless ones
+ purity => $Purity, # degree to which output is evalable
+ useqq => $Useqq, # use "" for strings (backslashitis ensues)
+ terse => $Terse, # avoid name output (where feasible)
+ freezer => $Freezer, # name of Freezer method for objects
+ toaster => $Toaster, # name of method to revive objects
+ deepcopy => $Deepcopy, # do not cross-ref, except to stop recursion
+ quotekeys => $Quotekeys, # quote hash keys
+ 'bless' => $Bless, # keyword to use for "bless"
+# expdepth => $Expdepth, # cutoff depth for explicit dumping
+ maxdepth => $Maxdepth, # depth beyond which we give up
+ maxrecurse => $Maxrecurse, # depth beyond which we abort
+ useperl => $Useperl, # use the pure Perl implementation
+ sortkeys => $Sortkeys, # flag or filter for sorting hash keys
+ deparse => $Deparse, # use B::Deparse for coderefs
+ noseen => $Sparseseen, # do not populate the seen hash unless necessary
+ };
if ($Indent > 0) {
$s->{xpad} = " ";
@@ -147,21 +151,26 @@ sub Seen {
init_refaddr_format();
my($k, $v, $id);
while (($k, $v) = each %$g) {
- if (defined $v and ref $v) {
- $id = format_refaddr($v);
- if ($k =~ /^[*](.*)$/) {
- $k = (ref $v eq 'ARRAY') ? ( "\\\@" . $1 ) :
- (ref $v eq 'HASH') ? ( "\\\%" . $1 ) :
- (ref $v eq 'CODE') ? ( "\\\&" . $1 ) :
- ( "\$" . $1 ) ;
- }
- elsif ($k !~ /^\$/) {
- $k = "\$" . $k;
- }
- $s->{seen}{$id} = [$k, $v];
+ if (defined $v) {
+ if (ref $v) {
+ $id = format_refaddr($v);
+ if ($k =~ /^[*](.*)$/) {
+ $k = (ref $v eq 'ARRAY') ? ( "\\\@" . $1 ) :
+ (ref $v eq 'HASH') ? ( "\\\%" . $1 ) :
+ (ref $v eq 'CODE') ? ( "\\\&" . $1 ) :
+ ( "\$" . $1 ) ;
+ }
+ elsif ($k !~ /^\$/) {
+ $k = "\$" . $k;
+ }
+ $s->{seen}{$id} = [$k, $v];
+ }
+ else {
+ carp "Only refs supported, ignoring non-ref item \$$k";
+ }
}
else {
- carp "Only refs supported, ignoring non-ref item \$$k";
+ carp "Value of ref must be defined; ignoring undefined item \$$k";
}
}
return $s;
@@ -176,9 +185,14 @@ sub Seen {
#
sub Values {
my($s, $v) = @_;
- if (defined($v) && (ref($v) eq 'ARRAY')) {
- $s->{todump} = [@$v]; # make a copy
- return $s;
+ if (defined($v)) {
+ if (ref($v) eq 'ARRAY') {
+ $s->{todump} = [@$v]; # make a copy
+ return $s;
+ }
+ else {
+ croak "Argument to Values, if provided, must be array ref";
+ }
}
else {
return @{$s->{todump}};
@@ -190,9 +204,14 @@ sub Values {
#
sub Names {
my($s, $n) = @_;
- if (defined($n) && (ref($n) eq 'ARRAY')) {
- $s->{names} = [@$n]; # make a copy
- return $s;
+ if (defined($n)) {
+ if (ref($n) eq 'ARRAY') {
+ $s->{names} = [@$n]; # make a copy
+ return $s;
+ }
+ else {
+ croak "Argument to Names, if provided, must be array ref";
+ }
}
else {
return @{$s->{names}};
@@ -203,9 +222,8 @@ sub DESTROY {}
sub Dump {
return &Dumpxs
- unless $Data::Dumper::Useperl || (ref($_[0]) && $_[0]->{useperl}) ||
- $Data::Dumper::Useqq || (ref($_[0]) && $_[0]->{useqq}) ||
- $Data::Dumper::Deparse || (ref($_[0]) && $_[0]->{deparse});
+ unless $Data::Dumper::Useperl || (ref($_[0]) && $_[0]->{useperl}) ||
+ $Data::Dumper::Deparse || (ref($_[0]) && $_[0]->{deparse});
return &Dumpperl;
}
@@ -223,28 +241,9 @@ sub Dumpperl {
$s = $s->new(@_) unless ref $s;
for $val (@{$s->{todump}}) {
- my $out = "";
@post = ();
$name = $s->{names}[$i++];
- if (defined $name) {
- if ($name =~ /^[*](.*)$/) {
- if (defined $val) {
- $name = (ref $val eq 'ARRAY') ? ( "\@" . $1 ) :
- (ref $val eq 'HASH') ? ( "\%" . $1 ) :
- (ref $val eq 'CODE') ? ( "\*" . $1 ) :
- ( "\$" . $1 ) ;
- }
- else {
- $name = "\$" . $1;
- }
- }
- elsif ($name !~ /^\$/) {
- $name = "\$" . $name;
- }
- }
- else {
- $name = "\$" . $s->{varname} . $i;
- }
+ $name = $s->_refine_name($name, $val, $i);
my $valstr;
{
@@ -254,9 +253,7 @@ sub Dumpperl {
}
$valstr = "$name = " . $valstr . ';' if @post or !$s->{terse};
- $out .= $s->{pad} . $valstr . $s->{sep};
- $out .= $s->{pad} . join(';' . $s->{sep} . $s->{pad}, @post)
- . ';' . $s->{sep} if @post;
+ my $out = $s->_compose_out($valstr, \@post);
push @out, $out;
}
@@ -282,8 +279,7 @@ use constant _bad_vsmg => defined &_vstr
#
sub _dump {
my($s, $val, $name) = @_;
- my($sname);
- my($out, $realpack, $realtype, $type, $ipad, $id, $blesspad);
+ my($out, $type, $id, $sname);
$type = ref $val;
$out = "";
@@ -300,65 +296,70 @@ sub _dump {
}
require Scalar::Util;
- $realpack = Scalar::Util::blessed($val);
- $realtype = $realpack ? Scalar::Util::reftype($val) : ref $val;
+ my $realpack = Scalar::Util::blessed($val);
+ my $realtype = $realpack ? Scalar::Util::reftype($val) : ref $val;
$id = format_refaddr($val);
- # if it has a name, we need to either look it up, or keep a tab
- # on it so we know when we hit it later
- if (defined($name) and length($name)) {
- # keep a tab on it so that we dont fall into recursive pit
- if (exists $s->{seen}{$id}) {
-# if ($s->{expdepth} < $s->{level}) {
- if ($s->{purity} and $s->{level} > 0) {
- $out = ($realtype eq 'HASH') ? '{}' :
- ($realtype eq 'ARRAY') ? '[]' :
- 'do{my $o}' ;
- push @post, $name . " = " . $s->{seen}{$id}[0];
- }
- else {
- $out = $s->{seen}{$id}[0];
- if ($name =~ /^([\@\%])/) {
- my $start = $1;
- if ($out =~ /^\\$start/) {
- $out = substr($out, 1);
- }
- else {
- $out = $start . '{' . $out . '}';
- }
- }
- }
- return $out;
-# }
+ # Note: By this point $name is always defined and of non-zero length.
+ # Keep a tab on it so that we do not fall into recursive pit.
+ if (exists $s->{seen}{$id}) {
+ if ($s->{purity} and $s->{level} > 0) {
+ $out = ($realtype eq 'HASH') ? '{}' :
+ ($realtype eq 'ARRAY') ? '[]' :
+ 'do{my $o}' ;
+ push @post, $name . " = " . $s->{seen}{$id}[0];
}
else {
- # store our name
- $s->{seen}{$id} = [ (($name =~ /^[@%]/) ? ('\\' . $name ) :
- ($realtype eq 'CODE' and
- $name =~ /^[*](.*)$/) ? ('\\&' . $1 ) :
- $name ),
- $val ];
+ $out = $s->{seen}{$id}[0];
+ if ($name =~ /^([\@\%])/) {
+ my $start = $1;
+ if ($out =~ /^\\$start/) {
+ $out = substr($out, 1);
+ }
+ else {
+ $out = $start . '{' . $out . '}';
+ }
+ }
}
+ return $out;
+ }
+ else {
+ # store our name
+ $s->{seen}{$id} = [ (
+ ($name =~ /^[@%]/)
+ ? ('\\' . $name )
+ : ($realtype eq 'CODE' and $name =~ /^[*](.*)$/)
+ ? ('\\&' . $1 )
+ : $name
+ ), $val ];
}
- my $no_bless = 0;
+ my $no_bless = 0;
my $is_regex = 0;
if ( $realpack and ($] >= 5.009005 ? re::is_regexp($val) : $realpack eq 'Regexp') ) {
$is_regex = 1;
$no_bless = $realpack eq 'Regexp';
}
- # If purity is not set and maxdepth is set, then check depth:
+ # If purity is not set and maxdepth is set, then check depth:
# if we have reached maximum depth, return the string
# representation of the thing we are currently examining
- # at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)').
+ # at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)').
if (!$s->{purity}
- and $s->{maxdepth} > 0
- and $s->{level} >= $s->{maxdepth})
+ and defined($s->{maxdepth})
+ and $s->{maxdepth} > 0
+ and $s->{level} >= $s->{maxdepth})
{
return qq['$val'];
}
+ # avoid recursing infinitely [perl #122111]
+ if ($s->{maxrecurse} > 0
+ and $s->{level} >= $s->{maxrecurse}) {
+ die "Recursion limit of $s->{maxrecurse} exceeded";
+ }
+
# we have a blessed ref
+ my ($blesspad);
if ($realpack and !$no_bless) {
$out = $s->{'bless'} . '( ';
$blesspad = $s->{apad};
@@ -366,131 +367,136 @@ sub _dump {
}
$s->{level}++;
- $ipad = $s->{xpad} x $s->{level};
+ my $ipad = $s->{xpad} x $s->{level};
if ($is_regex) {
my $pat;
- # This really sucks, re:regexp_pattern is in ext/re/re.xs and not in
- # universal.c, and even worse we cant just require that re to be loaded
- # we *have* to use() it.
- # We should probably move it to universal.c for 5.10.1 and fix this.
- # Currently we only use re::regexp_pattern when the re is blessed into another
- # package. This has the disadvantage of meaning that a DD dump won't round trip
- # as the pattern will be repeatedly wrapped with the same modifiers.
- # This is an aesthetic issue so we will leave it for now, but we could use
- # regexp_pattern() in list context to get the modifiers separately.
- # But since this means loading the full debugging engine in process we wont
- # bother unless its necessary for accuracy.
- if (($realpack ne 'Regexp') && defined(*re::regexp_pattern{CODE})) {
- $pat = re::regexp_pattern($val);
- } else {
- $pat = "$val";
+ my $flags = "";
+ if (defined(*re::regexp_pattern{CODE})) {
+ ($pat, $flags) = re::regexp_pattern($val);
+ }
+ else {
+ $pat = "$val";
}
$pat =~ s <(\\.)|/> { $1 || '\\/' }ge;
- $out .= "qr/$pat/";
+ $out .= "qr/$pat/$flags";
}
elsif ($realtype eq 'SCALAR' || $realtype eq 'REF'
- || $realtype eq 'VSTRING') {
+ || $realtype eq 'VSTRING') {
if ($realpack) {
- $out .= 'do{\\(my $o = ' . $s->_dump($$val, "\${$name}") . ')}';
+ $out .= 'do{\\(my $o = ' . $s->_dump($$val, "\${$name}") . ')}';
}
else {
- $out .= '\\' . $s->_dump($$val, "\${$name}");
+ $out .= '\\' . $s->_dump($$val, "\${$name}");
}
}
elsif ($realtype eq 'GLOB') {
- $out .= '\\' . $s->_dump($$val, "*{$name}");
+ $out .= '\\' . $s->_dump($$val, "*{$name}");
}
elsif ($realtype eq 'ARRAY') {
my($pad, $mname);
my($i) = 0;
$out .= ($name =~ /^\@/) ? '(' : '[';
$pad = $s->{sep} . $s->{pad} . $s->{apad};
- ($name =~ /^\@(.*)$/) ? ($mname = "\$" . $1) :
- # omit -> if $foo->[0]->{bar}, but not ${$foo->[0]}->{bar}
- ($name =~ /^\\?[\%\@\*\$][^{].*[]}]$/) ? ($mname = $name) :
- ($mname = $name . '->');
+ ($name =~ /^\@(.*)$/) ? ($mname = "\$" . $1) :
+ # omit -> if $foo->[0]->{bar}, but not ${$foo->[0]}->{bar}
+ ($name =~ /^\\?[\%\@\*\$][^{].*[]}]$/) ? ($mname = $name) :
+ ($mname = $name . '->');
$mname .= '->' if $mname =~ /^\*.+\{[A-Z]+\}$/;
for my $v (@$val) {
- $sname = $mname . '[' . $i . ']';
- $out .= $pad . $ipad . '#' . $i if $s->{indent} >= 3;
- $out .= $pad . $ipad . $s->_dump($v, $sname);
- $out .= "," if $i++ < $#$val;
+ $sname = $mname . '[' . $i . ']';
+ $out .= $pad . $ipad . '#' . $i
+ if $s->{indent} >= 3;
+ $out .= $pad . $ipad . $s->_dump($v, $sname);
+ $out .= "," if $i++ < $#$val;
}
$out .= $pad . ($s->{xpad} x ($s->{level} - 1)) if $i;
$out .= ($name =~ /^\@/) ? ')' : ']';
}
elsif ($realtype eq 'HASH') {
- my($k, $v, $pad, $lpad, $mname, $pair);
+ my ($k, $v, $pad, $lpad, $mname, $pair);
$out .= ($name =~ /^\%/) ? '(' : '{';
$pad = $s->{sep} . $s->{pad} . $s->{apad};
$lpad = $s->{apad};
$pair = $s->{pair};
($name =~ /^\%(.*)$/) ? ($mname = "\$" . $1) :
- # omit -> if $foo->[0]->{bar}, but not ${$foo->[0]}->{bar}
- ($name =~ /^\\?[\%\@\*\$][^{].*[]}]$/) ? ($mname = $name) :
- ($mname = $name . '->');
+ # omit -> if $foo->[0]->{bar}, but not ${$foo->[0]}->{bar}
+ ($name =~ /^\\?[\%\@\*\$][^{].*[]}]$/) ? ($mname = $name) :
+ ($mname = $name . '->');
$mname .= '->' if $mname =~ /^\*.+\{[A-Z]+\}$/;
- my ($sortkeys, $keys, $key) = ("$s->{sortkeys}");
+ my $sortkeys = defined($s->{sortkeys}) ? $s->{sortkeys} : '';
+ my $keys = [];
if ($sortkeys) {
- if (ref($s->{sortkeys}) eq 'CODE') {
- $keys = $s->{sortkeys}($val);
- unless (ref($keys) eq 'ARRAY') {
- carp "Sortkeys subroutine did not return ARRAYREF";
- $keys = [];
- }
- }
- else {
- $keys = [ sort keys %$val ];
- }
+ if (ref($s->{sortkeys}) eq 'CODE') {
+ $keys = $s->{sortkeys}($val);
+ unless (ref($keys) eq 'ARRAY') {
+ carp "Sortkeys subroutine did not return ARRAYREF";
+ $keys = [];
+ }
+ }
+ else {
+ $keys = [ sort keys %$val ];
+ }
}
# Ensure hash iterator is reset
keys(%$val);
+ my $key;
while (($k, $v) = ! $sortkeys ? (each %$val) :
- @$keys ? ($key = shift(@$keys), $val->{$key}) :
- () )
+ @$keys ? ($key = shift(@$keys), $val->{$key}) :
+ () )
{
- my $nk = $s->_dump($k, "");
- $nk = $1 if !$s->{quotekeys} and $nk =~ /^[\"\']([A-Za-z_]\w*)[\"\']$/;
- $sname = $mname . '{' . $nk . '}';
- $out .= $pad . $ipad . $nk . $pair;
-
- # temporarily alter apad
- $s->{apad} .= (" " x (length($nk) + 4)) if $s->{indent} >= 2;
- $out .= $s->_dump($val->{$k}, $sname) . ",";
- $s->{apad} = $lpad if $s->{indent} >= 2;
+ my $nk = $s->_dump($k, "");
+
+ # _dump doesn't quote numbers of this form
+ if ($s->{quotekeys} && $nk =~ /^(?:0|-?[1-9][0-9]{0,8})\z/) {
+ $nk = $s->{useqq} ? qq("$nk") : qq('$nk');
+ }
+ elsif (!$s->{quotekeys} and $nk =~ /^[\"\']([A-Za-z_]\w*)[\"\']$/) {
+ $nk = $1
+ }
+
+ $sname = $mname . '{' . $nk . '}';
+ $out .= $pad . $ipad . $nk . $pair;
+
+ # temporarily alter apad
+ $s->{apad} .= (" " x (length($nk) + 4))
+ if $s->{indent} >= 2;
+ $out .= $s->_dump($val->{$k}, $sname) . ",";
+ $s->{apad} = $lpad
+ if $s->{indent} >= 2;
}
if (substr($out, -1) eq ',') {
- chop $out;
- $out .= $pad . ($s->{xpad} x ($s->{level} - 1));
+ chop $out;
+ $out .= $pad . ($s->{xpad} x ($s->{level} - 1));
}
$out .= ($name =~ /^\%/) ? ')' : '}';
}
elsif ($realtype eq 'CODE') {
if ($s->{deparse}) {
- require B::Deparse;
- my $sub = 'sub ' . (B::Deparse->new)->coderef2text($val);
- $pad = $s->{sep} . $s->{pad} . $s->{apad} . $s->{xpad} x ($s->{level} - 1);
- $sub =~ s/\n/$pad/gse;
- $out .= $sub;
- } else {
+ require B::Deparse;
+ my $sub = 'sub ' . (B::Deparse->new)->coderef2text($val);
+ $pad = $s->{sep} . $s->{pad} . $s->{apad} . $s->{xpad} x ($s->{level} - 1);
+ $sub =~ s/\n/$pad/gse;
+ $out .= $sub;
+ }
+ else {
$out .= 'sub { "DUMMY" }';
carp "Encountered CODE ref, using dummy placeholder" if $s->{purity};
}
}
else {
- croak "Can\'t handle $realtype type.";
+ croak "Can't handle '$realtype' type";
}
-
+
if ($realpack and !$no_bless) { # we have a blessed ref
$out .= ', ' . _quote($realpack) . ' )';
- $out .= '->' . $s->{toaster} . '()' if $s->{toaster} ne '';
+ $out .= '->' . $s->{toaster} . '()'
+ if $s->{toaster} ne '';
$s->{apad} = $blesspad;
}
$s->{level}--;
-
}
else { # simple scalar
@@ -501,46 +507,46 @@ sub _dump {
$id = format_refaddr($ref);
if (exists $s->{seen}{$id}) {
if ($s->{seen}{$id}[2]) {
- $out = $s->{seen}{$id}[0];
- #warn "[<$out]\n";
- return "\${$out}";
- }
+ $out = $s->{seen}{$id}[0];
+ #warn "[<$out]\n";
+ return "\${$out}";
+ }
}
else {
- #warn "[>\\$name]\n";
- $s->{seen}{$id} = ["\\$name", $ref];
+ #warn "[>\\$name]\n";
+ $s->{seen}{$id} = ["\\$name", $ref];
}
}
$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::/::/;
- $sname = $name;
+ $name =~ s/^main::/::/;
+ $sname = $name;
}
else {
- $sname = $s->_dump(
- $name eq 'main::' || $] < 5.007 && $name eq "main::\0"
- ? ''
- : $name,
- "",
- );
- $sname = '{' . $sname . '}';
+ $sname = $s->_dump(
+ $name eq 'main::' || $] < 5.007 && $name eq "main::\0"
+ ? ''
+ : $name,
+ "",
+ );
+ $sname = '{' . $sname . '}';
}
if ($s->{purity}) {
- my $k;
- local ($s->{level}) = 0;
- for $k (qw(SCALAR ARRAY HASH)) {
- my $gval = *$val{$k};
- next unless defined $gval;
- next if $k eq "SCALAR" && ! defined $$gval; # always there
-
- # _dump can push into @post, so we hold our place using $postlen
- my $postlen = scalar @post;
- $post[$postlen] = "\*$sname = ";
- local ($s->{apad}) = " " x length($post[$postlen]) if $s->{indent} >= 2;
- $post[$postlen] .= $s->_dump($gval, "\*$sname\{$k\}");
- }
+ my $k;
+ local ($s->{level}) = 0;
+ for $k (qw(SCALAR ARRAY HASH)) {
+ my $gval = *$val{$k};
+ next unless defined $gval;
+ next if $k eq "SCALAR" && ! defined $$gval; # always there
+
+ # _dump can push into @post, so we hold our place using $postlen
+ my $postlen = scalar @post;
+ $post[$postlen] = "\*$sname = ";
+ local ($s->{apad}) = " " x length($post[$postlen]) if $s->{indent} >= 2;
+ $post[$postlen] .= $s->_dump($gval, "\*$sname\{$k\}");
+ }
}
$out .= '*' . $sname;
}
@@ -548,20 +554,21 @@ sub _dump {
$out .= "undef";
}
elsif (defined &_vstring and $v = _vstring($val)
- and !_bad_vsmg || eval $v eq $val) {
+ and !_bad_vsmg || eval $v eq $val) {
$out .= $v;
}
elsif (!defined &_vstring
and ref $ref eq 'VSTRING' || eval{Scalar::Util::isvstring($val)}) {
$out .= sprintf "%vd", $val;
}
- elsif ($val =~ /^(?:0|-?[1-9]\d{0,8})\z/) { # safe decimal number
+ # \d here would treat "1\x{660}" as a safe decimal number
+ elsif ($val =~ /^(?:0|-?[1-9][0-9]{0,8})\z/) { # safe decimal number
$out .= $val;
}
- else { # string
+ else { # string
if ($s->{useqq} or $val =~ tr/\0-\377//c) {
# Fall back to qq if there's Unicode
- $out .= qquote($val, $s->{useqq});
+ $out .= qquote($val, $s->{useqq});
}
else {
$out .= _quote($val);
@@ -580,7 +587,7 @@ sub _dump {
}
return $out;
}
-
+
#
# non-OO style of earlier version
#
@@ -593,12 +600,8 @@ sub DumperX {
return Data::Dumper->Dumpxs([@_], []);
}
-sub Dumpf { return Data::Dumper->Dump(@_) }
-
-sub Dumpp { print Data::Dumper->Dump(@_) }
-
#
-# reset the "seen" cache
+# reset the "seen" cache
#
sub Reset {
my($s) = shift;
@@ -685,6 +688,11 @@ sub Maxdepth {
defined($v) ? (($s->{'maxdepth'} = $v), return $s) : $s->{'maxdepth'};
}
+sub Maxrecurse {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{'maxrecurse'} = $v), return $s) : $s->{'maxrecurse'};
+}
+
sub Useperl {
my($s, $v) = @_;
defined($v) ? (($s->{'useperl'} = $v), return $s) : $s->{'useperl'};
@@ -700,8 +708,13 @@ sub Deparse {
defined($v) ? (($s->{'deparse'} = $v), return $s) : $s->{'deparse'};
}
+sub Sparseseen {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{'noseen'} = $v), return $s) : $s->{'noseen'};
+}
+
# used by qquote below
-my %esc = (
+my %esc = (
"\a" => "\\a",
"\b" => "\\b",
"\t" => "\\t",
@@ -716,8 +729,8 @@ sub qquote {
local($_) = shift;
s/([\\\"\@\$])/\\$1/g;
my $bytes; { use bytes; $bytes = length }
- s/([^\x00-\x7f])/'\x{'.sprintf("%x",ord($1)).'}'/ge if $bytes > length;
- return qq("$_") unless
+ s/([[:^ascii:]])/'\x{'.sprintf("%x",ord($1)).'}'/ge if $bytes > length;
+ return qq("$_") unless
/[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~]/; # fast exit
my $high = shift || "";
@@ -754,6 +767,45 @@ sub qquote {
# access to sortsv() from XS
sub _sortkeys { [ sort keys %{$_[0]} ] }
+sub _refine_name {
+ my $s = shift;
+ my ($name, $val, $i) = @_;
+ if (defined $name) {
+ if ($name =~ /^[*](.*)$/) {
+ if (defined $val) {
+ $name = (ref $val eq 'ARRAY') ? ( "\@" . $1 ) :
+ (ref $val eq 'HASH') ? ( "\%" . $1 ) :
+ (ref $val eq 'CODE') ? ( "\*" . $1 ) :
+ ( "\$" . $1 ) ;
+ }
+ else {
+ $name = "\$" . $1;
+ }
+ }
+ elsif ($name !~ /^\$/) {
+ $name = "\$" . $name;
+ }
+ }
+ else { # no names provided
+ $name = "\$" . $s->{varname} . $i;
+ }
+ return $name;
+}
+
+sub _compose_out {
+ my $s = shift;
+ my ($valstr, $postref) = @_;
+ my $out = "";
+ $out .= $s->{pad} . $valstr . $s->{sep};
+ if (@{$postref}) {
+ $out .= $s->{pad} .
+ join(';' . $s->{sep} . $s->{pad}, @{$postref}) .
+ ';' .
+ $s->{sep};
+ }
+ return $out;
+}
+
1;
__END__
@@ -794,7 +846,8 @@ variable is output in a single Perl stat
structures correctly.
The return value can be C<eval>ed to get back an identical copy of the
-original reference structure.
+original reference structure. (Please do consider the security implications
+of eval'ing code from untrusted sources!)
Any references that are the same as one of those passed in will be named
C<$VAR>I<n> (where I<n> is a numeric suffix), and other duplicate references
@@ -812,7 +865,7 @@ these references. Moreover, if C<eval>e
you need to ensure that any variables it accesses are previously declared.
In the extended usage form, the references to be dumped can be given
-user-specified names. If a name begins with a C<*>, the output will
+user-specified names. If a name begins with a C<*>, the output will
describe the dereferenced type of the supplied reference for hashes and
arrays, and coderefs. Output of names will be avoided where possible if
the C<Terse> flag is set.
@@ -822,7 +875,7 @@ object will return the object itself, so
chained together.
Several styles of output are possible, all controlled by setting
-the C<Indent> flag. See L<Configuration Variables or Methods> below
+the C<Indent> flag. See L<Configuration Variables or Methods> below
for details.
@@ -874,15 +927,21 @@ itself.
=item I<$OBJ>->Values(I<[ARRAYREF]>)
-Queries or replaces the internal array of values that will be dumped.
-When called without arguments, returns the values. Otherwise, returns the
-object itself.
+Queries or replaces the internal array of values that will be dumped. When
+called without arguments, returns the values as a list. When called with a
+reference to an array of replacement values, returns the object itself. When
+called with any other type of argument, dies.
=item I<$OBJ>->Names(I<[ARRAYREF]>)
Queries or replaces the internal array of user supplied names for the values
-that will be dumped. When called without arguments, returns the names.
-Otherwise, returns the object itself.
+that will be dumped. When called without arguments, returns the names. When
+called with an array of replacement names, returns the object itself. If the
+number of replacement names exceeds the number of values to be named, the
+excess names will not be used. If the number of replacement names falls short
+of the number of values to be named, the list of replacement names will be
+exhausted and remaining values will not be renamed. When
+called with any other type of argument, dies.
=item I<$OBJ>->Reset
@@ -909,7 +968,7 @@ in a list context.
Several configuration variables can be used to control the kind of output
generated when using the procedural interface. These variables are usually
C<local>ized in a block so that other parts of the code are not affected by
-the change.
+the change.
These variables determine the default state of the object created by calling
the C<new> method, but cannot be used to alter the state of the object
@@ -1022,7 +1081,7 @@ Cross-referencing will then only be done
$Data::Dumper::Quotekeys I<or> $I<OBJ>->Quotekeys(I<[NEWVAL]>)
Can be set to a boolean value to control whether hash keys are quoted.
-A false value will avoid quoting hash keys when it looks like a simple
+A defined false value will avoid quoting hash keys when it looks like a simple
string. Default is 1, which will always enclose hash keys in quotes.
=item *
@@ -1054,8 +1113,18 @@ $Data::Dumper::Maxdepth I<or> $I<OBJ>-
Can be set to a positive integer that specifies the depth beyond which
we don't venture into a structure. Has no effect when
C<Data::Dumper::Purity> is set. (Useful in debugger when we often don't
-want to see more than enough). Default is 0, which means there is
-no maximum depth.
+want to see more than enough). Default is 0, which means there is
+no maximum depth.
+
+=item *
+
+$Data::Dumper::Maxrecurse I<or> $I<OBJ>->Maxrecurse(I<[NEWVAL]>)
+
+Can be set to a positive integer that specifies the depth beyond which
+recursion into a structure will throw an exception. This is intended
+as a security measure to prevent perl running out of stack space when
+dumping an excessively deep structure. Can be set to 0 to remove the
+limit. Default is 1000.
=item *
@@ -1099,6 +1168,26 @@ XSUB implementation doesn't support it.
Caution : use this option only if you know that your coderefs will be
properly reconstructed by C<B::Deparse>.
+=item *
+
+$Data::Dumper::Sparseseen I<or> $I<OBJ>->Sparseseen(I<[NEWVAL]>)
+
+By default, Data::Dumper builds up the "seen" hash of scalars that
+it has encountered during serialization. This is very expensive.
+This seen hash is necessary to support and even just detect circular
+references. It is exposed to the user via the C<Seen()> call both
+for writing and reading.
+
+If you, as a user, do not need explicit access to the "seen" hash,
+then you can set the C<Sparseseen> option to allow Data::Dumper
+to eschew building the "seen" hash for scalars that are known not
+to possess more than one reference. This speeds up serialization
+considerably if you use the XS implementation.
+
+Note: If you turn on C<Sparseseen>, then you must not rely on the
+content of the seen hash since its contents will be an
+implementation detail!
+
=back
=head2 Exports
@@ -1130,7 +1219,7 @@ distribution for more examples.)
$foo = Foo->new;
$fuz = Fuz->new;
$boo = [ 1, [], "abcd", \*foo,
- {1 => 'a', 023 => 'b', 0x45 => 'c'},
+ {1 => 'a', 023 => 'b', 0x45 => 'c'},
\\"p\q\'r", $foo, $fuz];
########
@@ -1220,20 +1309,20 @@ distribution for more examples.)
sub new { bless { state => 'awake' }, shift }
sub Freeze {
my $s = shift;
- print STDERR "preparing to sleep\n";
- $s->{state} = 'asleep';
- return bless $s, 'Foo::ZZZ';
+ print STDERR "preparing to sleep\n";
+ $s->{state} = 'asleep';
+ return bless $s, 'Foo::ZZZ';
}
package Foo::ZZZ;
sub Thaw {
my $s = shift;
- print STDERR "waking up\n";
- $s->{state} = 'awake';
- return bless $s, 'Foo';
+ print STDERR "waking up\n";
+ $s->{state} = 'awake';
+ return bless $s, 'Foo';
}
- package Foo;
+ package main;
use Data::Dumper;
$a = Foo->new;
$b = Data::Dumper->new([$a], ['c']);
@@ -1326,13 +1415,13 @@ be to use the C<Sortkeys> filter of Data
Gurusamy Sarathy gsar@activestate.com
-Copyright (c) 1996-98 Gurusamy Sarathy. All rights reserved.
+Copyright (c) 1996-2014 Gurusamy Sarathy. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=head1 VERSION
-Version 2.135_06 (March 20 2012)
+Version 2.154 (September 18 2014)
=head1 SEE ALSO
diff -uNrp perl-5.16.3.orig/dist/Data-Dumper/Dumper.xs perl-5.16.3/dist/Data-Dumper/Dumper.xs
--- perl-5.16.3.orig/dist/Data-Dumper/Dumper.xs 2013-03-04 10:16:21.000000000 -0500
+++ perl-5.16.3/dist/Data-Dumper/Dumper.xs 2014-10-06 15:01:46.304999478 -0400
@@ -12,22 +12,32 @@
# define DD_USE_OLD_ID_FORMAT
#endif
+#ifndef isWORDCHAR
+# define isWORDCHAR(c) isALNUM(c)
+#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);
-static I32 needs_quote(register const char *s, STRLEN len);
+static I32 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);
+ I32 maxdepth, SV *sortkeys, int use_sparse_seen_hash, I32 useqq, IV maxrecurse);
#ifndef HvNAME_get
#define HvNAME_get HvNAME
#endif
+/* Perls 7 through portions of 15 used utf8_to_uvchr() which didn't have a
+ * length parameter. This wrongly allowed reading beyond the end of buffer
+ * given malformed input */
+
#if PERL_VERSION <= 6 /* Perl 5.6 and earlier */
# ifdef EBCDIC
@@ -47,11 +57,33 @@ Perl_utf8_to_uvchr_buf(pTHX_ U8 *s, U8 *
# if !defined(PERL_IMPLICIT_CONTEXT)
# define utf8_to_uvchr_buf Perl_utf8_to_uvchr_buf
# else
-# define utf8_to_uvchr_buf(a,b) Perl_utf8_to_uvchr_buf(aTHX_ a,b)
+# define utf8_to_uvchr_buf(a,b,c) Perl_utf8_to_uvchr_buf(aTHX_ a,b,c)
# endif
#endif /* PERL_VERSION <= 6 */
+/* Perl 5.7 through part of 5.15 */
+#if PERL_VERSION > 6 && PERL_VERSION <= 15 && ! defined(utf8_to_uvchr_buf)
+
+UV
+Perl_utf8_to_uvchr_buf(pTHX_ U8 *s, U8 *send, STRLEN *retlen)
+{
+ /* We have to discard <send> for these versions; hence can read off the
+ * 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);
+}
+
+# if !defined(PERL_IMPLICIT_CONTEXT)
+# define utf8_to_uvchr_buf Perl_utf8_to_uvchr_buf
+# else
+# define utf8_to_uvchr_buf(a,b,c) Perl_utf8_to_uvchr_buf(aTHX_ a,b,c)
+# endif
+
+#endif /* PERL_VERSION > 6 && <= 15 */
+
/* Changes in 5.7 series mean that now IOK is only set if scalar is
precisely integer but in 5.6 and earlier we need to do a more
complex test */
@@ -61,39 +93,95 @@ Perl_utf8_to_uvchr_buf(pTHX_ U8 *s, U8 *
#define DD_is_integer(sv) SvIOK(sv)
#endif
-/* does a string need to be protected? */
-static I32
-needs_quote(register const char *s, STRLEN len)
+/* does a glob name need to be protected? */
+static bool
+globname_needs_quote(const char *s, STRLEN len)
{
const char *send = s+len;
TOP:
if (s[0] == ':') {
if (++s<send) {
if (*s++ != ':')
- return 1;
+ return TRUE;
}
else
- return 1;
+ return TRUE;
}
if (isIDFIRST(*s)) {
while (++s<send)
- if (!isALNUM(*s)) {
+ if (!isWORDCHAR(*s)) {
if (*s == ':')
goto TOP;
else
- return 1;
+ return TRUE;
}
}
else
- return 1;
- return 0;
+ return TRUE;
+
+ return FALSE;
+}
+
+/* does a hash key need to be quoted (to the left of => ).
+ Previously this used (globname_)needs_quote() which accepted strings
+ like '::foo', but these aren't safe as unquoted keys under strict.
+*/
+static bool
+key_needs_quote(const char *s, STRLEN len) {
+ const char *send = s+len;
+
+ if (safe_decimal_number(s, len)) {
+ return FALSE;
+ }
+ else if (isIDFIRST(*s)) {
+ while (++s<send)
+ if (!isWORDCHAR(*s))
+ return TRUE;
+ }
+ else
+ return TRUE;
+
+ return FALSE;
+}
+
+/* Check that the SV can be represented as a simple decimal integer.
+ *
+ * The perl code does this by matching against /^(?:0|-?[1-9]\d{0,8})\z/
+*/
+static bool
+safe_decimal_number(const char *p, STRLEN len) {
+ if (len == 1 && *p == '0')
+ return TRUE;
+
+ if (len && *p == '-') {
+ ++p;
+ --len;
+ }
+
+ if (len == 0 || *p < '1' || *p > '9')
+ return FALSE;
+
+ ++p;
+ --len;
+
+ if (len > 8)
+ return FALSE;
+
+ while (len > 0) {
+ /* the perl code checks /\d/ but we don't want unicode digits here */
+ if (*p < '0' || *p > '9')
+ return FALSE;
+ ++p;
+ --len;
+ }
+ return TRUE;
}
/* count the number of "'"s and "\"s in string */
static I32
-num_q(register const char *s, register STRLEN slen)
+num_q(const char *s, STRLEN slen)
{
- register I32 ret = 0;
+ I32 ret = 0;
while (slen > 0) {
if (*s == '\'' || *s == '\\')
@@ -109,9 +197,9 @@ num_q(register const char *s, register S
/* slen number of characters in s will be escaped */
/* destination must be long enough for additional chars */
static I32
-esc_q(register char *d, register const char *s, register STRLEN slen)
+esc_q(char *d, const char *s, STRLEN slen)
{
- register I32 ret = 0;
+ I32 ret = 0;
while (slen > 0) {
switch (*s) {
@@ -119,6 +207,7 @@ esc_q(register char *d, register const c
case '\\':
*d = '\\';
++d; ++ret;
+ /* FALLTHROUGH */
default:
*d = *s;
++d; ++s; --slen;
@@ -128,8 +217,9 @@ esc_q(register char *d, register const c
return ret;
}
+/* this function is also misused for implementing $Useqq */
static I32
-esc_q_utf8(pTHX_ SV* sv, register const char *src, register STRLEN slen)
+esc_q_utf8(pTHX_ SV* sv, const char *src, STRLEN slen, I32 do_utf8, I32 useqq)
{
char *r, *rstart;
const char *s = src;
@@ -144,14 +234,21 @@ esc_q_utf8(pTHX_ SV* sv, register const
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; s += increment) {
- const UV k = utf8_to_uvchr_buf((U8*)s, (U8*) send, NULL);
+ 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);
+ /* 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);
+
#ifdef EBCDIC
if (!isprint(k) || k > 256) {
#else
@@ -165,6 +262,17 @@ esc_q_utf8(pTHX_ SV* sv, register const
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;
+#endif
} else if (k == '\\') {
backslashes++;
} else if (k == '\'') {
@@ -175,7 +283,7 @@ esc_q_utf8(pTHX_ SV* sv, register const
normal++;
}
}
- if (grow) {
+ if (grow || useqq) {
/* We have something needing hex. 3 is ""\0 */
sv_grow(sv, cur + 3 + grow + 2*backslashes + single_quotes
+ 2*qq_escapables + normal);
@@ -183,8 +291,8 @@ esc_q_utf8(pTHX_ SV* sv, register const
*r++ = '"';
- for (s = src; s < send; s += UTF8SKIP(s)) {
- const UV k = utf8_to_uvchr_buf((U8*)s, (U8*) send, NULL);
+ 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;
if (k == '"' || k == '\\' || k == '$' || k == '@') {
*r++ = '\\';
@@ -194,7 +302,44 @@ esc_q_utf8(pTHX_ SV* sv, register const
#ifdef EBCDIC
if (isprint(k) && k < 256)
#else
- if (k < 0x80)
+ if (useqq && (k <= 31 || k == 127 || (!do_utf8 && k > 127))) {
+ 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;
+ 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';
+
+ /* faster than
+ * r = r + my_sprintf(r, "%o", k);
+ */
+ if (k <= 7 && !next_is_digit) {
+ *r++ = (char)k + '0';
+ } else if (k <= 63 && !next_is_digit) {
+ *r++ = (char)(k>>3) + '0';
+ *r++ = (char)(k&7) + '0';
+ } else {
+ *r++ = (char)(k>>6) + '0';
+ *r++ = (char)((k&63)>>3) + '0';
+ *r++ = (char)(k&7) + '0';
+ }
+ }
+ }
+ else if (k < 0x80)
#endif
*r++ = (char)k;
else {
@@ -234,7 +379,7 @@ static SV *
sv_x(pTHX_ SV *sv, const char *str, STRLEN len, I32 n)
{
if (!sv)
- sv = newSVpvn("", 0);
+ sv = newSVpvs("");
#ifdef DEBUGGING
else
assert(SvTYPE(sv) >= SVt_PV);
@@ -267,10 +412,11 @@ 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)
+ I32 deepcopy, I32 quotekeys, SV *bless, I32 maxdepth, SV *sortkeys,
+ int use_sparse_seen_hash, I32 useqq, IV maxrecurse)
{
char tmpbuf[128];
- U32 i;
+ Size_t i;
char *c, *r, *realpack;
#ifdef DD_USE_OLD_ID_FORMAT
char id[128];
@@ -317,7 +463,7 @@ DD_dump(pTHX_ SV *val, const char *name,
{
dSP; ENTER; SAVETMPS; PUSHMARK(sp);
XPUSHs(val); PUTBACK;
- i = perl_call_method(SvPVX_const(freezer), G_EVAL|G_VOID);
+ i = perl_call_method(SvPVX_const(freezer), G_EVAL|G_VOID|G_DISCARD);
SPAGAIN;
if (SvTRUE(ERRSV))
warn("WARNING(Freezer method call failed): %"SVf"", ERRSV);
@@ -352,13 +498,13 @@ DD_dump(pTHX_ SV *val, const char *name,
SV *postentry;
if (realtype == SVt_PVHV)
- sv_catpvn(retval, "{}", 2);
+ sv_catpvs(retval, "{}");
else if (realtype == SVt_PVAV)
- sv_catpvn(retval, "[]", 2);
+ sv_catpvs(retval, "[]");
else
- sv_catpvn(retval, "do{my $o}", 9);
+ sv_catpvs(retval, "do{my $o}");
postentry = newSVpvn(name, namelen);
- sv_catpvn(postentry, " = ", 3);
+ sv_catpvs(postentry, " = ");
sv_catsv(postentry, othername);
av_push(postav, postentry);
}
@@ -371,9 +517,9 @@ DD_dump(pTHX_ SV *val, const char *name,
}
else {
sv_catpvn(retval, name, 1);
- sv_catpvn(retval, "{", 1);
+ sv_catpvs(retval, "{");
sv_catsv(retval, othername);
- sv_catpvn(retval, "}", 1);
+ sv_catpvs(retval, "}");
}
}
else
@@ -393,11 +539,11 @@ DD_dump(pTHX_ SV *val, const char *name,
else { /* store our name and continue */
SV *namesv;
if (name[0] == '@' || name[0] == '%') {
- namesv = newSVpvn("\\", 1);
+ namesv = newSVpvs("\\");
sv_catpvn(namesv, name, namelen);
}
else if (realtype == SVt_PVCV && name[0] == '*') {
- namesv = newSVpvn("\\", 2);
+ namesv = newSVpvs("\\");
sv_catpvn(namesv, name, namelen);
(SvPVX(namesv))[1] = '&';
}
@@ -438,17 +584,21 @@ DD_dump(pTHX_ SV *val, const char *name,
if (!purity && maxdepth > 0 && *levelp >= maxdepth) {
STRLEN vallen;
const char * const valstr = SvPV(val,vallen);
- sv_catpvn(retval, "'", 1);
+ sv_catpvs(retval, "'");
sv_catpvn(retval, valstr, vallen);
- sv_catpvn(retval, "'", 1);
+ sv_catpvs(retval, "'");
return 1;
}
+ if (maxrecurse > 0 && *levelp >= maxrecurse) {
+ croak("Recursion limit of %" IVdf " exceeded", maxrecurse);
+ }
+
if (realpack && !no_bless) { /* we have a blessed ref */
STRLEN blesslen;
const char * const blessstr = SvPV(bless, blesslen);
sv_catpvn(retval, blessstr, blesslen);
- sv_catpvn(retval, "( ", 2);
+ sv_catpvs(retval, "( ");
if (indent >= 2) {
blesspad = apad;
apad = newSVsv(apad);
@@ -462,21 +612,58 @@ DD_dump(pTHX_ SV *val, const char *name,
if (is_regex)
{
STRLEN rlen;
- const char *rval = SvPV(val, rlen);
- const char * const rend = rval+rlen;
- const char *slash = rval;
- sv_catpvn(retval, "qr/", 3);
+ SV *sv_pattern = NULL;
+ SV *sv_flags = NULL;
+ CV *re_pattern_cv;
+ const char *rval;
+ const char *rend;
+ const char *slash;
+
+ if ((re_pattern_cv = get_cv("re::regexp_pattern", 0))) {
+ dSP;
+ I32 count;
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(SP);
+ XPUSHs(val);
+ PUTBACK;
+ count = call_sv((SV*)re_pattern_cv, G_ARRAY);
+ SPAGAIN;
+ if (count >= 2) {
+ sv_flags = POPs;
+ sv_pattern = POPs;
+ SvREFCNT_inc(sv_flags);
+ SvREFCNT_inc(sv_pattern);
+ }
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+ if (sv_pattern) {
+ sv_2mortal(sv_pattern);
+ sv_2mortal(sv_flags);
+ }
+ }
+ else {
+ sv_pattern = val;
+ }
+ assert(sv_pattern);
+ rval = SvPV(sv_pattern, rlen);
+ rend = rval+rlen;
+ slash = rval;
+ sv_catpvs(retval, "qr/");
for (;slash < rend; slash++) {
if (*slash == '\\') { ++slash; continue; }
if (*slash == '/') {
sv_catpvn(retval, rval, slash-rval);
- sv_catpvn(retval, "\\/", 2);
+ sv_catpvs(retval, "\\/");
rlen -= slash-rval+1;
rval = slash+1;
}
}
sv_catpvn(retval, rval, rlen);
- sv_catpvn(retval, "/", 1);
+ sv_catpvs(retval, "/");
+ if (sv_flags)
+ sv_catsv(retval, sv_flags);
}
else if (
#if PERL_VERSION < 9
@@ -485,41 +672,44 @@ DD_dump(pTHX_ SV *val, const char *name,
realtype <= SVt_PVMG
#endif
) { /* scalar ref */
- SV * const namesv = newSVpvn("${", 2);
+ SV * const namesv = newSVpvs("${");
sv_catpvn(namesv, name, namelen);
- sv_catpvn(namesv, "}", 1);
+ sv_catpvs(namesv, "}");
if (realpack) { /* blessed */
- sv_catpvn(retval, "do{\\(my $o = ", 13);
+ 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);
- sv_catpvn(retval, ")}", 2);
+ maxdepth, sortkeys, use_sparse_seen_hash, useqq,
+ maxrecurse);
+ sv_catpvs(retval, ")}");
} /* plain */
else {
- sv_catpvn(retval, "\\", 1);
+ 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);
+ maxdepth, sortkeys, use_sparse_seen_hash, useqq,
+ maxrecurse);
}
SvREFCNT_dec(namesv);
}
else if (realtype == SVt_PVGV) { /* glob ref */
- SV * const namesv = newSVpvn("*{", 2);
+ SV * const namesv = newSVpvs("*{");
sv_catpvn(namesv, name, namelen);
- sv_catpvn(namesv, "}", 1);
- sv_catpvn(retval, "\\", 1);
+ 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);
+ maxdepth, sortkeys, use_sparse_seen_hash, useqq,
+ maxrecurse);
SvREFCNT_dec(namesv);
}
else if (realtype == SVt_PVAV) {
SV *totpad;
- I32 ix = 0;
- const I32 ixmax = av_len((AV *)ival);
+ SSize_t ix = 0;
+ const SSize_t ixmax = av_len((AV *)ival);
SV * const ixsv = newSViv(0);
/* allowing for a 24 char wide array index */
@@ -527,11 +717,11 @@ DD_dump(pTHX_ SV *val, const char *name,
(void)strcpy(iname, name);
inamelen = namelen;
if (name[0] == '@') {
- sv_catpvn(retval, "(", 1);
+ sv_catpvs(retval, "(");
iname[0] = '$';
}
else {
- sv_catpvn(retval, "[", 1);
+ sv_catpvs(retval, "[");
/* omit "->" in $foo{bar}->[0], but not in ${$foo}->[0] */
/*if (namelen > 0
&& name[namelen-1] != ']' && name[namelen-1] != '}'
@@ -578,7 +768,7 @@ DD_dump(pTHX_ SV *val, const char *name,
if (indent >= 3) {
sv_catsv(retval, totpad);
sv_catsv(retval, ipad);
- sv_catpvn(retval, "#", 1);
+ sv_catpvs(retval, "#");
sv_catsv(retval, ixsv);
}
sv_catsv(retval, totpad);
@@ -586,9 +776,10 @@ DD_dump(pTHX_ SV *val, const char *name,
DD_dump(aTHX_ elem, iname, ilen, retval, seenhv, postav,
levelp, indent, pad, xpad, apad, sep, pair,
freezer, toaster, purity, deepcopy, quotekeys, bless,
- maxdepth, sortkeys);
+ maxdepth, sortkeys, use_sparse_seen_hash,
+ useqq, maxrecurse);
if (ix < ixmax)
- sv_catpvn(retval, ",", 1);
+ sv_catpvs(retval, ",");
}
if (ixmax >= 0) {
SV * const opad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), (*levelp)-1);
@@ -597,9 +788,9 @@ DD_dump(pTHX_ SV *val, const char *name,
SvREFCNT_dec(opad);
}
if (name[0] == '@')
- sv_catpvn(retval, ")", 1);
+ sv_catpvs(retval, ")");
else
- sv_catpvn(retval, "]", 1);
+ sv_catpvs(retval, "]");
SvREFCNT_dec(ixsv);
SvREFCNT_dec(totpad);
Safefree(iname);
@@ -615,11 +806,11 @@ DD_dump(pTHX_ SV *val, const char *name,
SV * const iname = newSVpvn(name, namelen);
if (name[0] == '%') {
- sv_catpvn(retval, "(", 1);
+ sv_catpvs(retval, "(");
(SvPVX(iname))[0] = '$';
}
else {
- sv_catpvn(retval, "{", 1);
+ sv_catpvs(retval, "{");
/* omit "->" in $foo[0]->{bar}, but not in ${$foo}->{bar} */
if ((namelen > 0
&& name[namelen-1] != ']' && name[namelen-1] != '}')
@@ -627,16 +818,16 @@ DD_dump(pTHX_ SV *val, const char *name,
&& (name[1] == '{'
|| (name[0] == '\\' && name[2] == '{'))))
{
- sv_catpvn(iname, "->", 2);
+ sv_catpvs(iname, "->");
}
}
if (name[0] == '*' && name[namelen-1] == '}' && namelen >= 8 &&
(instr(name+namelen-8, "{SCALAR}") ||
instr(name+namelen-7, "{ARRAY}") ||
instr(name+namelen-6, "{HASH}"))) {
- sv_catpvn(iname, "->", 2);
+ sv_catpvs(iname, "->");
}
- sv_catpvn(iname, "{", 1);
+ sv_catpvs(iname, "{");
totpad = newSVsv(sep);
sv_catsv(totpad, pad);
sv_catsv(totpad, apad);
@@ -645,7 +836,7 @@ DD_dump(pTHX_ SV *val, const char *name,
if (sortkeys) {
if (sortkeys == &PL_sv_yes) {
#if PERL_VERSION < 8
- sortkeys = sv_2mortal(newSVpvn("Data::Dumper::_sortkeys", 23));
+ sortkeys = sv_2mortal(newSVpvs("Data::Dumper::_sortkeys"));
#else
keys = newAV();
(void)hv_iterinit((HV*)ival);
@@ -654,16 +845,25 @@ DD_dump(pTHX_ SV *val, const char *name,
(void)SvREFCNT_inc(sv);
av_push(keys, sv);
}
-# ifdef USE_LOCALE_NUMERIC
- sortsv(AvARRAY(keys),
- av_len(keys)+1,
- IN_LOCALE ? Perl_sv_cmp_locale : Perl_sv_cmp);
-# else
- sortsv(AvARRAY(keys),
- av_len(keys)+1,
- Perl_sv_cmp);
+# ifdef USE_LOCALE_COLLATE
+# ifdef IN_LC /* Use this if available */
+ if (IN_LC(LC_COLLATE))
+# else
+ if (IN_LOCALE)
+# endif
+ {
+ sortsv(AvARRAY(keys),
+ av_len(keys)+1,
+ Perl_sv_cmp_locale);
+ }
+ else
# endif
#endif
+ {
+ sortsv(AvARRAY(keys),
+ av_len(keys)+1,
+ Perl_sv_cmp);
+ }
}
if (sortkeys != &PL_sv_yes) {
dSP; ENTER; SAVETMPS; PUSHMARK(sp);
@@ -696,13 +896,13 @@ DD_dump(pTHX_ SV *val, const char *name,
bool do_utf8 = FALSE;
if (sortkeys) {
- if (!(keys && (I32)i <= av_len(keys))) break;
+ if (!(keys && (SSize_t)i <= av_len(keys))) break;
} else {
if (!(entry = hv_iternext((HV *)ival))) break;
}
if (i)
- sv_catpvn(retval, ",", 1);
+ sv_catpvs(retval, ",");
if (sortkeys) {
char *key;
@@ -724,31 +924,27 @@ DD_dump(pTHX_ SV *val, const char *name,
sv_catsv(retval, totpad);
sv_catsv(retval, ipad);
- /* old logic was first to check utf8 flag, and if utf8 always
+ /* The (very)
+ old logic was first to check utf8 flag, and if utf8 always
call esc_q_utf8. This caused test to break under -Mutf8,
because there even strings like 'c' have utf8 flag on.
Hence with quotekeys == 0 the XS code would still '' quote
them based on flags, whereas the perl code would not,
based on regexps.
- The perl code is correct.
- needs_quote() decides that anything that isn't a valid
- perl identifier needs to be quoted, hence only correctly
- formed strings with no characters outside [A-Za-z0-9_:]
- won't need quoting. None of those characters are used in
- the byte encoding of utf8, so anything with utf8
- encoded characters in will need quoting. Hence strings
- with utf8 encoded characters in will end up inside do_utf8
- just like before, but now strings with utf8 flag set but
- only ascii characters will end up in the unquoted section.
-
- There should also be less tests for the (probably currently)
- more common doesn't need quoting case.
- The code is also smaller (22044 vs 22260) because I've been
- able to pull the common logic out to both sides. */
- if (quotekeys || needs_quote(key,keylen)) {
- if (do_utf8) {
+
+ The old logic checked that the string was a valid
+ perl glob name (foo::bar), which isn't safe under
+ strict, and differs from the perl code which only
+ accepts simple identifiers.
+
+ With the fix for [perl #120384] I chose to make
+ their handling of key quoting compatible between XS
+ and perl.
+ */
+ if (quotekeys || key_needs_quote(key,keylen)) {
+ if (do_utf8 || useqq) {
STRLEN ocur = SvCUR(retval);
- nlen = esc_q_utf8(aTHX_ retval, key, klen);
+ nlen = esc_q_utf8(aTHX_ retval, key, klen, do_utf8, useqq);
nkey = SvPVX(retval) + ocur;
}
else {
@@ -773,7 +969,7 @@ DD_dump(pTHX_ SV *val, const char *name,
}
sname = newSVsv(iname);
sv_catpvn(sname, nkey, nlen);
- sv_catpvn(sname, "}", 1);
+ sv_catpvs(sname, "}");
sv_catsv(retval, pair);
if (indent >= 2) {
@@ -793,7 +989,8 @@ DD_dump(pTHX_ SV *val, const char *name,
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);
+ maxdepth, sortkeys, use_sparse_seen_hash, useqq,
+ maxrecurse);
SvREFCNT_dec(sname);
Safefree(nkey_buffer);
if (indent >= 2)
@@ -806,14 +1003,14 @@ DD_dump(pTHX_ SV *val, const char *name,
SvREFCNT_dec(opad);
}
if (name[0] == '%')
- sv_catpvn(retval, ")", 1);
+ sv_catpvs(retval, ")");
else
- sv_catpvn(retval, "}", 1);
+ sv_catpvs(retval, "}");
SvREFCNT_dec(iname);
SvREFCNT_dec(totpad);
}
else if (realtype == SVt_PVCV) {
- sv_catpvn(retval, "sub { \"DUMMY\" }", 15);
+ sv_catpvs(retval, "sub { \"DUMMY\" }");
if (purity)
warn("Encountered CODE ref, using dummy placeholder");
}
@@ -829,7 +1026,7 @@ DD_dump(pTHX_ SV *val, const char *name,
SvREFCNT_dec(apad);
apad = blesspad;
}
- sv_catpvn(retval, ", '", 3);
+ sv_catpvs(retval, ", '");
plen = strlen(realpack);
pticks = num_q(realpack, plen);
@@ -848,11 +1045,11 @@ DD_dump(pTHX_ SV *val, const char *name,
else {
sv_catpvn(retval, realpack, strlen(realpack));
}
- sv_catpvn(retval, "' )", 3);
+ sv_catpvs(retval, "' )");
if (toaster && SvPOK(toaster) && SvCUR(toaster)) {
- sv_catpvn(retval, "->", 2);
+ sv_catpvs(retval, "->");
sv_catsv(retval, toaster);
- sv_catpvn(retval, "()", 2);
+ sv_catpvs(retval, "()");
}
}
SvREFCNT_dec(ipad);
@@ -877,14 +1074,21 @@ DD_dump(pTHX_ SV *val, const char *name,
if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp)
&& (svp = av_fetch(seenentry, 2, FALSE)) && *svp && SvIV(*svp) > 0)
{
- sv_catpvn(retval, "${", 2);
+ sv_catpvs(retval, "${");
sv_catsv(retval, othername);
- sv_catpvn(retval, "}", 1);
+ sv_catpvs(retval, "}");
return 1;
}
}
- else if (val != &PL_sv_undef) {
- SV * const namesv = newSVpvn("\\", 1);
+ /* If we're allowed to keep only a sparse "seen" hash
+ * (IOW, the user does not expect it to contain everything
+ * after the dump, then only store in seen hash if the SV
+ * ref count is larger than 1. If it's 1, then we know that
+ * 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)) {
+ SV * const namesv = newSVpvs("\\");
sv_catpvn(namesv, name, namelen);
seenentry = newAV();
av_push(seenentry, namesv);
@@ -928,14 +1132,14 @@ DD_dump(pTHX_ SV *val, const char *name,
#endif
i = 0; else i -= 4;
}
- if (needs_quote(c,i)) {
+ if (globname_needs_quote(c,i)) {
#ifdef GvNAMEUTF8
if (GvNAMEUTF8(val)) {
sv_grow(retval, SvCUR(retval)+2);
r = SvPVX(retval)+SvCUR(retval);
r[0] = '*'; r[1] = '{';
SvCUR_set(retval, SvCUR(retval)+2);
- esc_q_utf8(aTHX_ retval, c, i);
+ esc_q_utf8(aTHX_ retval, c, i, 1, useqq);
sv_grow(retval, SvCUR(retval)+2);
r = SvPVX(retval)+SvCUR(retval);
r[0] = '}'; r[1] = '\0';
@@ -965,8 +1169,8 @@ DD_dump(pTHX_ SV *val, const char *name,
static const char* const entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" };
static const STRLEN sizes[] = { 8, 7, 6 };
SV *e;
- SV * const nname = newSVpvn("", 0);
- SV * const newapad = newSVpvn("", 0);
+ SV * const nname = newSVpvs("");
+ SV * const newapad = newSVpvs("");
GV * const gv = (GV*)val;
I32 j;
@@ -983,7 +1187,7 @@ DD_dump(pTHX_ SV *val, const char *name,
sv_setsv(nname, postentry);
sv_catpvn(nname, entries[j], sizes[j]);
- sv_catpvn(postentry, " = ", 3);
+ sv_catpvs(postentry, " = ");
av_push(postav, postentry);
e = newRV_inc(e);
@@ -995,7 +1199,8 @@ DD_dump(pTHX_ SV *val, const char *name,
seenhv, postav, &nlevel, indent, pad, xpad,
newapad, sep, pair, freezer, toaster, purity,
deepcopy, quotekeys, bless, maxdepth,
- sortkeys);
+ sortkeys, use_sparse_seen_hash, useqq,
+ maxrecurse);
SvREFCNT_dec(e);
}
}
@@ -1005,11 +1210,11 @@ DD_dump(pTHX_ SV *val, const char *name,
}
}
else if (val == &PL_sv_undef || !SvOK(val)) {
- sv_catpvn(retval, "undef", 5);
+ sv_catpvs(retval, "undef");
}
#ifdef SvVOK
else if (SvMAGICAL(val) && (mg = mg_find(val, 'V'))) {
-# ifndef PL_vtbl_vstring
+# if !defined(PL_vtbl_vstring) && PERL_VERSION < 17
SV * const vecsv = sv_newmortal();
# if PERL_VERSION < 10
scan_vstring(mg->mg_ptr, vecsv);
@@ -1021,11 +1226,20 @@ DD_dump(pTHX_ SV *val, const char *name,
sv_catpvn(retval, (const char *)mg->mg_ptr, mg->mg_len);
}
#endif
+
else {
integer_came_from_string:
- c = SvPV(val, i);
- if (DO_UTF8(val))
- i += esc_q_utf8(aTHX_ retval, c, i);
+ c = SvPV(val, i);
+ /* the pure perl and XS non-qq outputs have historically been
+ * different in this case, but for useqq, let's try to match
+ * the pure perl code.
+ * see [perl #74798]
+ */
+ if (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 {
sv_grow(retval, SvCUR(retval)+3+2*i); /* 3: ""\0 */
r = SvPVX(retval) + SvCUR(retval);
@@ -1056,7 +1270,7 @@ MODULE = Data::Dumper PACKAGE = Data::D
#
# This is the exact equivalent of Dump. Well, almost. The things that are
# different as of now (due to Laziness):
-# * doesn't do double-quotes yet.
+# * doesn't deparse yet.'
#
void
@@ -1070,13 +1284,16 @@ Data_Dumper_Dumpxs(href, ...)
HV *seenhv = NULL;
AV *postav, *todumpav, *namesav;
I32 level = 0;
- I32 indent, terse, i, imax, postlen;
+ I32 indent, terse, useqq;
+ 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;
char tmpbuf[1024];
I32 gimme = GIMME;
+ int use_sparse_seen_hash = 0;
if (!SvROK(href)) { /* call new to get an object first */
if (items < 2)
@@ -1086,10 +1303,11 @@ Data_Dumper_Dumpxs(href, ...)
SAVETMPS;
PUSHMARK(sp);
- XPUSHs(href);
- XPUSHs(sv_2mortal(newSVsv(ST(1))));
+ EXTEND(SP, 3); /* 3 == max of all branches below */
+ PUSHs(href);
+ PUSHs(sv_2mortal(newSVsv(ST(1))));
if (items >= 3)
- XPUSHs(sv_2mortal(newSVsv(ST(2))));
+ PUSHs(sv_2mortal(newSVsv(ST(2))));
PUTBACK;
i = perl_call_method("new", G_SCALAR);
SPAGAIN;
@@ -1109,16 +1327,20 @@ Data_Dumper_Dumpxs(href, ...)
= freezer = toaster = bless = sortkeys = &PL_sv_undef;
name = sv_newmortal();
indent = 2;
- terse = purity = deepcopy = 0;
+ terse = purity = deepcopy = useqq = 0;
quotekeys = 1;
- retval = newSVpvn("", 0);
+ retval = newSVpvs("");
if (SvROK(href)
&& (hv = (HV*)SvRV((SV*)href))
&& SvTYPE(hv) == SVt_PVHV) {
if ((svp = hv_fetch(hv, "seen", 4, FALSE)) && SvROK(*svp))
seenhv = (HV*)SvRV(*svp);
+ else
+ use_sparse_seen_hash = 1;
+ if ((svp = hv_fetch(hv, "noseen", 6, FALSE)))
+ 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))
@@ -1129,10 +1351,8 @@ Data_Dumper_Dumpxs(href, ...)
purity = SvIV(*svp);
if ((svp = hv_fetch(hv, "terse", 5, FALSE)))
terse = SvTRUE(*svp);
-#if 0 /* useqq currently unused */
if ((svp = hv_fetch(hv, "useqq", 5, FALSE)))
useqq = SvTRUE(*svp);
-#endif
if ((svp = hv_fetch(hv, "pad", 3, FALSE)))
pad = *svp;
if ((svp = hv_fetch(hv, "xpad", 4, FALSE)))
@@ -1157,6 +1377,8 @@ Data_Dumper_Dumpxs(href, ...)
bless = *svp;
if ((svp = hv_fetch(hv, "maxdepth", 8, FALSE)))
maxdepth = SvIV(*svp);
+ if ((svp = hv_fetch(hv, "maxrecurse", 10, FALSE)))
+ maxrecurse = SvIV(*svp);
if ((svp = hv_fetch(hv, "sortkeys", 8, FALSE))) {
sortkeys = *svp;
if (! SvTRUE(sortkeys))
@@ -1174,7 +1396,7 @@ Data_Dumper_Dumpxs(href, ...)
imax = av_len(todumpav);
else
imax = -1;
- valstr = newSVpvn("",0);
+ valstr = newSVpvs("");
for (i = 0; i <= imax; ++i) {
SV *newapad;
@@ -1236,7 +1458,8 @@ Data_Dumper_Dumpxs(href, ...)
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);
+ bless, maxdepth, sortkeys, use_sparse_seen_hash,
+ useqq, maxrecurse);
SPAGAIN;
if (indent >= 2 && !terse)
@@ -1246,13 +1469,13 @@ Data_Dumper_Dumpxs(href, ...)
if (postlen >= 0 || !terse) {
sv_insert(valstr, 0, 0, " = ", 3);
sv_insert(valstr, 0, 0, SvPVX_const(name), SvCUR(name));
- sv_catpvn(valstr, ";", 1);
+ sv_catpvs(valstr, ";");
}
sv_catsv(retval, pad);
sv_catsv(retval, valstr);
sv_catsv(retval, sep);
if (postlen >= 0) {
- I32 i;
+ SSize_t i;
sv_catsv(retval, pad);
for (i = 0; i <= postlen; ++i) {
SV *elem;
@@ -1260,20 +1483,20 @@ Data_Dumper_Dumpxs(href, ...)
if (svp && (elem = *svp)) {
sv_catsv(retval, elem);
if (i < postlen) {
- sv_catpvn(retval, ";", 1);
+ sv_catpvs(retval, ";");
sv_catsv(retval, sep);
sv_catsv(retval, pad);
}
}
}
- sv_catpvn(retval, ";", 1);
+ sv_catpvs(retval, ";");
sv_catsv(retval, sep);
}
sv_setpvn(valstr, "", 0);
if (gimme == G_ARRAY) {
XPUSHs(sv_2mortal(retval));
if (i < imax) /* not the last time thro ? */
- retval = newSVpvn("",0);
+ retval = newSVpvs("");
}
}
SvREFCNT_dec(postav);
diff -uNrp perl-5.16.3.orig/dist/Data-Dumper/t/recurse.t perl-5.16.3/dist/Data-Dumper/t/recurse.t
--- perl-5.16.3.orig/dist/Data-Dumper/t/recurse.t 1969-12-31 19:00:00.000000000 -0500
+++ perl-5.16.3/dist/Data-Dumper/t/recurse.t 2014-10-06 15:01:35.444960100 -0400
@@ -0,0 +1,45 @@
+#!perl
+
+# Test the Maxrecurse option
+
+use strict;
+use Test::More tests => 32;
+use Data::Dumper;
+
+SKIP: {
+ skip "no XS available", 16
+ if $Data::Dumper::Useperl;
+ local $Data::Dumper::Useperl = 1;
+ test_recursion();
+}
+
+test_recursion();
+
+sub test_recursion {
+ my $pp = $Data::Dumper::Useperl ? "pure perl" : "XS";
+ $Data::Dumper::Purity = 1; # make sure this has no effect
+ $Data::Dumper::Indent = 0;
+ $Data::Dumper::Maxrecurse = 1;
+ is(eval { Dumper([]) }, '$VAR1 = [];', "$pp: maxrecurse 1, []");
+ is(eval { Dumper([[]]) }, undef, "$pp: maxrecurse 1, [[]]");
+ ok($@, "exception thrown");
+ is(eval { Dumper({}) }, '$VAR1 = {};', "$pp: maxrecurse 1, {}");
+ is(eval { Dumper({ a => 1 }) }, q($VAR1 = {'a' => 1};),
+ "$pp: maxrecurse 1, { a => 1 }");
+ is(eval { Dumper({ a => {} }) }, undef, "$pp: maxrecurse 1, { a => {} }");
+ ok($@, "exception thrown");
+ is(eval { Dumper(\1) }, "\$VAR1 = \\1;", "$pp: maxrecurse 1, \\1");
+ is(eval { Dumper(\\1) }, undef, "$pp: maxrecurse 1, \\1");
+ ok($@, "exception thrown");
+ $Data::Dumper::Maxrecurse = 3;
+ is(eval { Dumper(\1) }, "\$VAR1 = \\1;", "$pp: maxrecurse 3, \\1");
+ is(eval { Dumper(\(my $s = {})) }, "\$VAR1 = \\{};", "$pp: maxrecurse 3, \\{}");
+ is(eval { Dumper(\(my $s = { a => [] })) }, "\$VAR1 = \\{'a' => []};",
+ "$pp: maxrecurse 3, \\{ a => [] }");
+ is(eval { Dumper(\(my $s = { a => [{}] })) }, undef,
+ "$pp: maxrecurse 3, \\{ a => [{}] }");
+ ok($@, "exception thrown");
+ $Data::Dumper::Maxrecurse = 0;
+ is(eval { Dumper([[[[[]]]]]) }, q($VAR1 = [[[[[]]]]];),
+ "$pp: check Maxrecurse doesn't set limit to 0 recursion");
+}
diff -uNrp perl-5.16.3.orig/MANIFEST perl-5.16.3/MANIFEST
--- perl-5.16.3.orig/MANIFEST 2013-03-04 10:16:21.000000000 -0500
+++ perl-5.16.3/MANIFEST 2014-10-06 15:07:21.676221279 -0400
@@ -3079,6 +3079,7 @@ dist/Data-Dumper/t/overload.t See if Dat
dist/Data-Dumper/t/pair.t See if Data::Dumper pair separator works
dist/Data-Dumper/t/perl-74170.t Regression test for stack reallocation
dist/Data-Dumper/t/qr.t See if Data::Dumper works with qr|/|
+dist/Data-Dumper/t/recurse.t See if Data::Dumper::Maxrecurse works
dist/Data-Dumper/t/terse.t See if Data::Dumper terse option works
dist/Devel-SelfStubber/lib/Devel/SelfStubber.pm Generate stubs for SelfLoader.pm
dist/Devel-SelfStubber/t/Devel-SelfStubber.t See if Devel::SelfStubber works
