Data-Dumper: Boost test coverage and refactor.
authorJames E Keenan <jkeenan@cpan.org>
Sun, 20 Jan 2013 00:20:21 +0000 (19:20 -0500)
committerJames E Keenan <jkeenan@cpan.org>
Thu, 31 Jan 2013 02:20:15 +0000 (21:20 -0500)
Thanks to coverage data posted by Paul Johnson as part of Perl
Foundation-sponsored work, we know that as of Jan 01 2013, Data::Dumper
(v2.139) had the following coverage of its code by its test suite:

                          stmt  bran  cond   sub
Dumper.xs                 94.8  64.5
blib/lib/Data/Dumper.pm   85.3  76.7  69.6  71.4

The coverage levels reported for Dumper.pm are unacceptably low,
particularly for a library which is part of the Perl 5 core
distribution.  With this commit, we significantly improve
coverage of Dumper.pm; Dumper.xs will need attention from those with XS
expertise.

Attempting to write tests for every line in a codebase frequently
uncovers places in the code that are superfluous or cannot be reached.
The close study of the code required to achieve high test coverage also
discloses places where the code and its documentation are at odds with
each other.  This work on Data::Dumper is no exception, so we have made
changes to Dumper.pm where appropriate.  In addition, in order to
facilitate this analysis and to make the codebase easier to maintain
going forward, the code in Dumper.pm has been tidied up in certain
locations, mostly with respect to tabs vs. whitespace in indentation and
cuddled elses.

Specifics of this commit:

* Modifications to Dumper.pm

** Eliminate subs Dumpf() and Dumpp, which were neither documented nor
tested anywhere in the codebase.  (They will be reinstated if and only
if someone can provide a rationale for that, along with documentation
and testing.)

** For both Values() and Names():  explicit handling (croak) of the case
where the method is provided with a defined argument that is not an
array reference.

** Tidying, mostly in _dump().

** Deletion of commented-out code.

* New test files

** t/deparse.t
** t/dumpperl.t
** t/indent.t
** t/misc.t
** t/names.t
** t/purity_deepcopy_maxdepth.t
** t/quotekeys.t
** t/seen.t
** t/sortkeys.t
** t/sparseseen.t
** t/toaster.t
** t/values.t

** t/lib/Testing.pm - package holding subs used in the new test files

* Expanded test files

** t/freezer.t
** t/terse.t

* Add test for variable type which Data-Dumper does not handle.  Improve
punctuation in fatal error messge.  Related to: RT #101508.

The work done so far has significantly improved the coverage.  As of Jan
26 2013 we are at:
                                  stmt  bran  cond   sub
Jan 01: blib/lib/Data/Dumper.pm   85.3  76.7  69.6  71.4
Jan 26: blib/lib/Data/Dumper.pm   97.9  94.3  82.1  97.6

Additional revisions submitted by Aaron Crane++:

* Adjust newly-added comment.  Without this change, it appears to run on
into the existing comment on the next line.

* Mention "undefined" in carp message, not "non-ref".  This is a more
precise description of the problem encountered.

* Whitespace corrections.

* Avoid scalar-IO in test routine; just return the concatenated ->Dump
return values directly.

20 files changed:
MANIFEST
dist/Data-Dumper/Dumper.pm
dist/Data-Dumper/t/bless_var_method.t [new file with mode: 0644]
dist/Data-Dumper/t/bugs.t
dist/Data-Dumper/t/deparse.t [new file with mode: 0644]
dist/Data-Dumper/t/dumper.t
dist/Data-Dumper/t/dumpperl.t [new file with mode: 0644]
dist/Data-Dumper/t/freezer.t
dist/Data-Dumper/t/indent.t [new file with mode: 0644]
dist/Data-Dumper/t/lib/Testing.pm [new file with mode: 0644]
dist/Data-Dumper/t/misc.t [new file with mode: 0644]
dist/Data-Dumper/t/names.t [new file with mode: 0644]
dist/Data-Dumper/t/purity_deepcopy_maxdepth.t [new file with mode: 0644]
dist/Data-Dumper/t/quotekeys.t [new file with mode: 0644]
dist/Data-Dumper/t/seen.t [new file with mode: 0644]
dist/Data-Dumper/t/sortkeys.t [new file with mode: 0644]
dist/Data-Dumper/t/sparseseen.t [new file with mode: 0644]
dist/Data-Dumper/t/terse.t
dist/Data-Dumper/t/toaster.t [new file with mode: 0644]
dist/Data-Dumper/t/values.t [new file with mode: 0644]

index a510591..f4e6190 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -3121,15 +3121,29 @@ dist/Data-Dumper/Changes        Data pretty printer, changelog
 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
index 8c8ae7e..d2c4015 100644 (file)
@@ -10,8 +10,8 @@
 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;
 
@@ -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;
 }
@@ -66,37 +66,37 @@ $Sparseseen = 0         unless defined $Sparseseen;
 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} = "  ";
@@ -149,21 +149,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;
@@ -178,9 +183,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}};
@@ -192,9 +202,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}};
@@ -205,9 +220,9 @@ 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::Useqq   || (ref($_[0]) && $_[0]->{useqq}) ||
+           $Data::Dumper::Deparse || (ref($_[0]) && $_[0]->{deparse});
     return &Dumpperl;
 }
 
@@ -225,28 +240,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;
     {
@@ -256,9 +252,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;
   }
@@ -284,8 +278,7 @@ use constant _bad_vsmg => defined &_vstring && (_vstring(~v0)||'') eq "v0";
 #
 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 = "";
@@ -302,65 +295,64 @@ 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 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};
@@ -368,13 +360,13 @@ 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 
+        # 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
@@ -384,115 +376,123 @@ sub _dump {
         # 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
 
@@ -503,46 +503,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;
     }
@@ -550,7 +550,7 @@ 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
@@ -560,10 +560,10 @@ sub _dump {
     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);
@@ -582,7 +582,7 @@ sub _dump {
   }
   return $out;
 }
-  
+
 #
 # non-OO style of earlier version
 #
@@ -595,12 +595,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;
@@ -708,7 +704,7 @@ sub Sparseseen {
 }
 
 # used by qquote below
-my %esc = (  
+my %esc = (
     "\a" => "\\a",
     "\b" => "\\b",
     "\t" => "\\t",
@@ -724,7 +720,7 @@ sub qquote {
   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 || "";
@@ -761,6 +757,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__
 
@@ -819,7 +854,7 @@ these references.  Moreover, if C<eval>ed when strictures are in effect,
 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.
@@ -829,7 +864,7 @@ object will return the object itself, so method calls can be conveniently
 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.
 
 
@@ -881,15 +916,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 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
 
@@ -916,7 +957,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
@@ -1029,7 +1070,7 @@ Cross-referencing will then only be done when absolutely essential
 $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 *
@@ -1061,8 +1102,8 @@ $Data::Dumper::Maxdepth  I<or>  $I<OBJ>->Maxdepth(I<[NEWVAL]>)
 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 *
 
@@ -1157,7 +1198,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];
 
     ########
@@ -1247,20 +1288,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']);
@@ -1359,7 +1400,7 @@ modify it under the same terms as Perl itself.
 
 =head1 VERSION
 
-Version 2.141  (January 13 2013)
+Version 2.142  (January 13 2013)
 
 =head1 SEE ALSO
 
diff --git a/dist/Data-Dumper/t/bless_var_method.t b/dist/Data-Dumper/t/bless_var_method.t
new file mode 100644 (file)
index 0000000..8f00f83
--- /dev/null
@@ -0,0 +1,127 @@
+#!./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 = ();
+}
+
index e8d2126..a440b0a 100644 (file)
@@ -1,6 +1,6 @@
 #!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;
diff --git a/dist/Data-Dumper/t/deparse.t b/dist/Data-Dumper/t/deparse.t
new file mode 100644 (file)
index 0000000..c281fce
--- /dev/null
@@ -0,0 +1,80 @@
+#!./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");
+}
+
index a837d6f..6f618de 100644 (file)
@@ -505,7 +505,7 @@ EOT
   $dogs[2] = \%kennel;
   $mutts = \%kennel;
   $mutts = $mutts;         # avoid warning
-  
+
 ############# 85
 ##
   $WANT = <<'EOT';
@@ -533,7 +533,7 @@ EOT
           $d->Dumpxs;
          );
   }
-  
+
 ############# 91
 ##
   $WANT = <<'EOT';
@@ -544,7 +544,7 @@ EOT
 
   TEST q($d->Dump);
   TEST q($d->Dumpxs) if $XS;
-  
+
 ############# 97
 ##
   $WANT = <<'EOT';
@@ -560,7 +560,7 @@ EOT
 #%mutts = %kennels;
 EOT
 
-  
+
   TEST q($d->Reset; $d->Dump);
   if ($XS) {
     TEST q($d->Reset; $d->Dumpxs);
@@ -593,7 +593,7 @@ EOT
           $d->Dumpxs;
          );
   }
-  
+
 ############# 109
 ##
   TEST q($d->Reset->Dump);
@@ -625,7 +625,7 @@ EOT
   if ($XS) {
     TEST q($d->Reset->Dumpxs);
   }
-  
+
 }
 
 {
@@ -925,7 +925,7 @@ TEST q(Data::Dumper->new([$c])->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)
     ];
diff --git a/dist/Data-Dumper/t/dumpperl.t b/dist/Data-Dumper/t/dumpperl.t
new file mode 100644 (file)
index 0000000..6c1d096
--- /dev/null
@@ -0,0 +1,224 @@
+#!./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");
+}
+
index a67cc12..11b5c2b 100644 (file)
@@ -13,75 +13,164 @@ BEGIN {
 }
 
 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]) }
diff --git a/dist/Data-Dumper/t/indent.t b/dist/Data-Dumper/t/indent.t
new file mode 100644 (file)
index 0000000..dd736be
--- /dev/null
@@ -0,0 +1,110 @@
+#!./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};
diff --git a/dist/Data-Dumper/t/lib/Testing.pm b/dist/Data-Dumper/t/lib/Testing.pm
new file mode 100644 (file)
index 0000000..5eaa8ee
--- /dev/null
@@ -0,0 +1,15 @@
+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;
diff --git a/dist/Data-Dumper/t/misc.t b/dist/Data-Dumper/t/misc.t
new file mode 100644 (file)
index 0000000..2ce81ac
--- /dev/null
@@ -0,0 +1,209 @@
+#!./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"
+    );
+}
diff --git a/dist/Data-Dumper/t/names.t b/dist/Data-Dumper/t/names.t
new file mode 100644 (file)
index 0000000..782f1cb
--- /dev/null
@@ -0,0 +1,66 @@
+#!./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");
+
diff --git a/dist/Data-Dumper/t/purity_deepcopy_maxdepth.t b/dist/Data-Dumper/t/purity_deepcopy_maxdepth.t
new file mode 100644 (file)
index 0000000..f287101
--- /dev/null
@@ -0,0 +1,418 @@
+#!./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");
+}
diff --git a/dist/Data-Dumper/t/quotekeys.t b/dist/Data-Dumper/t/quotekeys.t
new file mode 100644 (file)
index 0000000..5b2f0ae
--- /dev/null
@@ -0,0 +1,139 @@
+#!./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 = ();
+}
+
diff --git a/dist/Data-Dumper/t/seen.t b/dist/Data-Dumper/t/seen.t
new file mode 100644 (file)
index 0000000..08e4f1e
--- /dev/null
@@ -0,0 +1,103 @@
+#!./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");
+}
+
diff --git a/dist/Data-Dumper/t/sortkeys.t b/dist/Data-Dumper/t/sortkeys.t
new file mode 100644 (file)
index 0000000..f4bbcb6
--- /dev/null
@@ -0,0 +1,277 @@
+#!./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");
+}
diff --git a/dist/Data-Dumper/t/sparseseen.t b/dist/Data-Dumper/t/sparseseen.t
new file mode 100644 (file)
index 0000000..3658b85
--- /dev/null
@@ -0,0 +1,128 @@
+#!./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 = ();
+
+}
+
index 8d3ad48..a5be980 100644 (file)
@@ -2,9 +2,11 @@
 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 };
 
@@ -20,3 +22,40 @@ for my $useperl (0..1) {
 }
 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)");
diff --git a/dist/Data-Dumper/t/toaster.t b/dist/Data-Dumper/t/toaster.t
new file mode 100644 (file)
index 0000000..d82524d
--- /dev/null
@@ -0,0 +1,128 @@
+#!./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 = ();
+
+}
+
diff --git a/dist/Data-Dumper/t/values.t b/dist/Data-Dumper/t/values.t
new file mode 100644 (file)
index 0000000..444ebc3
--- /dev/null
@@ -0,0 +1,40 @@
+#!./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()");
+
+