dist/Data-Dumper/Dumper.pm Data pretty printer, module
dist/Data-Dumper/Dumper.xs Data pretty printer, externals
dist/Data-Dumper/t/bless.t See if Data::Dumper works
+dist/Data-Dumper/t/bless_var_method.t See if Data::Dumper::Bless works
dist/Data-Dumper/t/bugs.t See if Data::Dumper works
+dist/Data-Dumper/t/deparse.t See if Data::Dumper::Deparse works
dist/Data-Dumper/t/dumper.t See if Data::Dumper works
-dist/Data-Dumper/t/freezer.t See if $Data::Dumper::Freezer works
+dist/Data-Dumper/t/dumpperl.t See if Data::Dumper::Dumpperl works
+dist/Data-Dumper/t/freezer.t See if Data::Dumper::Freezer works
+dist/Data-Dumper/t/indent.t See if Data::Dumper::Indent works
+dist/Data-Dumper/t/lib/Testing.pm Functions used in testing Data-Dumper
+dist/Data-Dumper/t/misc.t Miscellaneous tests for Data-Dumper
+dist/Data-Dumper/t/names.t See if Data::Dumper::Names works
dist/Data-Dumper/Todo Data pretty printer, futures
dist/Data-Dumper/t/overload.t See if Data::Dumper works for overloaded data
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/purity_deepcopy_maxdepth.t See if three Data::Dumper functions work
dist/Data-Dumper/t/qr.t See if Data::Dumper works with qr|/|
+dist/Data-Dumper/t/quotekeys.t See if Data::Dumper::Quotekeys works
+dist/Data-Dumper/t/seen.t See if Data::Dumper::Seen works
+dist/Data-Dumper/t/sortkeys.t See if Data::Dumper::Sortkeys works
+dist/Data-Dumper/t/sparseseen.t See if Data::Dumper::Sparseseen works
dist/Data-Dumper/t/terse.t See if Data::Dumper terse option works
+dist/Data-Dumper/t/toaster.t See if Data::Dumper::Toaster works
+dist/Data-Dumper/t/values.t See if Data::Dumper::Values 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
dist/Dumpvalue/lib/Dumpvalue.pm Screen dump of perl values
package Data::Dumper;
BEGIN {
- $VERSION = '2.141'; # Don't forget to set version and release
-} # date in POD below!
+ $VERSION = '2.142'; # Don't forget to set version and release
+} # date in POD below!
#$| = 1;
# 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;
}
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
- noseen => $Sparseseen, # do not populate the seen hash unless necessary
- };
+ 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
+ noseen => $Sparseseen, # do not populate the seen hash unless necessary
+ };
if ($Indent > 0) {
$s->{xpad} = " ";
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;
#
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}};
#
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}};
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::Useqq || (ref($_[0]) && $_[0]->{useqq}) ||
+ $Data::Dumper::Deparse || (ref($_[0]) && $_[0]->{deparse});
return &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;
{
}
$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;
}
#
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 = "";
}
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 dont 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'];
}
# we have a blessed ref
+ my ($blesspad);
if ($realpack and !$no_bless) {
$out = $s->{'bless'} . '( ';
$blesspad = $s->{apad};
}
$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
+ # 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 *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
# 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";
+ $pat = re::regexp_pattern($val);
+ }
+ else {
+ $pat = "$val";
}
$pat =~ s <(\\.)|/> { $1 || '\\/' }ge;
$out .= "qr/$pat/";
}
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, "");
+ $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;
}
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
$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;
}
$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
elsif ($val =~ /^(?:0|-?[1-9]\d{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);
}
return $out;
}
-
+
#
# non-OO style of earlier version
#
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;
}
# used by qquote below
-my %esc = (
+my %esc = (
"\a" => "\\a",
"\b" => "\\b",
"\t" => "\\t",
s/([\\\"\@\$])/\\$1/g;
my $bytes; { use bytes; $bytes = length }
s/([^\x00-\x7f])/'\x{'.sprintf("%x",ord($1)).'}'/ge if $bytes > length;
- return qq("$_") unless
+ return qq("$_") unless
/[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~]/; # fast exit
my $high = shift || "";
# 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__
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.
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.
=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 replacment 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 replacment names will be
+exhausted and remaining values will not be renamed. When
+called with any other type of argument, dies.
=item I<$OBJ>->Reset
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
$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 *
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 *
$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];
########
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']);
=head1 VERSION
-Version 2.141 (January 13 2013)
+Version 2.142 (January 13 2013)
=head1 SEE ALSO
--- /dev/null
+#!./perl -w
+# t/bless.t - Test Bless()
+
+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 tests => 8;
+use lib qw( ./t/lib );
+use Testing qw( _dumptostr );
+
+my %d = (
+ delta => 'd',
+ beta => 'b',
+ gamma => 'c',
+ alpha => 'a',
+);
+
+{
+ my ($obj, %dumps, $bless, $starting);
+
+ note("\$Data::Dumper::Bless and Bless() set to true value");
+ note("XS implementation");
+ $Data::Dumper::Useperl = 0;
+
+ $starting = $Data::Dumper::Bless;
+ $bless = 1;
+ local $Data::Dumper::Bless = $bless;
+ $obj = Data::Dumper->new( [ \%d ] );
+ $dumps{'ddblessone'} = _dumptostr($obj);
+ local $Data::Dumper::Bless = $starting;
+
+ $obj = Data::Dumper->new( [ \%d ] );
+ $obj->Bless($bless);
+ $dumps{'objblessone'} = _dumptostr($obj);
+
+ is($dumps{'ddblessone'}, $dumps{'objblessone'},
+ "\$Data::Dumper::Bless = 1 and Bless(1) are equivalent");
+ %dumps = ();
+
+ $bless = 0;
+ local $Data::Dumper::Bless = $bless;
+ $obj = Data::Dumper->new( [ \%d ] );
+ $dumps{'ddblesszero'} = _dumptostr($obj);
+ local $Data::Dumper::Bless = $starting;
+
+ $obj = Data::Dumper->new( [ \%d ] );
+ $obj->Bless($bless);
+ $dumps{'objblesszero'} = _dumptostr($obj);
+
+ is($dumps{'ddblesszero'}, $dumps{'objblesszero'},
+ "\$Data::Dumper::Bless = 0 and Bless(0) are equivalent");
+
+ $bless = undef;
+ local $Data::Dumper::Bless = $bless;
+ $obj = Data::Dumper->new( [ \%d ] );
+ $dumps{'ddblessundef'} = _dumptostr($obj);
+ local $Data::Dumper::Bless = $starting;
+
+ $obj = Data::Dumper->new( [ \%d ] );
+ $obj->Bless($bless);
+ $dumps{'objblessundef'} = _dumptostr($obj);
+
+ is($dumps{'ddblessundef'}, $dumps{'objblessundef'},
+ "\$Data::Dumper::Bless = undef and Bless(undef) are equivalent");
+ is($dumps{'ddblesszero'}, $dumps{'objblessundef'},
+ "\$Data::Dumper::Bless = undef and = 0 are equivalent");
+ %dumps = ();
+
+ note("Perl implementation");
+ $Data::Dumper::Useperl = 1;
+
+ $starting = $Data::Dumper::Bless;
+ $bless = 1;
+ local $Data::Dumper::Bless = $bless;
+ $obj = Data::Dumper->new( [ \%d ] );
+ $dumps{'ddblessone'} = _dumptostr($obj);
+ local $Data::Dumper::Bless = $starting;
+
+ $obj = Data::Dumper->new( [ \%d ] );
+ $obj->Bless($bless);
+ $dumps{'objblessone'} = _dumptostr($obj);
+
+ is($dumps{'ddblessone'}, $dumps{'objblessone'},
+ "\$Data::Dumper::Bless = 1 and Bless(1) are equivalent");
+ %dumps = ();
+
+ $bless = 0;
+ local $Data::Dumper::Bless = $bless;
+ $obj = Data::Dumper->new( [ \%d ] );
+ $dumps{'ddblesszero'} = _dumptostr($obj);
+ local $Data::Dumper::Bless = $starting;
+
+ $obj = Data::Dumper->new( [ \%d ] );
+ $obj->Bless($bless);
+ $dumps{'objblesszero'} = _dumptostr($obj);
+
+ is($dumps{'ddblesszero'}, $dumps{'objblesszero'},
+ "\$Data::Dumper::Bless = 0 and Bless(0) are equivalent");
+
+ $bless = undef;
+ local $Data::Dumper::Bless = $bless;
+ $obj = Data::Dumper->new( [ \%d ] );
+ $dumps{'ddblessundef'} = _dumptostr($obj);
+ local $Data::Dumper::Bless = $starting;
+
+ $obj = Data::Dumper->new( [ \%d ] );
+ $obj->Bless($bless);
+ $dumps{'objblessundef'} = _dumptostr($obj);
+
+ is($dumps{'ddblessundef'}, $dumps{'objblessundef'},
+ "\$Data::Dumper::Bless = undef and Bless(undef) are equivalent");
+ is($dumps{'ddblesszero'}, $dumps{'objblessundef'},
+ "\$Data::Dumper::Bless = undef and = 0 are equivalent");
+ %dumps = ();
+}
+
#!perl
#
-# regression tests for old bugs that don't fit other categories
+# regression tests for old bugs that do not fit other categories
BEGIN {
require Config; import Config;
--- /dev/null
+#!./perl -w
+# t/deparse.t - Test Deparse()
+
+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 tests => 8;
+use lib qw( ./t/lib );
+use Testing qw( _dumptostr );
+
+# Thanks to Arthur Axel "fREW" Schmidt:
+# http://search.cpan.org/~frew/Data-Dumper-Concise-2.020/lib/Data/Dumper/Concise.pm
+
+note("\$Data::Dumper::Deparse and Deparse()");
+
+{
+ my ($obj, %dumps, $deparse, $starting);
+ use strict;
+ my $struct = { foo => "bar\nbaz", quux => sub { "fleem" } };
+ $obj = Data::Dumper->new( [ $struct ] );
+ $dumps{'noprev'} = _dumptostr($obj);
+
+ $starting = $Data::Dumper::Deparse;
+ local $Data::Dumper::Deparse = 0;
+ $obj = Data::Dumper->new( [ $struct ] );
+ $dumps{'dddzero'} = _dumptostr($obj);
+ local $Data::Dumper::Deparse = $starting;
+
+ $obj = Data::Dumper->new( [ $struct ] );
+ $obj->Deparse();
+ $dumps{'objempty'} = _dumptostr($obj);
+
+ $obj = Data::Dumper->new( [ $struct ] );
+ $obj->Deparse(0);
+ $dumps{'objzero'} = _dumptostr($obj);
+
+ is($dumps{'noprev'}, $dumps{'dddzero'},
+ "No previous setting and \$Data::Dumper::Deparse = 0 are equivalent");
+ is($dumps{'noprev'}, $dumps{'objempty'},
+ "No previous setting and Deparse() are equivalent");
+ is($dumps{'noprev'}, $dumps{'objzero'},
+ "No previous setting and Deparse(0) are equivalent");
+
+ local $Data::Dumper::Deparse = 1;
+ $obj = Data::Dumper->new( [ $struct ] );
+ $dumps{'dddtrue'} = _dumptostr($obj);
+ local $Data::Dumper::Deparse = $starting;
+
+ $obj = Data::Dumper->new( [ $struct ] );
+ $obj->Deparse(1);
+ $dumps{'objone'} = _dumptostr($obj);
+
+ is($dumps{'dddtrue'}, $dumps{'objone'},
+ "\$Data::Dumper::Deparse = 1 and Deparse(1) are equivalent");
+
+ isnt($dumps{'dddzero'}, $dumps{'dddtrue'},
+ "\$Data::Dumper::Deparse = 0 differs from \$Data::Dumper::Deparse = 1");
+
+ like($dumps{'dddzero'},
+ qr/quux.*?sub.*?DUMMY/s,
+ "\$Data::Dumper::Deparse = 0 reports DUMMY instead of deparsing coderef");
+ unlike($dumps{'dddtrue'},
+ qr/quux.*?sub.*?DUMMY/s,
+ "\$Data::Dumper::Deparse = 1 does not report DUMMY");
+ like($dumps{'dddtrue'},
+ qr/quux.*?sub.*?use\sstrict.*?fleem/s,
+ "\$Data::Dumper::Deparse = 1 deparses coderef");
+}
+
$dogs[2] = \%kennel;
$mutts = \%kennel;
$mutts = $mutts; # avoid warning
-
+
############# 85
##
$WANT = <<'EOT';
$d->Dumpxs;
);
}
-
+
############# 91
##
$WANT = <<'EOT';
TEST q($d->Dump);
TEST q($d->Dumpxs) if $XS;
-
+
############# 97
##
$WANT = <<'EOT';
#%mutts = %kennels;
EOT
-
+
TEST q($d->Reset; $d->Dump);
if ($XS) {
TEST q($d->Reset; $d->Dumpxs);
$d->Dumpxs;
);
}
-
+
############# 109
##
TEST q($d->Reset->Dump);
if ($XS) {
TEST q($d->Reset->Dumpxs);
}
-
+
}
{
local $Data::Dumper::Sortkeys = \&sort205;
sub sort205 {
my $hash = shift;
- return [
+ return [
$hash eq $c ? (sort { $a <=> $b } keys %$hash)
: (reverse sort keys %$hash)
];
--- /dev/null
+#!./perl -w
+# t/dumpperl.t - test all branches of, and modes of triggering, Dumpperl()
+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 Carp;
+use Data::Dumper;
+$Data::Dumper::Indent=1;
+use Test::More tests => 22;
+use lib qw( ./t/lib );
+use Testing qw( _dumptostr );
+my ($a, $b, $obj);
+my (@names);
+my (@newnames, $objagain, %newnames);
+my $dumpstr;
+$a = 'alpha';
+$b = 'beta';
+my @c = ( qw| eta theta | );
+my %d = ( iota => 'kappa' );
+my $realtype;
+
+local $Data::Dumper::Useperl=1;
+
+note('Data::Dumper::Useperl; names not provided');
+
+$obj = Data::Dumper->new([$a, $b]);
+$dumpstr = _dumptostr($obj);
+like($dumpstr,
+ qr/\$VAR1.+alpha.+\$VAR2.+beta/s,
+ "Dump: two strings"
+);
+
+$obj = Data::Dumper->new([$a, \@c]);
+$dumpstr = _dumptostr($obj);
+like($dumpstr,
+ qr/\$VAR1.+alpha.+\$VAR2.+\[.+eta.+theta.+\]/s,
+ "Dump: one string, one array ref"
+);
+
+$obj = Data::Dumper->new([$a, \%d]);
+$dumpstr = _dumptostr($obj);
+like($dumpstr,
+ qr/\$VAR1.+alpha.+\$VAR2.+\{.+iota.+kappa.+\}/s,
+ "Dump: one string, one hash ref"
+);
+
+$obj = Data::Dumper->new([$a, undef]);
+$dumpstr = _dumptostr($obj);
+like($dumpstr,
+ qr/\$VAR1.+alpha.+\$VAR2.+undef/s,
+ "Dump: one string, one undef"
+);
+
+note('Data::Dumper::Useperl; names provided');
+
+$obj = Data::Dumper->new([$a, $b], [ qw( a b ) ]);
+$dumpstr = _dumptostr($obj);
+like($dumpstr,
+ qr/\$a.+alpha.+\$b.+beta/s,
+ "Dump: names: two strings"
+);
+
+$obj = Data::Dumper->new([$a, \@c], [ qw( a *c ) ]);
+$dumpstr = _dumptostr($obj);
+like($dumpstr,
+ qr/\$a.+alpha.+\@c.+eta.+theta/s,
+ "Dump: names: one string, one array ref"
+);
+
+$obj = Data::Dumper->new([$a, \%d], [ qw( a *d ) ]);
+$dumpstr = _dumptostr($obj);
+like($dumpstr,
+ qr/\$a.+alpha.+\%d.+iota.+kappa/s,
+ "Dump: names: one string, one hash ref"
+);
+
+$obj = Data::Dumper->new([$a,undef], [qw(a *c)]);
+$dumpstr = _dumptostr($obj);
+like($dumpstr,
+ qr/\$a.+alpha.+\$c.+undef/s,
+ "Dump: names: one string, one undef"
+);
+
+$obj = Data::Dumper->new([$a, $b], [ 'a', '']);
+$dumpstr = _dumptostr($obj);
+like($dumpstr,
+ qr/\$a.+alpha.+\$.+beta/s,
+ "Dump: names: two strings: one name empty"
+);
+
+$obj = Data::Dumper->new([$a, $b], [ 'a', '$foo']);
+$dumpstr = _dumptostr($obj);
+no warnings 'uninitialized';
+like($dumpstr,
+ qr/\$a.+alpha.+\$foo.+beta/s,
+ "Dump: names: two strings: one name start with '\$'"
+);
+use warnings;
+
+local $Data::Dumper::Useperl=0;
+
+# Setting aside quoting, Useqq should produce same output as Useperl.
+# Both will exercise Dumpperl().
+# So will run the same tests as above.
+note('Data::Dumper::Useqq');
+
+local $Data::Dumper::Useqq=1;
+
+$obj = Data::Dumper->new([$a, $b]);
+$dumpstr = _dumptostr($obj);
+like($dumpstr,
+ qr/\$VAR1.+alpha.+\$VAR2.+beta/s,
+ "Dump: two strings"
+);
+
+$obj = Data::Dumper->new([$a, \@c]);
+$dumpstr = _dumptostr($obj);
+like($dumpstr,
+ qr/\$VAR1.+alpha.+\$VAR2.+\[.+eta.+theta.+\]/s,
+ "Dump: one string, one array ref"
+);
+
+$obj = Data::Dumper->new([$a, \%d]);
+$dumpstr = _dumptostr($obj);
+like($dumpstr,
+ qr/\$VAR1.+alpha.+\$VAR2.+\{.+iota.+kappa.+\}/s,
+ "Dump: one string, one hash ref"
+);
+
+$obj = Data::Dumper->new([$a, undef]);
+$dumpstr = _dumptostr($obj);
+like($dumpstr,
+ qr/\$VAR1.+alpha.+\$VAR2.+undef/s,
+ "Dump: one string, one undef"
+);
+
+local $Data::Dumper::Useqq=0;
+
+# Deparse should produce same output as Useperl.
+# Both will exercise Dumpperl().
+# So will run the same tests as above.
+note('Data::Dumper::Deparse');
+
+local $Data::Dumper::Deparse=1;
+
+$obj = Data::Dumper->new([$a, $b]);
+$dumpstr = _dumptostr($obj);
+like($dumpstr,
+ qr/\$VAR1.+alpha.+\$VAR2.+beta/s,
+ "Dump: two strings"
+);
+
+$obj = Data::Dumper->new([$a, \@c]);
+$dumpstr = _dumptostr($obj);
+like($dumpstr,
+ qr/\$VAR1.+alpha.+\$VAR2.+\[.+eta.+theta.+\]/s,
+ "Dump: one string, one array ref"
+);
+
+$obj = Data::Dumper->new([$a, \%d]);
+$dumpstr = _dumptostr($obj);
+like($dumpstr,
+ qr/\$VAR1.+alpha.+\$VAR2.+\{.+iota.+kappa.+\}/s,
+ "Dump: one string, one hash ref"
+);
+
+$obj = Data::Dumper->new([$a, undef]);
+$dumpstr = _dumptostr($obj);
+like($dumpstr,
+ qr/\$VAR1.+alpha.+\$VAR2.+undef/s,
+ "Dump: one string, one undef"
+);
+
+local $Data::Dumper::Deparse=0;
+
+{
+ my (%dumps, $starting);
+
+ $starting = $Data::Dumper::Useperl;
+
+ local $Data::Dumper::Useperl = 0;
+ $obj = Data::Dumper->new([$a, $b]);
+ $dumps{'dduzero'} = _dumptostr($obj);
+
+ local $Data::Dumper::Useperl = undef;
+ $obj = Data::Dumper->new([$a, $b]);
+ $dumps{'dduundef'} = _dumptostr($obj);
+
+ $Data::Dumper::Useperl= $starting;
+
+ $obj = Data::Dumper->new([$a, $b]);
+ $obj->Useperl(0);
+ $dumps{'useperlzero'} = _dumptostr($obj);
+
+ $obj = Data::Dumper->new([$a, $b]);
+ $obj->Useperl(undef);
+ $dumps{'useperlundef'} = _dumptostr($obj);
+
+ is($dumps{'dduzero'}, $dumps{'dduundef'},
+ "\$Data::Dumper::Useperl(0) and (undef) are equivalent");
+ is($dumps{'useperlzero'}, $dumps{'useperlundef'},
+ "Useperl(0) and (undef) are equivalent");
+ is($dumps{'dduundef'}, $dumps{'useperlundef'},
+ "\$Data::Dumper::Useperl(undef) and Useperl(undef) are equivalent");
+}
+
+{
+ $obj = Data::Dumper->new([ {IO => *{$::{STDERR}}{IO}} ]);
+ $obj->Useperl(1);
+ eval { $dumpstr = _dumptostr($obj); };
+ $realtype = 'IO';
+ like($@, qr/Can't handle '$realtype' type/,
+ "Got expected error: pure-perl: Data-Dumper does not handle $realtype");
+}
+
}
use strict;
-use Test::More qw(no_plan);
+use Test::More tests => 15;
use Data::Dumper;
-$Data::Dumper::Freezer = 'freeze';
-
-# test for seg-fault bug when freeze() returns a non-ref
-my $foo = Test1->new("foo");
-my $dumped_foo = Dumper($foo);
-ok($dumped_foo,
- "Use of freezer sub which returns non-ref worked.");
-like($dumped_foo, qr/frozed/,
- "Dumped string has the key added by Freezer.");
-
-# test that list-context freeze return doesn't contain the freezer's return
-# value; RT #116364
-like(join(" ", Dumper($foo)), qr/\A\$VAR1 = /,
- "Dumped list doesn't begin with Freezer's return value");
-
-# run the same tests with useperl. this always worked
+use lib qw( ./t/lib );
+use Testing qw( _dumptostr );
+
{
- local $Data::Dumper::Useperl = 1;
- my $foo = Test1->new("foo");
- my $dumped_foo = Dumper($foo);
- ok($dumped_foo,
- "Use of freezer sub which returns non-ref worked with useperl");
- like($dumped_foo, qr/frozed/,
- "Dumped string has the key added by Freezer with useperl.");
- like(join(" ", Dumper($foo)), qr/\A\$VAR1 = /,
- "Dumped list doesn't begin with Freezer's return value with useperl");
+ local $Data::Dumper::Freezer = 'freeze';
+
+ # test for seg-fault bug when freeze() returns a non-ref
+ {
+ my $foo = Test1->new("foo");
+ my $dumped_foo = Dumper($foo);
+ ok($dumped_foo,
+ "Use of freezer sub which returns non-ref worked.");
+ like($dumped_foo, qr/frozed/,
+ "Dumped string has the key added by Freezer with useperl.");
+ like(join(" ", Dumper($foo)), qr/\A\$VAR1 = /,
+ "Dumped list doesn't begin with Freezer's return value with useperl");
+ }
+
+ # run the same tests with useperl. this always worked
+ {
+ local $Data::Dumper::Useperl = 1;
+ my $foo = Test1->new("foo");
+ my $dumped_foo = Dumper($foo);
+ ok($dumped_foo,
+ "Use of freezer sub which returns non-ref worked with useperl");
+ like($dumped_foo, qr/frozed/,
+ "Dumped string has the key added by Freezer with useperl.");
+ like(join(" ", Dumper($foo)), qr/\A\$VAR1 = /,
+ "Dumped list doesn't begin with Freezer's return value with useperl");
+ }
+
+ # test for warning when an object does not have a freeze()
+ {
+ my $warned = 0;
+ local $SIG{__WARN__} = sub { $warned++ };
+ my $bar = Test2->new("bar");
+ my $dumped_bar = Dumper($bar);
+ is($warned, 0, "A missing freeze() shouldn't warn.");
+ }
+
+ # run the same test with useperl, which always worked
+ {
+ local $Data::Dumper::Useperl = 1;
+ my $warned = 0;
+ local $SIG{__WARN__} = sub { $warned++ };
+ my $bar = Test2->new("bar");
+ my $dumped_bar = Dumper($bar);
+ is($warned, 0, "A missing freeze() shouldn't warn with useperl");
+ }
+
+ # a freeze() which die()s should still trigger the warning
+ {
+ my $warned = 0;
+ local $SIG{__WARN__} = sub { $warned++; };
+ my $bar = Test3->new("bar");
+ my $dumped_bar = Dumper($bar);
+ is($warned, 1, "A freeze() which die()s should warn.");
+ }
+
+ # the same should work in useperl
+ {
+ local $Data::Dumper::Useperl = 1;
+ my $warned = 0;
+ local $SIG{__WARN__} = sub { $warned++; };
+ my $bar = Test3->new("bar");
+ my $dumped_bar = Dumper($bar);
+ is($warned, 1, "A freeze() which die()s should warn with useperl.");
+ }
}
-# test for warning when an object doesn't have a freeze()
{
- my $warned = 0;
- local $SIG{__WARN__} = sub { $warned++ };
- my $bar = Test2->new("bar");
- my $dumped_bar = Dumper($bar);
- is($warned, 0, "A missing freeze() shouldn't warn.");
+ my ($obj, %dumps);
+ my $foo = Test1->new("foo");
+
+ local $Data::Dumper::Freezer = 'freeze';
+ $obj = Data::Dumper->new( [ $foo ] );
+ $dumps{'ddftrue'} = _dumptostr($obj);
+ local $Data::Dumper::Freezer = '';
+
+ $obj = Data::Dumper->new( [ $foo ] );
+ $obj->Freezer('freeze');
+ $dumps{'objset'} = _dumptostr($obj);
+
+ is($dumps{'ddftrue'}, $dumps{'objset'},
+ "\$Data::Dumper::Freezer and Freezer() are equivalent");
}
+{
+ my ($obj, %dumps);
+ my $foo = Test1->new("foo");
+
+ local $Data::Dumper::Freezer = 'freeze';
+
+ local $Data::Dumper::Useperl = 1;
+ $obj = Data::Dumper->new( [ $foo ] );
+ $dumps{'ddftrueuseperl'} = _dumptostr($obj);
+
+ local $Data::Dumper::Useperl = 0;
+ $obj = Data::Dumper->new( [ $foo ] );
+ $dumps{'ddftruexs'} = _dumptostr($obj);
+
+ is( $dumps{'ddftruexs'}, $dumps{'ddftrueuseperl'},
+ "\$Data::Dumper::Freezer() gives same results under XS and Useperl");
+}
-# run the same test with useperl, which always worked
{
+ my ($obj, %dumps);
+ my $foo = Test1->new("foo");
+
local $Data::Dumper::Useperl = 1;
- my $warned = 0;
- local $SIG{__WARN__} = sub { $warned++ };
- my $bar = Test2->new("bar");
- my $dumped_bar = Dumper($bar);
- is($warned, 0, "A missing freeze() shouldn't warn with useperl");
+ $obj = Data::Dumper->new( [ $foo ] );
+ $obj->Freezer('freeze');
+ $dumps{'objsetuseperl'} = _dumptostr($obj);
+
+ local $Data::Dumper::Useperl = 0;
+ $obj = Data::Dumper->new( [ $foo ] );
+ $obj->Freezer('freeze');
+ $dumps{'objsetxs'} = _dumptostr($obj);
+
+ is($dumps{'objsetxs'}, $dumps{'objsetuseperl'},
+ "Freezer() gives same results under XS and Useperl");
}
-# a freeze() which die()s should still trigger the warning
{
- my $warned = 0;
- local $SIG{__WARN__} = sub { $warned++; };
- my $bar = Test3->new("bar");
- my $dumped_bar = Dumper($bar);
- is($warned, 1, "A freeze() which die()s should warn.");
+ my ($obj, %dumps);
+ my $foo = Test1->new("foo");
+
+ local $Data::Dumper::Freezer = '';
+ $obj = Data::Dumper->new( [ $foo ] );
+ $dumps{'ddfemptystr'} = _dumptostr($obj);
+
+ local $Data::Dumper::Freezer = undef;
+ $obj = Data::Dumper->new( [ $foo ] );
+ $dumps{'ddfundef'} = _dumptostr($obj);
+
+ is($dumps{'ddfundef'}, $dumps{'ddfemptystr'},
+ "\$Data::Dumper::Freezer same with empty string or undef");
}
-# the same should work in useperl
{
- local $Data::Dumper::Useperl = 1;
- my $warned = 0;
- local $SIG{__WARN__} = sub { $warned++; };
- my $bar = Test3->new("bar");
- my $dumped_bar = Dumper($bar);
- is($warned, 1, "A freeze() which die()s should warn with useperl.");
+ my ($obj, %dumps);
+ my $foo = Test1->new("foo");
+
+ $obj = Data::Dumper->new( [ $foo ] );
+ $obj->Freezer('');
+ $dumps{'objemptystr'} = _dumptostr($obj);
+
+ $obj = Data::Dumper->new( [ $foo ] );
+ $obj->Freezer(undef);
+ $dumps{'objundef'} = _dumptostr($obj);
+
+ is($dumps{'objundef'}, $dumps{'objemptystr'},
+ "Freezer() same with empty string or undef");
}
+
# a package with a freeze() which returns a non-ref
package Test1;
sub new { bless({name => $_[1]}, $_[0]) }
--- /dev/null
+#!./perl -w
+# t/indent.t - Test Indent()
+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 tests => 10;
+use lib qw( ./t/lib );
+use Testing qw( _dumptostr );
+
+
+my $hash = { foo => 42 };
+
+my (%dumpstr);
+my $dumper;
+
+$dumper = Data::Dumper->new([$hash]);
+$dumpstr{noindent} = _dumptostr($dumper);
+# $VAR1 = {
+# 'foo' => 42
+# };
+
+$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);
+# $VAR1 = {'foo' => 42}; # no newline
+
+$dumper = Data::Dumper->new([$hash]);
+$dumper->Indent(1);
+$dumpstr{indent_1} = _dumptostr($dumper);
+# $VAR1 = {
+# 'foo' => 42
+# };
+
+$dumper = Data::Dumper->new([$hash]);
+$dumper->Indent(2);
+$dumpstr{indent_2} = _dumptostr($dumper);
+# $VAR1 = {
+# 'foo' => 42
+# };
+
+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},
+ "Indent(0) is different from Indent(1)");
+cmp_ok(length($dumpstr{indent_0}), '<=', length($dumpstr{indent_1}),
+ "Indent(0) is more compact than Indent(1)");
+is($dumpstr{noindent}, $dumpstr{indent_2},
+ "absence of Indent is same as Indent(2), i.e., 2 is default");
+cmp_ok(length($dumpstr{indent_1}), '<=', length($dumpstr{indent_2}),
+ "Indent(1) is more compact than Indent(2)");
+
+my $array = [ qw| foo 42 | ];
+$dumper = Data::Dumper->new([$array]);
+$dumper->Indent(2);
+$dumpstr{ar_indent_2} = _dumptostr($dumper);
+# $VAR1 = [
+# 'foo',
+# '42'
+# ];
+
+$dumper = Data::Dumper->new([$array]);
+$dumper->Indent(3);
+$dumpstr{ar_indent_3} = _dumptostr($dumper);
+# $VAR1 = [
+# #0
+# 'foo',
+# #1
+# '42'
+# ];
+
+isnt($dumpstr{ar_indent_2}, $dumpstr{ar_indent_3},
+ "On arrays, Indent(2) is different from Indent(3)");
+like($dumpstr{ar_indent_3},
+ qr/\#0.+'foo'.+\#1.+'42'/s,
+ "Indent(3) annotates array elements with their indices"
+);
+is(scalar(split("\n" => $dumpstr{ar_indent_2})) + 2,
+ scalar(split("\n" => $dumpstr{ar_indent_3})),
+ "Indent(3) runs 2 lines longer than Indent(2)");
+
+__END__
+is($dumpstr{noindent}, $dumpstr{indent_0},
+ "absence of Indent is same as Indent(0)");
+isnt($dumpstr{noindent}, $dumpstr{indent_1},
+ "absence of Indent is different from Indent(1)");
+print STDERR $dumpstr{indent_0};
+print STDERR $dumpstr{ar_indent_3};
--- /dev/null
+package Testing;
+use 5.006_001;
+use strict;
+use warnings;
+require Exporter;
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw(_dumptostr);
+use Carp;
+
+sub _dumptostr {
+ my ($obj) = @_;
+ return join '', $obj->Dump;
+}
+
+1;
--- /dev/null
+#!./perl -w
+# t/misc.t - Test various functionality
+
+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 tests => 20;
+use lib qw( ./t/lib );
+use Testing qw( _dumptostr );
+
+my ($a, $b, @c, %d);
+$a = 'alpha';
+$b = 'beta';
+@c = ( qw| gamma delta epsilon | );
+%d = ( zeta => 'eta', theta => 'iota' );
+
+note("Argument validation for new()");
+{
+ local $@ = '';
+ eval { my $obj = Data::Dumper->new(undef); };
+ like($@,
+ qr/^Usage:\s+PACKAGE->new\(ARRAYREF,\s*\[ARRAYREF\]\)/,
+ "Got error message: new() needs defined argument"
+ );
+}
+
+{
+ local $@ = '';
+ eval { my $obj = Data::Dumper->new( { $a => $b } ); };
+ like($@,
+ qr/^Usage:\s+PACKAGE->new\(ARRAYREF,\s*\[ARRAYREF\]\)/,
+ "Got error message: new() needs array reference"
+ );
+}
+
+{
+ note("\$Data::Dumper::Useperl, Useqq, Deparse");
+ my ($obj, %dumpstr);
+
+ local $Data::Dumper::Useperl = 1;
+ $obj = Data::Dumper->new( [ \@c, \%d ] );
+ $dumpstr{useperl} = [ $obj->Values ];
+ local $Data::Dumper::Useperl = 0;
+
+ local $Data::Dumper::Useqq = 1;
+ $obj = Data::Dumper->new( [ \@c, \%d ] );
+ $dumpstr{useqq} = [ $obj->Values ];
+ local $Data::Dumper::Useqq = 0;
+
+ is_deeply($dumpstr{useperl}, $dumpstr{useqq},
+ "Useperl and Useqq return same");
+
+ local $Data::Dumper::Deparse = 1;
+ $obj = Data::Dumper->new( [ \@c, \%d ] );
+ $dumpstr{deparse} = [ $obj->Values ];
+ local $Data::Dumper::Deparse = 0;
+
+ is_deeply($dumpstr{useperl}, $dumpstr{deparse},
+ "Useperl and Deparse return same");
+}
+
+{
+ note("\$Data::Dumper::Pad and \$obj->Pad");
+ my ($obj, %dumps, $pad);
+ $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");
+
+ $pad = 'XXX: ';
+ local $Data::Dumper::Pad = $pad;
+ $obj = Data::Dumper->new([$a,$b]);
+ $dumps{'ddp'} = _dumptostr($obj);
+ local $Data::Dumper::Pad = '';
+
+ $obj = Data::Dumper->new([$a,$b]);
+ $obj->Pad($pad);
+ $dumps{'obj'} = _dumptostr($obj);
+
+ is($dumps{'ddp'}, $dumps{'obj'},
+ "\$Data::Dumper::Pad and \$obj->Pad() give same result");
+
+ is( (grep {! /^$pad/} (split(/\n/, $dumps{'ddp'}))), 0,
+ "Each line of dumped output padded as expected");
+}
+
+{
+ note("\$Data::Dumper::Varname and \$obj->Varname");
+ my ($obj, %dumps, $varname);
+ $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'},
+ "No setting for \$Data::Dumper::Varname and Varname('') give different results");
+
+ $varname = 'MIMI';
+ local $Data::Dumper::Varname = $varname;
+ $obj = Data::Dumper->new([$a,$b]);
+ $dumps{'ddv'} = _dumptostr($obj);
+ local $Data::Dumper::Varname = undef;
+
+ $obj = Data::Dumper->new([$a,$b]);
+ $obj->Varname($varname);
+ $dumps{'varname'} = _dumptostr($obj);
+
+ is($dumps{'ddv'}, $dumps{'varname'},
+ "Setting for \$Data::Dumper::Varname and Varname() give same result");
+
+ is( (grep { /^\$$varname/ } (split(/\n/, $dumps{'ddv'}))), 2,
+ "All lines of dumped output use provided varname");
+
+ is( (grep { /^\$VAR/ } (split(/\n/, $dumps{'ddv'}))), 0,
+ "No lines of dumped output use default \$VAR");
+}
+
+{
+ note("\$Data::Dumper::Useqq and \$obj->Useqq");
+ my ($obj, %dumps, $useqq);
+ $obj = Data::Dumper->new([$a,$b]);
+ $dumps{'noprev'} = _dumptostr($obj);
+
+ $obj = Data::Dumper->new([$a,$b]);
+ $obj->Useqq(undef);
+ $dumps{'undef'} = _dumptostr($obj);
+
+ $obj = Data::Dumper->new([$a,$b]);
+ $obj->Useqq('');
+ $dumps{'emptystring'} = _dumptostr($obj);
+
+ $obj = Data::Dumper->new([$a,$b]);
+ $obj->Useqq(0);
+ $dumps{'zero'} = _dumptostr($obj);
+
+ my $current = $Data::Dumper::Useqq;
+ local $Data::Dumper::Useqq = 0;
+ $obj = Data::Dumper->new([$a,$b]);
+ $dumps{'dduzero'} = _dumptostr($obj);
+ local $Data::Dumper::Useqq = $current;
+
+ is($dumps{'noprev'}, $dumps{'undef'},
+ "No setting for \$Data::Dumper::Useqq and Useqq(undef) give same result");
+
+ is($dumps{'noprev'}, $dumps{'zero'},
+ "No setting for \$Data::Dumper::Useqq and Useqq(0) give same result");
+
+ is($dumps{'noprev'}, $dumps{'emptystring'},
+ "No setting for \$Data::Dumper::Useqq and Useqq('') give same result");
+
+ is($dumps{'noprev'}, $dumps{'dduzero'},
+ "No setting for \$Data::Dumper::Useqq and Useqq(undef) give same result");
+
+ local $Data::Dumper::Useqq = 1;
+ $obj = Data::Dumper->new([$a,$b]);
+ $dumps{'ddu'} = _dumptostr($obj);
+ local $Data::Dumper::Useqq = $current;
+
+ $obj = Data::Dumper->new([$a,$b]);
+ $obj->Useqq(1);
+ $dumps{'obj'} = _dumptostr($obj);
+
+ is($dumps{'ddu'}, $dumps{'obj'},
+ "\$Data::Dumper::Useqq=1 and Useqq(1) give same result");
+
+ like($dumps{'ddu'},
+ qr/"$a".+?"$b"/s,
+ "Double-quotes used around values"
+ );
+
+ unlike($dumps{'ddu'},
+ qr/'$a'.+?'$b'/s,
+ "Single-quotes not used around values"
+ );
+}
--- /dev/null
+#!./perl -w
+
+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 Carp;
+use Data::Dumper;
+use Test::More tests => 15;
+use lib qw( ./t/lib );
+use Testing qw( _dumptostr );
+
+my ($a, $b, $obj);
+my (@names);
+my (@newnames, $objagain, %newnames);
+my $dumpstr;
+$a = 'alpha';
+$b = 'beta';
+
+$obj = Data::Dumper->new([$a,$b], [qw(a b)]);
+@names = $obj->Names;
+is_deeply(\@names, [qw(a b)], "Names() returned expected list");
+
+@newnames = ( qw| gamma delta | );
+$objagain = $obj->Names(\@newnames);
+is($objagain, $obj, "Names returned same object");
+is_deeply($objagain->{names}, \@newnames,
+ "Able to use Names() to set names to be dumped");
+
+$obj = Data::Dumper->new([$a,$b], [qw(a b)]);
+%newnames = ( gamma => 'delta', epsilon => 'zeta' );
+eval { @names = $obj->Names(\%newnames); };
+like($@, qr/Argument to Names, if provided, must be array ref/,
+ "Got expected error message: bad argument to Names()");
+
+$obj = Data::Dumper->new([$a,$b], [qw(a b)]);
+@newnames = ( qw| gamma delta epsilon | );
+$objagain = $obj->Names(\@newnames);
+is($objagain, $obj, "Names returned same object");
+is_deeply($objagain->{names}, \@newnames,
+ "Able to use Names() to set names to be dumped");
+$dumpstr = _dumptostr($obj);
+like($dumpstr, qr/gamma/s, "Got first name expected");
+like($dumpstr, qr/delta/s, "Got first name expected");
+unlike($dumpstr, qr/epsilon/s, "Did not get name which was not expected");
+
+$obj = Data::Dumper->new([$a,$b], [qw(a b)]);
+@newnames = ( qw| gamma | );
+$objagain = $obj->Names(\@newnames);
+is($objagain, $obj, "Names returned same object");
+is_deeply($objagain->{names}, \@newnames,
+ "Able to use Names() to set names to be dumped");
+$dumpstr = _dumptostr($obj);
+like($dumpstr, qr/gamma/s, "Got name expected");
+unlike($dumpstr, qr/delta/s, "Did not get name which was not expected");
+unlike($dumpstr, qr/epsilon/s, "Did not get name which was not expected");
+like($dumpstr, qr/\$VAR2/s, "Got default name");
+
--- /dev/null
+#!./perl -w
+# t/purity_deepcopy_maxdepth.t - Test Purity(), Deepcopy(),
+# Maxdepth() and recursive structures
+
+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 tests => 24;
+use lib qw( ./t/lib );
+use Testing qw( _dumptostr );
+
+my ($a, $b, $c, @d);
+my ($d, $e, $f);
+
+note("\$Data::Dumper::Purity and Purity()");
+
+{
+ my ($obj, %dumps, $purity);
+
+ # Adapted from example in Dumper.pm POD:
+ @d = ('c');
+ $c = \@d;
+ $b = {};
+ $a = [1, $b, $c];
+ $b->{a} = $a;
+ $b->{b} = $a->[1];
+ $b->{c} = $a->[2];
+
+ $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]);
+ $dumps{'noprev'} = _dumptostr($obj);
+
+ note("Discrepancy between Dumpxs() and Dumpperl() behavior with respect to \$Data::Dumper::Purity = undef");
+ local $Data::Dumper::Useperl = 1;
+ $purity = undef;
+ local $Data::Dumper::Purity = $purity;
+ $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]);
+ $dumps{'ddpundef'} = _dumptostr($obj);
+
+ $purity = 0;
+ local $Data::Dumper::Purity = $purity;
+ $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]);
+ $dumps{'ddpzero'} = _dumptostr($obj);
+
+ is($dumps{'noprev'}, $dumps{'ddpundef'},
+ "No previous Purity setting equivalent to \$Data::Dumper::Purity = undef");
+
+ is($dumps{'noprev'}, $dumps{'ddpzero'},
+ "No previous Purity setting equivalent to \$Data::Dumper::Purity = 0");
+}
+
+{
+ my ($obj, %dumps, $purity);
+
+ @d = ('c');
+ $c = \@d;
+ $b = {};
+ $a = [1, $b, $c];
+ $b->{a} = $a;
+ $b->{b} = $a->[1];
+ $b->{c} = $a->[2];
+
+ $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]);
+ $dumps{'noprev'} = _dumptostr($obj);
+
+ $purity = 0;
+ $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]);
+ $obj->Purity($purity);
+ $dumps{'objzero'} = _dumptostr($obj);
+
+ 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)");
+}
+
+{
+ my ($obj, %dumps, $purity);
+
+ @d = ('c');
+ $c = \@d;
+ $b = {};
+ $a = [1, $b, $c];
+ $b->{a} = $a;
+ $b->{b} = $a->[1];
+ $b->{c} = $a->[2];
+
+ $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]);
+ $dumps{'noprev'} = _dumptostr($obj);
+
+ $purity = 1;
+ local $Data::Dumper::Purity = $purity;
+ $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]);
+ $dumps{'ddpone'} = _dumptostr($obj);
+
+ isnt($dumps{'noprev'}, $dumps{'ddpone'},
+ "No previous Purity setting different from \$Data::Dumper::Purity = 1");
+}
+
+{
+ my ($obj, %dumps, $purity);
+
+ @d = ('c');
+ $c = \@d;
+ $b = {};
+ $a = [1, $b, $c];
+ $b->{a} = $a;
+ $b->{b} = $a->[1];
+ $b->{c} = $a->[2];
+
+ $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]);
+ $dumps{'noprev'} = _dumptostr($obj);
+
+ $purity = 1;
+ $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]);
+ $obj->Purity(1);
+ $dumps{'objone'} = _dumptostr($obj);
+
+ isnt($dumps{'noprev'}, $dumps{'objone'},
+ "No previous Purity setting different from Purity(0)");
+}
+
+{
+ my ($obj, %dumps, $purity);
+
+ @d = ('c');
+ $c = \@d;
+ $b = {};
+ $a = [1, $b, $c];
+ $b->{a} = $a;
+ $b->{b} = $a->[1];
+ $b->{c} = $a->[2];
+
+ $purity = 1;
+ local $Data::Dumper::Purity = $purity;
+ $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]);
+ $dumps{'ddpone'} = _dumptostr($obj);
+ local $Data::Dumper::Purity = undef;
+
+ $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]);
+ $obj->Purity(1);
+ $dumps{'objone'} = _dumptostr($obj);
+
+ is($dumps{'ddpone'}, $dumps{'objone'},
+ "\$Data::Dumper::Purity = 1 and Purity(1) are equivalent");
+}
+
+note("\$Data::Dumper::Deepcopy and Deepcopy()");
+
+{
+ my ($obj, %dumps, $deepcopy);
+
+ # Adapted from example in Dumper.pm POD:
+ @d = ('c');
+ $c = \@d;
+ $b = {};
+ $a = [1, $b, $c];
+ $b->{a} = $a;
+ $b->{b} = $a->[1];
+ $b->{c} = $a->[2];
+
+ $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]);
+ $dumps{'noprev'} = _dumptostr($obj);
+
+ $deepcopy = undef;
+ local $Data::Dumper::Deepcopy = $deepcopy;
+ $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]);
+ $dumps{'dddundef'} = _dumptostr($obj);
+
+ $deepcopy = 0;
+ local $Data::Dumper::Deepcopy = $deepcopy;
+ $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]);
+ $dumps{'dddzero'} = _dumptostr($obj);
+
+ is($dumps{'noprev'}, $dumps{'dddundef'},
+ "No previous Deepcopy setting equivalent to \$Data::Dumper::Deepcopy = undef");
+
+ is($dumps{'noprev'}, $dumps{'dddzero'},
+ "No previous Deepcopy setting equivalent to \$Data::Dumper::Deepcopy = 0");
+}
+
+{
+ my ($obj, %dumps, $deepcopy);
+
+ @d = ('c');
+ $c = \@d;
+ $b = {};
+ $a = [1, $b, $c];
+ $b->{a} = $a;
+ $b->{b} = $a->[1];
+ $b->{c} = $a->[2];
+
+ $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]);
+ $dumps{'noprev'} = _dumptostr($obj);
+
+ $deepcopy = 0;
+ $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]);
+ $obj->Deepcopy($deepcopy);
+ $dumps{'objzero'} = _dumptostr($obj);
+
+ is($dumps{'noprev'}, $dumps{'objzero'},
+ "No previous Deepcopy setting equivalent to Deepcopy(0)");
+
+ $deepcopy = undef;
+ $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]);
+ $obj->Deepcopy($deepcopy);
+ $dumps{'objundef'} = _dumptostr($obj);
+
+ is($dumps{'noprev'}, $dumps{'objundef'},
+ "No previous Deepcopy setting equivalent to Deepcopy(undef)");
+}
+
+{
+ my ($obj, %dumps, $deepcopy);
+
+ @d = ('c');
+ $c = \@d;
+ $b = {};
+ $a = [1, $b, $c];
+ $b->{a} = $a;
+ $b->{b} = $a->[1];
+ $b->{c} = $a->[2];
+
+ $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]);
+ $dumps{'noprev'} = _dumptostr($obj);
+
+ $deepcopy = 1;
+ local $Data::Dumper::Deepcopy = $deepcopy;
+ $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]);
+ $dumps{'dddone'} = _dumptostr($obj);
+
+ isnt($dumps{'noprev'}, $dumps{'dddone'},
+ "No previous Deepcopy setting different from \$Data::Dumper::Deepcopy = 1");
+}
+
+{
+ my ($obj, %dumps, $deepcopy);
+
+ @d = ('c');
+ $c = \@d;
+ $b = {};
+ $a = [1, $b, $c];
+ $b->{a} = $a;
+ $b->{b} = $a->[1];
+ $b->{c} = $a->[2];
+
+ $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]);
+ $dumps{'noprev'} = _dumptostr($obj);
+
+ $deepcopy = 1;
+ $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]);
+ $obj->Deepcopy(1);
+ $dumps{'objone'} = _dumptostr($obj);
+
+ isnt($dumps{'noprev'}, $dumps{'objone'},
+ "No previous Deepcopy setting different from Deepcopy(0)");
+}
+
+{
+ my ($obj, %dumps, $deepcopy);
+
+ @d = ('c');
+ $c = \@d;
+ $b = {};
+ $a = [1, $b, $c];
+ $b->{a} = $a;
+ $b->{b} = $a->[1];
+ $b->{c} = $a->[2];
+
+ $deepcopy = 1;
+ local $Data::Dumper::Deepcopy = $deepcopy;
+ $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]);
+ $dumps{'dddone'} = _dumptostr($obj);
+ local $Data::Dumper::Deepcopy = undef;
+
+ $obj = Data::Dumper->new([$a,$b,$c], [qw(a b c)]);
+ $obj->Deepcopy(1);
+ $dumps{'objone'} = _dumptostr($obj);
+
+ is($dumps{'dddone'}, $dumps{'objone'},
+ "\$Data::Dumper::Deepcopy = 1 and Deepcopy(1) are equivalent");
+}
+
+note("\$Data::Dumper::Maxdepth and Maxdepth()");
+
+{
+ # Adapted from Dumper.pm POD
+
+ my ($obj, %dumps, $maxdepth);
+
+ $a = "pearl";
+ $b = [ $a ];
+ $c = { 'b' => $b };
+ $d = [ $c ];
+ $e = { 'd' => $d };
+ $f = { 'e' => $e };
+
+ note("Discrepancy between Dumpxs() and Dumpperl() behavior with respect to \$Data::Dumper::Maxdepth = undef");
+ local $Data::Dumper::Useperl = 1;
+
+ $obj = Data::Dumper->new([$f], [qw(f)]);
+ $dumps{'noprev'} = _dumptostr($obj);
+
+ $Data::Dumper::Maxdepth = undef;
+ $obj = Data::Dumper->new([$f], [qw(f)]);
+ $dumps{'ddmundef'} = _dumptostr($obj);
+
+ $maxdepth = 3;
+ local $Data::Dumper::Maxdepth = $maxdepth;
+ $obj = Data::Dumper->new([$f], [qw(f)]);
+ $dumps{'ddm'} = _dumptostr($obj);
+
+ is($dumps{'noprev'}, $dumps{'ddmundef'},
+ "No previous Maxdepth setting equivalent to \$Data::Dumper::Maxdepth = undef");
+
+ like($dumps{'noprev'}, qr/$a/s,
+ "Without Maxdepth, got output from deepest level");
+
+ isnt($dumps{'noprev'}, $dumps{'ddm'},
+ "No previous Maxdepth setting differs from setting a shallow Maxdepth");
+
+ unlike($dumps{'ddm'}, qr/$a/s,
+ "With Maxdepth, did not get output from deepest level");
+}
+
+{
+ # Adapted from Dumper.pm POD
+
+ my ($obj, %dumps, $maxdepth);
+
+ $a = "pearl";
+ $b = [ $a ];
+ $c = { 'b' => $b };
+ $d = [ $c ];
+ $e = { 'd' => $d };
+ $f = { 'e' => $e };
+
+ note("Discrepancy between Dumpxs() and Dumpperl() behavior with respect to \$Data::Dumper::Maxdepth = undef");
+ local $Data::Dumper::Useperl = 1;
+
+ $obj = Data::Dumper->new([$f], [qw(f)]);
+ $dumps{'noprev'} = _dumptostr($obj);
+
+ $obj = Data::Dumper->new([$f], [qw(f)]);
+ $obj->Maxdepth();
+ $dumps{'maxdepthempty'} = _dumptostr($obj);
+
+ 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);
+ $dumps{'maxdepthset'} = _dumptostr($obj);
+
+ isnt($dumps{'noprev'}, $dumps{'maxdepthset'},
+ "No previous Maxdepth setting differs from Maxdepth() with shallow depth");
+
+ local $Data::Dumper::Maxdepth = 3;
+ $obj = Data::Dumper->new([$f], [qw(f)]);
+ $dumps{'ddmset'} = _dumptostr($obj);
+
+ is($dumps{'maxdepthset'}, $dumps{'ddmset'},
+ "Maxdepth set and \$Data::Dumper::Maxdepth are equivalent");
+}
+
+{
+ my ($obj, %dumps);
+
+ my $warning = '';
+ local $SIG{__WARN__} = sub { $warning = $_[0] };
+
+ local $Data::Dumper::Deparse = 0;
+ local $Data::Dumper::Purity = 1;
+ local $Data::Dumper::Useperl = 1;
+ sub hello { print "Hello world\n"; }
+ $obj = Data::Dumper->new( [ \&hello ] );
+ $dumps{'ddsksub'} = _dumptostr($obj);
+ like($warning, qr/^Encountered CODE ref, using dummy placeholder/,
+ "Got expected warning: dummy placeholder under Purity = 1");
+}
+
+{
+ my ($obj, %dumps);
+
+ my $warning = '';
+ local $SIG{__WARN__} = sub { $warning = $_[0] };
+
+ local $Data::Dumper::Deparse = 0;
+ local $Data::Dumper::Useperl = 1;
+ sub jello { print "Jello world\n"; }
+ $obj = Data::Dumper->new( [ \&hello ] );
+ $dumps{'ddsksub'} = _dumptostr($obj);
+ ok(! $warning, "Encountered CODE ref, but no Purity, hence no warning");
+}
--- /dev/null
+#!./perl -w
+# t/quotekeys.t - Test Quotekeys()
+
+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 tests => 10;
+use lib qw( ./t/lib );
+use Testing qw( _dumptostr );
+
+my %d = (
+ delta => 'd',
+ beta => 'b',
+ gamma => 'c',
+ alpha => 'a',
+);
+
+{
+ my ($obj, %dumps, $quotekeys, $starting);
+
+ note("\$Data::Dumper::Quotekeys and Quotekeys() set to true value");
+ note("XS implementation");
+ $Data::Dumper::Useperl = 0;
+
+ $obj = Data::Dumper->new( [ \%d ] );
+ $dumps{'ddqkdefault'} = _dumptostr($obj);
+
+ $starting = $Data::Dumper::Quotekeys;
+ $quotekeys = 1;
+ local $Data::Dumper::Quotekeys = $quotekeys;
+ $obj = Data::Dumper->new( [ \%d ] );
+ $dumps{'ddqkone'} = _dumptostr($obj);
+ local $Data::Dumper::Quotekeys = $starting;
+
+ $obj = Data::Dumper->new( [ \%d ] );
+ $obj->Quotekeys($quotekeys);
+ $dumps{'objqkone'} = _dumptostr($obj);
+
+ is($dumps{'ddqkdefault'}, $dumps{'ddqkone'},
+ "\$Data::Dumper::Quotekeys = 1 is default");
+ is($dumps{'ddqkone'}, $dumps{'objqkone'},
+ "\$Data::Dumper::Quotekeys = 1 and Quotekeys(1) are equivalent");
+ %dumps = ();
+
+ $quotekeys = 0;
+ local $Data::Dumper::Quotekeys = $quotekeys;
+ $obj = Data::Dumper->new( [ \%d ] );
+ $dumps{'ddqkzero'} = _dumptostr($obj);
+ local $Data::Dumper::Quotekeys = $starting;
+
+ $obj = Data::Dumper->new( [ \%d ] );
+ $obj->Quotekeys($quotekeys);
+ $dumps{'objqkzero'} = _dumptostr($obj);
+
+ is($dumps{'ddqkzero'}, $dumps{'objqkzero'},
+ "\$Data::Dumper::Quotekeys = 0 and Quotekeys(0) are equivalent");
+
+ $quotekeys = undef;
+ local $Data::Dumper::Quotekeys = $quotekeys;
+ $obj = Data::Dumper->new( [ \%d ] );
+ $dumps{'ddqkundef'} = _dumptostr($obj);
+ local $Data::Dumper::Quotekeys = $starting;
+
+ $obj = Data::Dumper->new( [ \%d ] );
+ $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'},
+ "\$Data::Dumper::Quotekeys = undef and Quotekeys(undef) are equivalent");
+ isnt($dumps{'ddqkzero'}, $dumps{'objqkundef'},
+ "\$Data::Dumper::Quotekeys = undef and = 0 are equivalent");
+ %dumps = ();
+
+ note("Perl implementation");
+ $Data::Dumper::Useperl = 1;
+
+ $obj = Data::Dumper->new( [ \%d ] );
+ $dumps{'ddqkdefault'} = _dumptostr($obj);
+
+ $starting = $Data::Dumper::Quotekeys;
+ $quotekeys = 1;
+ local $Data::Dumper::Quotekeys = $quotekeys;
+ $obj = Data::Dumper->new( [ \%d ] );
+ $dumps{'ddqkone'} = _dumptostr($obj);
+ local $Data::Dumper::Quotekeys = $starting;
+
+ $obj = Data::Dumper->new( [ \%d ] );
+ $obj->Quotekeys($quotekeys);
+ $dumps{'objqkone'} = _dumptostr($obj);
+
+ is($dumps{'ddqkundef'}, $dumps{'objqkundef'},
+ "\$Data::Dumper::Quotekeys = undef and Quotekeys(undef) are equivalent");
+ is($dumps{'ddqkone'}, $dumps{'objqkone'},
+ "\$Data::Dumper::Quotekeys = 1 and Quotekeys(1) are equivalent");
+ %dumps = ();
+
+ $quotekeys = 0;
+ local $Data::Dumper::Quotekeys = $quotekeys;
+ $obj = Data::Dumper->new( [ \%d ] );
+ $dumps{'ddqkzero'} = _dumptostr($obj);
+ local $Data::Dumper::Quotekeys = $starting;
+
+ $obj = Data::Dumper->new( [ \%d ] );
+ $obj->Quotekeys($quotekeys);
+ $dumps{'objqkzero'} = _dumptostr($obj);
+
+ is($dumps{'ddqkzero'}, $dumps{'objqkzero'},
+ "\$Data::Dumper::Quotekeys = 0 and Quotekeys(0) are equivalent");
+
+ $quotekeys = undef;
+ local $Data::Dumper::Quotekeys = $quotekeys;
+ $obj = Data::Dumper->new( [ \%d ] );
+ $dumps{'ddqkundef'} = _dumptostr($obj);
+ local $Data::Dumper::Quotekeys = $starting;
+
+ $obj = Data::Dumper->new( [ \%d ] );
+ $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'},
+ "\$Data::Dumper::Quotekeys = undef and Quotekeys(undef) are equivalent");
+ isnt($dumps{'ddqkzero'}, $dumps{'objqkundef'},
+ "\$Data::Dumper::Quotekeys = undef and = 0 are equivalent");
+ %dumps = ();
+}
+
--- /dev/null
+#!./perl -w
+# t/seen.t - Test Seen()
+
+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 tests => 10;
+use lib qw( ./t/lib );
+use Testing qw( _dumptostr );
+
+my ($obj, %dumps);
+
+my (@e, %f, @rv, @g, %h, $k);
+@e = ( qw| alpha beta gamma | );
+%f = ( epsilon => 'zeta', eta => 'theta' );
+@g = ( qw| iota kappa lambda | );
+%h = ( mu => 'nu', omicron => 'pi' );
+sub j { print "Hello world\n"; }
+$k = 'just another scalar';
+
+{
+ my $warning = '';
+ local $SIG{__WARN__} = sub { $warning = $_[0] };
+
+ $obj = Data::Dumper->new( [ \@e, \%f ]);
+ @rv = $obj->Seen( { mark => 'snark' } );
+ like($warning,
+ qr/^Only refs supported, ignoring non-ref item \$mark/,
+ "Got expected warning for non-ref item");
+}
+
+{
+ my $warning = '';
+ local $SIG{__WARN__} = sub { $warning = $_[0] };
+
+ $obj = Data::Dumper->new( [ \@e, \%f ]);
+ @rv = $obj->Seen( { mark => undef } );
+ like($warning,
+ qr/^Value of ref must be defined; ignoring undefined item \$mark/,
+ "Got expected warning for undefined value of item");
+}
+
+{
+ $obj = Data::Dumper->new( [ \@e, \%f ]);
+ @rv = $obj->Seen( undef );
+ is(@rv, 0, "Seen(undef) returned empty array");
+}
+
+{
+ $obj = Data::Dumper->new( [ \@e, \%f ]);
+ @rv = $obj->Seen( [ qw| mark snark | ] );
+ is(@rv, 0, "Seen(ref other than hashref) returned empty array");
+}
+
+{
+ $obj = Data::Dumper->new( [ \@e, \%f ]);
+ @rv = $obj->Seen( { '*samba' => \@g } );
+ is_deeply($rv[0], $obj, "Got the object back: value array ref");
+}
+
+{
+ $obj = Data::Dumper->new( [ \@e, \%f ]);
+ @rv = $obj->Seen( { '*canasta' => \%h } );
+ is_deeply($rv[0], $obj, "Got the object back: value hash ref");
+}
+
+{
+ $obj = Data::Dumper->new( [ \@e, \%f ]);
+ @rv = $obj->Seen( { '*pinochle' => \&j } );
+ is_deeply($rv[0], $obj, "Got the object back: value code ref");
+}
+
+{
+ $obj = Data::Dumper->new( [ \@e, \%f ]);
+ @rv = $obj->Seen( { '*poker' => \$k } );
+ is_deeply($rv[0], $obj, "Got the object back: value ref to scalar");
+}
+
+{
+ my $l = 'loo';
+ $obj = Data::Dumper->new( [ \@e, \%f ]);
+ @rv = $obj->Seen( { $l => \$k } );
+ is_deeply($rv[0], $obj, "Got the object back: value ref to scalar");
+}
+
+{
+ my $l = '$loo';
+ $obj = Data::Dumper->new( [ \@e, \%f ]);
+ @rv = $obj->Seen( { $l => \$k } );
+ is_deeply($rv[0], $obj, "Got the object back: value ref to scalar");
+}
+
--- /dev/null
+#!./perl -w
+# t/sortkeys.t - Test Sortkeys()
+
+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 tests => 23;
+use lib qw( ./t/lib );
+use Testing qw( _dumptostr );
+
+my %d = (
+ delta => 'd',
+ beta => 'b',
+ gamma => 'c',
+ alpha => 'a',
+);
+
+{
+ my ($obj, %dumps, $sortkeys, $starting);
+
+ note("\$Data::Dumper::Sortkeys and Sortkeys() set to true value");
+ note("XS implementation");
+ $Data::Dumper::Useperl = 0;
+
+ $starting = $Data::Dumper::Sortkeys;
+ $sortkeys = 1;
+ local $Data::Dumper::Sortkeys = $sortkeys;
+ $obj = Data::Dumper->new( [ \%d ] );
+ $dumps{'ddskone'} = _dumptostr($obj);
+ local $Data::Dumper::Sortkeys = $starting;
+
+ $obj = Data::Dumper->new( [ \%d ] );
+ $obj->Sortkeys($sortkeys);
+ $dumps{'objskone'} = _dumptostr($obj);
+
+ is($dumps{'ddskone'}, $dumps{'objskone'},
+ "\$Data::Dumper::Sortkeys = 1 and Sortkeys(1) are equivalent");
+ like($dumps{'ddskone'},
+ qr/alpha.*?beta.*?delta.*?gamma/s,
+ "Sortkeys returned hash keys in Perl's default sort order");
+ %dumps = ();
+
+ note("Perl implementation");
+ $Data::Dumper::Useperl = 1;
+
+ $starting = $Data::Dumper::Sortkeys;
+ $sortkeys = 1;
+ local $Data::Dumper::Sortkeys = $sortkeys;
+ $obj = Data::Dumper->new( [ \%d ] );
+ $dumps{'ddskone'} = _dumptostr($obj);
+ local $Data::Dumper::Sortkeys = $starting;
+
+ $obj = Data::Dumper->new( [ \%d ] );
+ $obj->Sortkeys($sortkeys);
+ $dumps{'objskone'} = _dumptostr($obj);
+
+ is($dumps{'ddskone'}, $dumps{'objskone'},
+ "\$Data::Dumper::Sortkeys = 1 and Sortkeys(1) are equivalent");
+ like($dumps{'ddskone'},
+ qr/alpha.*?beta.*?delta.*?gamma/s,
+ "Sortkeys returned hash keys in Perl's default sort order");
+}
+
+{
+ my ($obj, %dumps, $starting);
+
+ note("\$Data::Dumper::Sortkeys and Sortkeys() set to coderef");
+ sub reversekeys { return [ reverse sort keys %{+shift} ]; }
+
+ note("XS implementation");
+ $Data::Dumper::Useperl = 0;
+
+ $starting = $Data::Dumper::Sortkeys;
+ local $Data::Dumper::Sortkeys = \&reversekeys;
+ $obj = Data::Dumper->new( [ \%d ] );
+ $dumps{'ddsksub'} = _dumptostr($obj);
+ local $Data::Dumper::Sortkeys = $starting;
+
+ $obj = Data::Dumper->new( [ \%d ] );
+ $obj->Sortkeys(\&reversekeys);
+ $dumps{'objsksub'} = _dumptostr($obj);
+
+ is($dumps{'ddsksub'}, $dumps{'objsksub'},
+ "\$Data::Dumper::Sortkeys = CODEREF and Sortkeys(CODEREF) are equivalent");
+ like($dumps{'ddsksub'},
+ qr/gamma.*?delta.*?beta.*?alpha/s,
+ "Sortkeys returned hash keys per sorting subroutine");
+ %dumps = ();
+
+ note("Perl implementation");
+ $Data::Dumper::Useperl = 1;
+
+ $starting = $Data::Dumper::Sortkeys;
+ local $Data::Dumper::Sortkeys = \&reversekeys;
+ $obj = Data::Dumper->new( [ \%d ] );
+ $dumps{'ddsksub'} = _dumptostr($obj);
+ local $Data::Dumper::Sortkeys = $starting;
+
+ $obj = Data::Dumper->new( [ \%d ] );
+ $obj->Sortkeys(\&reversekeys);
+ $dumps{'objsksub'} = _dumptostr($obj);
+
+ is($dumps{'ddsksub'}, $dumps{'objsksub'},
+ "\$Data::Dumper::Sortkeys = CODEREF and Sortkeys(CODEREF) are equivalent");
+ like($dumps{'ddsksub'},
+ qr/gamma.*?delta.*?beta.*?alpha/s,
+ "Sortkeys returned hash keys per sorting subroutine");
+}
+
+{
+ my ($obj, %dumps, $starting);
+
+ note("\$Data::Dumper::Sortkeys and Sortkeys() set to coderef with filter");
+ sub reversekeystrim {
+ my $hr = shift;
+ my @keys = sort keys %{$hr};
+ shift(@keys);
+ return [ reverse @keys ];
+ }
+
+ note("XS implementation");
+ $Data::Dumper::Useperl = 0;
+
+ $starting = $Data::Dumper::Sortkeys;
+ local $Data::Dumper::Sortkeys = \&reversekeystrim;
+ $obj = Data::Dumper->new( [ \%d ] );
+ $dumps{'ddsksub'} = _dumptostr($obj);
+ local $Data::Dumper::Sortkeys = $starting;
+
+ $obj = Data::Dumper->new( [ \%d ] );
+ $obj->Sortkeys(\&reversekeystrim);
+ $dumps{'objsksub'} = _dumptostr($obj);
+
+ is($dumps{'ddsksub'}, $dumps{'objsksub'},
+ "\$Data::Dumper::Sortkeys = CODEREF and Sortkeys(CODEREF) select same keys");
+ like($dumps{'ddsksub'},
+ qr/gamma.*?delta.*?beta/s,
+ "Sortkeys returned hash keys per sorting subroutine");
+ unlike($dumps{'ddsksub'},
+ qr/alpha/s,
+ "Sortkeys filtered out one key per request");
+ %dumps = ();
+
+ note("Perl implementation");
+ $Data::Dumper::Useperl = 1;
+
+ $starting = $Data::Dumper::Sortkeys;
+ local $Data::Dumper::Sortkeys = \&reversekeystrim;
+ $obj = Data::Dumper->new( [ \%d ] );
+ $dumps{'ddsksub'} = _dumptostr($obj);
+ local $Data::Dumper::Sortkeys = $starting;
+
+ $obj = Data::Dumper->new( [ \%d ] );
+ $obj->Sortkeys(\&reversekeystrim);
+ $dumps{'objsksub'} = _dumptostr($obj);
+
+ is($dumps{'ddsksub'}, $dumps{'objsksub'},
+ "\$Data::Dumper::Sortkeys = CODEREF and Sortkeys(CODEREF) select same keys");
+ like($dumps{'ddsksub'},
+ qr/gamma.*?delta.*?beta/s,
+ "Sortkeys returned hash keys per sorting subroutine");
+ unlike($dumps{'ddsksub'},
+ qr/alpha/s,
+ "Sortkeys filtered out one key per request");
+}
+
+{
+ my ($obj, %dumps, $sortkeys, $starting);
+
+ note("\$Data::Dumper::Sortkeys(undef) and Sortkeys(undef)");
+ note("XS implementation");
+ $Data::Dumper::Useperl = 0;
+
+ $starting = $Data::Dumper::Sortkeys;
+ $sortkeys = 0;
+ local $Data::Dumper::Sortkeys = $sortkeys;
+ $obj = Data::Dumper->new( [ \%d ] );
+ $dumps{'ddskzero'} = _dumptostr($obj);
+ local $Data::Dumper::Sortkeys = $starting;
+
+ $obj = Data::Dumper->new( [ \%d ] );
+ $obj->Sortkeys($sortkeys);
+ $dumps{'objskzero'} = _dumptostr($obj);
+
+ $sortkeys = undef;
+ local $Data::Dumper::Sortkeys = $sortkeys;
+ $obj = Data::Dumper->new( [ \%d ] );
+ $dumps{'ddskundef'} = _dumptostr($obj);
+ local $Data::Dumper::Sortkeys = $starting;
+
+ $obj = Data::Dumper->new( [ \%d ] );
+ $obj->Sortkeys($sortkeys);
+ $dumps{'objskundef'} = _dumptostr($obj);
+
+ is($dumps{'ddskzero'}, $dumps{'objskzero'},
+ "\$Data::Dumper::Sortkeys = 0 and Sortkeys(0) are equivalent");
+ is($dumps{'ddskzero'}, $dumps{'ddskundef'},
+ "\$Data::Dumper::Sortkeys = 0 and = undef equivalent");
+ is($dumps{'objkzero'}, $dumps{'objkundef'},
+ "Sortkeys(0) and Sortkeys(undef) are equivalent");
+ %dumps = ();
+
+ note("Perl implementation");
+ $Data::Dumper::Useperl = 1;
+
+ $starting = $Data::Dumper::Sortkeys;
+ $sortkeys = 0;
+ local $Data::Dumper::Sortkeys = $sortkeys;
+ $obj = Data::Dumper->new( [ \%d ] );
+ $dumps{'ddskzero'} = _dumptostr($obj);
+ local $Data::Dumper::Sortkeys = $starting;
+
+ $obj = Data::Dumper->new( [ \%d ] );
+ $obj->Sortkeys($sortkeys);
+ $dumps{'objskzero'} = _dumptostr($obj);
+
+ $sortkeys = undef;
+ local $Data::Dumper::Sortkeys = $sortkeys;
+ $obj = Data::Dumper->new( [ \%d ] );
+ $dumps{'ddskundef'} = _dumptostr($obj);
+ local $Data::Dumper::Sortkeys = $starting;
+
+ $obj = Data::Dumper->new( [ \%d ] );
+ $obj->Sortkeys($sortkeys);
+ $dumps{'objskundef'} = _dumptostr($obj);
+
+ is($dumps{'ddskzero'}, $dumps{'objskzero'},
+ "\$Data::Dumper::Sortkeys = 0 and Sortkeys(0) are equivalent");
+ is($dumps{'ddskzero'}, $dumps{'ddskundef'},
+ "\$Data::Dumper::Sortkeys = 0 and = undef equivalent");
+ is($dumps{'objkzero'}, $dumps{'objkundef'},
+ "Sortkeys(0) and Sortkeys(undef) are equivalent");
+}
+
+note("Internal subroutine _sortkeys");
+my %e = (
+ nu => 'n',
+ lambda => 'l',
+ kappa => 'k',
+ mu => 'm',
+ omicron => 'o',
+);
+my $rv = Data::Dumper::_sortkeys(\%e);
+is(ref($rv), 'ARRAY', "Data::Dumper::_sortkeys returned an array ref");
+is_deeply($rv, [ qw( kappa lambda mu nu omicron ) ],
+ "Got keys in Perl default order");
+
+{
+ my $warning = '';
+ local $SIG{__WARN__} = sub { $warning = $_[0] };
+
+ my ($obj, %dumps, $starting);
+
+ note("\$Data::Dumper::Sortkeys and Sortkeys() set to coderef");
+ sub badreturnvalue { return { %{+shift} }; }
+
+ note("Perl implementation");
+ $Data::Dumper::Useperl = 1;
+
+ $starting = $Data::Dumper::Sortkeys;
+ local $Data::Dumper::Sortkeys = \&badreturnvalue;
+ $obj = Data::Dumper->new( [ \%d ] );
+ $dumps{'ddsksub'} = _dumptostr($obj);
+ like($warning, qr/^Sortkeys subroutine did not return ARRAYREF/,
+ "Got expected warning: sorting routine did not return array ref");
+}
--- /dev/null
+#!./perl -w
+# t/sparseseen.t - Test Sparseseen()
+
+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 tests => 8;
+use lib qw( ./t/lib );
+use Testing qw( _dumptostr );
+
+my %d = (
+ delta => 'd',
+ beta => 'b',
+ gamma => 'c',
+ alpha => 'a',
+);
+
+{
+ my ($obj, %dumps, $sparseseen, $starting);
+
+ note("\$Data::Dumper::Sparseseen and Sparseseen() set to true value");
+ note("XS implementation");
+ $Data::Dumper::Useperl = 0;
+
+ $starting = $Data::Dumper::Sparseseen;
+ $sparseseen = 1;
+ local $Data::Dumper::Sparseseen = $sparseseen;
+ $obj = Data::Dumper->new( [ \%d ] );
+ $dumps{'ddssone'} = _dumptostr($obj);
+ local $Data::Dumper::Sparseseen = $starting;
+
+ $obj = Data::Dumper->new( [ \%d ] );
+ $obj->Sparseseen($sparseseen);
+ $dumps{'objssone'} = _dumptostr($obj);
+
+ is($dumps{'ddssone'}, $dumps{'objssone'},
+ "\$Data::Dumper::Sparseseen = 1 and Sparseseen(1) are equivalent");
+ %dumps = ();
+
+ $sparseseen = 0;
+ local $Data::Dumper::Sparseseen = $sparseseen;
+ $obj = Data::Dumper->new( [ \%d ] );
+ $dumps{'ddsszero'} = _dumptostr($obj);
+ local $Data::Dumper::Sparseseen = $starting;
+
+ $obj = Data::Dumper->new( [ \%d ] );
+ $obj->Sparseseen($sparseseen);
+ $dumps{'objsszero'} = _dumptostr($obj);
+
+ is($dumps{'ddsszero'}, $dumps{'objsszero'},
+ "\$Data::Dumper::Sparseseen = 0 and Sparseseen(0) are equivalent");
+
+ $sparseseen = undef;
+ local $Data::Dumper::Sparseseen = $sparseseen;
+ $obj = Data::Dumper->new( [ \%d ] );
+ $dumps{'ddssundef'} = _dumptostr($obj);
+ local $Data::Dumper::Sparseseen = $starting;
+
+ $obj = Data::Dumper->new( [ \%d ] );
+ $obj->Sparseseen($sparseseen);
+ $dumps{'objssundef'} = _dumptostr($obj);
+
+ is($dumps{'ddssundef'}, $dumps{'objssundef'},
+ "\$Data::Dumper::Sparseseen = undef and Sparseseen(undef) are equivalent");
+ is($dumps{'ddsszero'}, $dumps{'objssundef'},
+ "\$Data::Dumper::Sparseseen = undef and = 0 are equivalent");
+ %dumps = ();
+
+ note("Perl implementation");
+ $Data::Dumper::Useperl = 1;
+
+ $starting = $Data::Dumper::Sparseseen;
+ $sparseseen = 1;
+ local $Data::Dumper::Sparseseen = $sparseseen;
+ $obj = Data::Dumper->new( [ \%d ] );
+ $dumps{'ddssone'} = _dumptostr($obj);
+ local $Data::Dumper::Sparseseen = $starting;
+
+ $obj = Data::Dumper->new( [ \%d ] );
+ $obj->Sparseseen($sparseseen);
+ $dumps{'objssone'} = _dumptostr($obj);
+
+ is($dumps{'ddssone'}, $dumps{'objssone'},
+ "\$Data::Dumper::Sparseseen = 1 and Sparseseen(1) are equivalent");
+ %dumps = ();
+
+ $sparseseen = 0;
+ local $Data::Dumper::Sparseseen = $sparseseen;
+ $obj = Data::Dumper->new( [ \%d ] );
+ $dumps{'ddsszero'} = _dumptostr($obj);
+ local $Data::Dumper::Sparseseen = $starting;
+
+ $obj = Data::Dumper->new( [ \%d ] );
+ $obj->Sparseseen($sparseseen);
+ $dumps{'objsszero'} = _dumptostr($obj);
+
+ is($dumps{'ddsszero'}, $dumps{'objsszero'},
+ "\$Data::Dumper::Sparseseen = 0 and Sparseseen(0) are equivalent");
+
+ $sparseseen = undef;
+ local $Data::Dumper::Sparseseen = $sparseseen;
+ $obj = Data::Dumper->new( [ \%d ] );
+ $dumps{'ddssundef'} = _dumptostr($obj);
+ local $Data::Dumper::Sparseseen = $starting;
+
+ $obj = Data::Dumper->new( [ \%d ] );
+ $obj->Sparseseen($sparseseen);
+ $dumps{'objssundef'} = _dumptostr($obj);
+
+ is($dumps{'ddssundef'}, $dumps{'objssundef'},
+ "\$Data::Dumper::Sparseseen = undef and Sparseseen(undef) are equivalent");
+ is($dumps{'ddsszero'}, $dumps{'objssundef'},
+ "\$Data::Dumper::Sparseseen = undef and = 0 are equivalent");
+ %dumps = ();
+
+}
+
use strict;
use warnings;
-use Test::More tests => 2;
-
use Data::Dumper;
+use Test::More tests => 6;
+use lib qw( ./t/lib );
+use Testing qw( _dumptostr );
+
my $hash = { foo => 42 };
}
WANT
}
+
+my (%dumpstr);
+my $dumper;
+
+$dumper = Data::Dumper->new([$hash]);
+$dumpstr{noterse} = _dumptostr($dumper);
+# $VAR1 = {
+# 'foo' => 42
+# };
+
+$dumper = Data::Dumper->new([$hash]);
+$dumper->Terse();
+$dumpstr{terse_no_arg} = _dumptostr($dumper);
+
+$dumper = Data::Dumper->new([$hash]);
+$dumper->Terse(0);
+$dumpstr{terse_0} = _dumptostr($dumper);
+
+$dumper = Data::Dumper->new([$hash]);
+$dumper->Terse(1);
+$dumpstr{terse_1} = _dumptostr($dumper);
+# {
+# 'foo' => 42
+# }
+
+$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)");
--- /dev/null
+#!./perl -w
+# t/toaster.t - Test Toaster()
+
+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 tests => 8;
+use lib qw( ./t/lib );
+use Testing qw( _dumptostr );
+
+my %d = (
+ delta => 'd',
+ beta => 'b',
+ gamma => 'c',
+ alpha => 'a',
+);
+
+{
+ my ($obj, %dumps, $toaster, $starting);
+
+ note("\$Data::Dumper::Toaster and Toaster() set to true value");
+ note("XS implementation");
+ $Data::Dumper::Useperl = 0;
+
+ $starting = $Data::Dumper::Toaster;
+ $toaster = 1;
+ local $Data::Dumper::Toaster = $toaster;
+ $obj = Data::Dumper->new( [ \%d ] );
+ $dumps{'ddtoasterone'} = _dumptostr($obj);
+ local $Data::Dumper::Toaster = $starting;
+
+ $obj = Data::Dumper->new( [ \%d ] );
+ $obj->Toaster($toaster);
+ $dumps{'objtoasterone'} = _dumptostr($obj);
+
+ is($dumps{'ddtoasterone'}, $dumps{'objtoasterone'},
+ "\$Data::Dumper::Toaster = 1 and Toaster(1) are equivalent");
+ %dumps = ();
+
+ $toaster = 0;
+ local $Data::Dumper::Toaster = $toaster;
+ $obj = Data::Dumper->new( [ \%d ] );
+ $dumps{'ddtoasterzero'} = _dumptostr($obj);
+ local $Data::Dumper::Toaster = $starting;
+
+ $obj = Data::Dumper->new( [ \%d ] );
+ $obj->Toaster($toaster);
+ $dumps{'objtoasterzero'} = _dumptostr($obj);
+
+ is($dumps{'ddtoasterzero'}, $dumps{'objtoasterzero'},
+ "\$Data::Dumper::Toaster = 0 and Toaster(0) are equivalent");
+
+ $toaster = undef;
+ local $Data::Dumper::Toaster = $toaster;
+ $obj = Data::Dumper->new( [ \%d ] );
+ $dumps{'ddtoasterundef'} = _dumptostr($obj);
+ local $Data::Dumper::Toaster = $starting;
+
+ $obj = Data::Dumper->new( [ \%d ] );
+ $obj->Toaster($toaster);
+ $dumps{'objtoasterundef'} = _dumptostr($obj);
+
+ is($dumps{'ddtoasterundef'}, $dumps{'objtoasterundef'},
+ "\$Data::Dumper::Toaster = undef and Toaster(undef) are equivalent");
+ is($dumps{'ddtoasterzero'}, $dumps{'objtoasterundef'},
+ "\$Data::Dumper::Toaster = undef and = 0 are equivalent");
+ %dumps = ();
+
+ note("Perl implementation");
+ $Data::Dumper::Useperl = 1;
+
+ $starting = $Data::Dumper::Toaster;
+ $toaster = 1;
+ local $Data::Dumper::Toaster = $toaster;
+ $obj = Data::Dumper->new( [ \%d ] );
+ $dumps{'ddtoasterone'} = _dumptostr($obj);
+ local $Data::Dumper::Toaster = $starting;
+
+ $obj = Data::Dumper->new( [ \%d ] );
+ $obj->Toaster($toaster);
+ $dumps{'objtoasterone'} = _dumptostr($obj);
+
+ is($dumps{'ddtoasterone'}, $dumps{'objtoasterone'},
+ "\$Data::Dumper::Toaster = 1 and Toaster(1) are equivalent");
+ %dumps = ();
+
+ $toaster = 0;
+ local $Data::Dumper::Toaster = $toaster;
+ $obj = Data::Dumper->new( [ \%d ] );
+ $dumps{'ddtoasterzero'} = _dumptostr($obj);
+ local $Data::Dumper::Toaster = $starting;
+
+ $obj = Data::Dumper->new( [ \%d ] );
+ $obj->Toaster($toaster);
+ $dumps{'objtoasterzero'} = _dumptostr($obj);
+
+ is($dumps{'ddtoasterzero'}, $dumps{'objtoasterzero'},
+ "\$Data::Dumper::Toaster = 0 and Toaster(0) are equivalent");
+
+ $toaster = undef;
+ local $Data::Dumper::Toaster = $toaster;
+ $obj = Data::Dumper->new( [ \%d ] );
+ $dumps{'ddtoasterundef'} = _dumptostr($obj);
+ local $Data::Dumper::Toaster = $starting;
+
+ $obj = Data::Dumper->new( [ \%d ] );
+ $obj->Toaster($toaster);
+ $dumps{'objtoasterundef'} = _dumptostr($obj);
+
+ is($dumps{'ddtoasterundef'}, $dumps{'objtoasterundef'},
+ "\$Data::Dumper::Toaster = undef and Toaster(undef) are equivalent");
+ is($dumps{'ddtoasterzero'}, $dumps{'objtoasterundef'},
+ "\$Data::Dumper::Toaster = undef and = 0 are equivalent");
+ %dumps = ();
+
+}
+
--- /dev/null
+#!./perl -w
+
+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 tests => 4;
+
+my ($a, $b, $obj);
+my (@values, @names);
+my (@newvalues, $objagain, %newvalues);
+$a = 'alpha';
+$b = 'beta';
+
+$obj = Data::Dumper->new([$a,$b], [qw(a b)]);
+@values = $obj->Values;
+is_deeply(\@values, [$a,$b], "Values() returned expected list");
+
+@newvalues = ( qw| gamma delta epsilon | );
+$objagain = $obj->Values(\@newvalues);
+is($objagain, $obj, "Values returned same object");
+is_deeply($objagain->{todump}, \@newvalues,
+ "Able to use Values() to set values to be dumped");
+
+$obj = Data::Dumper->new([$a,$b], [qw(a b)]);
+%newvalues = ( gamma => 'delta', epsilon => 'zeta' );
+eval { @values = $obj->Values(\%newvalues); };
+like($@, qr/Argument to Values, if provided, must be array ref/,
+ "Got expected error message: bad argument to Values()");
+
+
projects / perl.git / commitdiff
