Data::Dumper test compatibility fixes for older Perls
authorSteffen Mueller <smueller@cpan.org>
Fri, 15 Mar 2013 09:28:30 +0000 (10:28 +0100)
committerSteffen Mueller <smueller@cpan.org>
Fri, 15 Mar 2013 09:28:30 +0000 (10:28 +0100)
Ported from Jim Keenan's changes in the DD github repository.

12 files changed:
MANIFEST
dist/Data-Dumper/t/bless.t
dist/Data-Dumper/t/bless_var_method.t
dist/Data-Dumper/t/dumpperl.t
dist/Data-Dumper/t/freezer.t
dist/Data-Dumper/t/freezer_useperl.t [new file with mode: 0644]
dist/Data-Dumper/t/indent.t
dist/Data-Dumper/t/perl-74170.t
dist/Data-Dumper/t/quotekeys.t
dist/Data-Dumper/t/sortkeys.t
dist/Data-Dumper/t/sparseseen.t
dist/Data-Dumper/t/toaster.t

index 45fe093..a79fd32 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -3138,6 +3138,7 @@ 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/dumpperl.t  See if Data::Dumper::Dumpperl works
 dist/Data-Dumper/t/freezer.t   See if Data::Dumper::Freezer works
+dist/Data-Dumper/t/freezer_useperl.t   See if Data::Dumper 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
index 086332c..9866ea7 100644 (file)
@@ -5,16 +5,22 @@ use Test::More 0.60;
 # Test::More 0.60 required because:
 # - is_deeply(undef, $not_undef); now works. [rt.cpan.org 9441]
 
-BEGIN { plan tests => 1+5*2; }
+BEGIN { plan tests => 1+2*5; }
 
 BEGIN { use_ok('Data::Dumper') };
 
 # RT 39420: Data::Dumper fails to escape bless class name
 
-# test under XS and pure Perl version
-foreach $Data::Dumper::Useperl (0, 1) {
+run_tests_for_bless();
+SKIP: {
+    skip "XS version was unavailable, so we already ran with pure Perl", 5
+        if $Data::Dumper::Useperl;
+    local $Data::Dumper::Useperl = 1;
+    run_tests_for_bless();
+}
 
-#diag("\$Data::Dumper::Useperl = $Data::Dumper::Useperl");
+sub run_tests_for_bless {
+note("\$Data::Dumper::Useperl = $Data::Dumper::Useperl");
 
 {
 my $t = bless( {}, q{a'b} );
@@ -52,4 +58,5 @@ PERL_LEGACY
 is($dt, $o, "We can dump blessed qr//'s properly");
 
 }
-}
+
+} # END sub run_tests_for_bless()
index 8f00f83..7af4cdb 100644 (file)
@@ -26,59 +26,18 @@ my %d = (
     alpha   => 'a',
 );
 
-{
+run_tests_for_bless_var_method();
+SKIP: {
+    skip "XS version was unavailable, so we already ran with pure Perl", 4
+        if $Data::Dumper::Useperl;
+    local $Data::Dumper::Useperl = 1;
+    run_tests_for_bless_var_method();
+}
+
+sub run_tests_for_bless_var_method {
     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;
index 6c1d096..9220430 100644 (file)
@@ -14,206 +14,127 @@ BEGIN {
 use strict;
 use Carp;
 use Data::Dumper;
-$Data::Dumper::Indent=1;
-use Test::More tests => 22;
+use Test::More tests => 31;
 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;
+$Data::Dumper::Indent=1;
 
 {
-    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=1;
+    local $Data::Dumper::Useqq=0;
+    local $Data::Dumper::Deparse=0;
+    note('$Data::Dumper::Useperl => 1');
+    run_tests_for_pure_perl_implementations();
+}
 
-    local $Data::Dumper::Useperl = undef;
-    $obj = Data::Dumper->new([$a, $b]);
-    $dumps{'dduundef'} = _dumptostr($obj);
+{
+    local $Data::Dumper::Useperl=0;
+    local $Data::Dumper::Useqq=1;
+    local $Data::Dumper::Deparse=0;
+    note('$Data::Dumper::Useqq => 1');
+    run_tests_for_pure_perl_implementations();
+}
+    
+{
+    local $Data::Dumper::Useperl=0;
+    local $Data::Dumper::Useqq=0;
+    local $Data::Dumper::Deparse=1;
+    note('$Data::Dumper::Deparse => 1');
+    run_tests_for_pure_perl_implementations();
+}
+    
+    
 
-    $Data::Dumper::Useperl= $starting;
+sub run_tests_for_pure_perl_implementations {
 
-    $obj = Data::Dumper->new([$a, $b]);
-    $obj->Useperl(0);
-    $dumps{'useperlzero'} = _dumptostr($obj);
+    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' );
 
+    note('names not provided');
     $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");
+    $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('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;
 }
 
 {
+    my ($obj, $dumpstr, $realtype);
     $obj = Data::Dumper->new([ {IO => *{$::{STDERR}}{IO}} ]);
     $obj->Useperl(1);
     eval { $dumpstr = _dumptostr($obj); };
@@ -221,4 +142,3 @@ local $Data::Dumper::Deparse=0;
     like($@, qr/Can't handle '$realtype' type/,
         "Got expected error: pure-perl: Data-Dumper does not handle $realtype");
 }
-
index 11b5c2b..7f3b7ac 100644 (file)
@@ -7,13 +7,13 @@ BEGIN {
     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;
+        print "1..0 # Skip: Data::Dumper was not built\n";
+        exit 0;
     }
 }
 
 use strict;
-use Test::More tests => 15;
+use Test::More tests =>  8;
 use Data::Dumper;
 use lib qw( ./t/lib );
 use Testing qw( _dumptostr );
@@ -33,18 +33,6 @@ use Testing qw( _dumptostr );
              "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()
     {
@@ -55,15 +43,6 @@ use Testing qw( _dumptostr );
         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
     {
@@ -74,15 +53,6 @@ use Testing qw( _dumptostr );
         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.");
-    }
 }
 
 {
@@ -102,42 +72,6 @@ use Testing qw( _dumptostr );
         "\$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");
-}
-
-{
-    my ($obj, %dumps);
-    my $foo = Test1->new("foo");
-
-    local $Data::Dumper::Useperl = 1;
-    $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");
-}
-
 {
     my ($obj, %dumps);
     my $foo = Test1->new("foo");
diff --git a/dist/Data-Dumper/t/freezer_useperl.t b/dist/Data-Dumper/t/freezer_useperl.t
new file mode 100644 (file)
index 0000000..b79c3c1
--- /dev/null
@@ -0,0 +1,106 @@
+#!./perl -w
+#
+# test a few problems with the Freezer option, not a complete Freezer
+# test suite yet
+
+BEGIN {
+    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 Test::More tests =>  7;
+use Data::Dumper;
+use lib qw( ./t/lib );
+use Testing qw( _dumptostr );
+
+local $Data::Dumper::Useperl = 1;
+
+{
+    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");
+    }
+
+    # 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.");
+    }
+
+    # 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");
+}
+
+{
+    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]) }
+sub freeze {
+    my $self = shift;
+    $self->{frozed} = 1;
+}
+
+# a package without a freeze()
+package Test2;
+sub new { bless({name => $_[1]}, $_[0]) }
+
+# a package with a freeze() which dies
+package Test3;
+sub new { bless({name => $_[1]}, $_[0]) }
+sub freeze { die "freeze() is broken" }
index 90a3be0..a91027d 100644 (file)
@@ -100,3 +100,11 @@ like($dumpstr{ar_indent_3},
 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};
index 4f8025d..cca94ae 100644 (file)
@@ -4,20 +4,20 @@
 # Since it’s so large, it gets its own file.
 
 BEGIN {
-    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;
+    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 Test::More tests => 1;
 use Data::Dumper;
 
-our %repos = ();
-&real_life_setup();
+our %repos = real_life_setup();
 
 $Data::Dumper::Indent = 1;
 # A custom sort sub is necessary for reproducing the bug, as this is where
@@ -25,13 +25,14 @@ $Data::Dumper::Indent = 1;
 $Data::Dumper::Sortkeys = sub { return [ reverse sort keys %{$_[0]} ]; }
     unless exists $ENV{NO_SORT_SUB};
 
-ok +Data::Dumper->Dumpxs([\%repos], [qw(*repos)]);
+ok(Data::Dumper->Dump([\%repos], [qw(*repos)]), "RT 74170 test");
 
 sub real_life_setup {
     # set up the %repos hash in a manner that reflects a real run of
-    # gitolite's "compiler" script:
+    # the gitolite "compiler" script:
     # Yes, all this is necessary to get the stack in such a state that the
     # custom sort sub will trigger a reallocation.
+    my %repos;
     push @{ $repos{''}{'@all'} }, ();
     push @{ $repos{''}{'guser86'} }, ();
     push @{ $repos{''}{'guser87'} }, ();
@@ -140,4 +141,5 @@ sub real_life_setup {
     $repos{''}{R}{'user8'} = 1;
     $repos{''}{W}{'user8'} = 1;
     push @{ $repos{''}{'user8'} }, ();
+    return %repos;
 }
index 5b2f0ae..c633d56 100644 (file)
@@ -26,12 +26,20 @@ my %d = (
     alpha   => 'a',
 );
 
-{
+run_tests_for_quotekeys();
+SKIP: {
+    skip "XS version was unavailable, so we already ran with pure Perl", 5
+        if $Data::Dumper::Useperl;
+    local $Data::Dumper::Useperl = 1;
+    run_tests_for_quotekeys();
+}
+
+sub run_tests_for_quotekeys {
+    note("\$Data::Dumper::Useperl = $Data::Dumper::Useperl");
+
     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);
@@ -82,58 +90,5 @@ my %d = (
     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 = ();
 }
 
index f4bbcb6..fbd8197 100644 (file)
@@ -15,263 +15,176 @@ BEGIN {
 use strict;
 
 use Data::Dumper;
-use Test::More tests => 23;
+use Test::More tests => 26;
 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");
+run_tests_for_sortkeys();
+SKIP: {
+    skip "XS version was unavailable, so we already ran with pure Perl", 13 
+        if $Data::Dumper::Useperl;
+    local $Data::Dumper::Useperl = 1;
+    run_tests_for_sortkeys();
 }
 
-{
-    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 ];
+sub run_tests_for_sortkeys {
+    note("\$Data::Dumper::Useperl = $Data::Dumper::Useperl");
+
+    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");
+    
+        $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 = ();
+    
+    }
+    
+    {
+        my ($obj, %dumps, $starting);
+    
+        note("\$Data::Dumper::Sortkeys and Sortkeys() set to coderef");
+    
+        $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 = ();
+    
+    }
+    
+    {
+        my ($obj, %dumps, $starting);
+    
+        note("\$Data::Dumper::Sortkeys and Sortkeys() set to coderef with filter");
+        $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 = ();
+    
+    }
+    
+    {
+        my ($obj, %dumps, $sortkeys, $starting);
+    
+        note("\$Data::Dumper::Sortkeys(undef) and Sortkeys(undef)");
+    
+        $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("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");
+    
+        $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");
     }
 
-    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);
+sub reversekeys { return [ reverse sort keys %{+shift} ]; }
 
-    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");
+sub reversekeystrim {
+    my $hr = shift;
+    my @keys = sort keys %{$hr};
+    shift(@keys);
+    return [ reverse @keys ];
 }
 
-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");
-}
+sub badreturnvalue { return { %{+shift} }; }
index 3658b85..c78dec6 100644 (file)
@@ -26,59 +26,20 @@ my %d = (
     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;
+run_tests_for_sparseseen();
+SKIP: {
+    skip "XS version was unavailable, so we already ran with pure Perl", 4
+        if $Data::Dumper::Useperl;
+    local $Data::Dumper::Useperl = 1;
+    run_tests_for_sparseseen();
+}
 
-    $obj = Data::Dumper->new( [ \%d ] );
-    $obj->Sparseseen($sparseseen);
-    $dumps{'objssundef'} = _dumptostr($obj);
+sub run_tests_for_sparseseen {
+    note("\$Data::Dumper::Useperl = $Data::Dumper::Useperl");
 
-    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 = ();
+    my ($obj, %dumps, $sparseseen, $starting);
 
-    note("Perl implementation");
-    $Data::Dumper::Useperl = 1;
+    note("\$Data::Dumper::Sparseseen and Sparseseen() set to true value");
 
     $starting = $Data::Dumper::Sparseseen;
     $sparseseen = 1;
@@ -123,6 +84,5 @@ my %d = (
     is($dumps{'ddsszero'}, $dumps{'objssundef'},
         "\$Data::Dumper::Sparseseen = undef and = 0 are equivalent");
     %dumps = ();
-
 }
 
index d82524d..6e7d0e0 100644 (file)
@@ -26,59 +26,20 @@ my %d = (
     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;
+run_tests_for_toaster();
+SKIP: {
+    skip "XS version was unavailable, so we already ran with pure Perl", 4
+        if $Data::Dumper::Useperl;
+    local $Data::Dumper::Useperl = 1;
+    run_tests_for_toaster();
+}
 
-    $obj = Data::Dumper->new( [ \%d ] );
-    $obj->Toaster($toaster);
-    $dumps{'objtoasterundef'} = _dumptostr($obj);
+sub run_tests_for_toaster {
+    note("\$Data::Dumper::Useperl = $Data::Dumper::Useperl");
 
-    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 = ();
+    my ($obj, %dumps, $toaster, $starting);
 
-    note("Perl implementation");
-    $Data::Dumper::Useperl = 1;
+    note("\$Data::Dumper::Toaster and Toaster() set to true value");
 
     $starting = $Data::Dumper::Toaster;
     $toaster = 1;
@@ -123,6 +84,5 @@ my %d = (
     is($dumps{'ddtoasterzero'}, $dumps{'objtoasterundef'},
         "\$Data::Dumper::Toaster = undef and = 0 are equivalent");
     %dumps = ();
-
 }