In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/6e138f133ca33e95be2121fd060a4b15bcf265e1?hp=940a04b39217e2aa30e922aa13a992903adec835>
- Log ----------------------------------------------------------------- commit 6e138f133ca33e95be2121fd060a4b15bcf265e1 Author: Steffen Mueller <[email protected]> Date: Fri Mar 15 10:29:37 2013 +0100 Data::Dumper version bump and changelog for release M dist/Data-Dumper/Changes M dist/Data-Dumper/Dumper.pm commit ed960e770db09e7a14d466307081aa5ed00e055f Author: Steffen Mueller <[email protected]> Date: Fri Mar 15 10:28:30 2013 +0100 Data::Dumper test compatibility fixes for older Perls Ported from Jim Keenan's changes in the DD github repository. M MANIFEST M dist/Data-Dumper/t/bless.t M dist/Data-Dumper/t/bless_var_method.t M dist/Data-Dumper/t/dumpperl.t M dist/Data-Dumper/t/freezer.t A dist/Data-Dumper/t/freezer_useperl.t M dist/Data-Dumper/t/indent.t M dist/Data-Dumper/t/perl-74170.t M dist/Data-Dumper/t/quotekeys.t M dist/Data-Dumper/t/sortkeys.t M dist/Data-Dumper/t/sparseseen.t M dist/Data-Dumper/t/toaster.t commit d22722a1b35e2d075cbe401a4f4fbcc541f488e0 Author: Steffen Mueller <[email protected]> Date: Fri Mar 15 10:21:12 2013 +0100 Add security warning about eval'ing DD output As if it isn't obvious, but, well, people do it. M dist/Data-Dumper/Dumper.pm ----------------------------------------------------------------------- Summary of changes: MANIFEST | 1 + dist/Data-Dumper/Changes | 6 + dist/Data-Dumper/Dumper.pm | 7 +- dist/Data-Dumper/t/bless.t | 17 +- dist/Data-Dumper/t/bless_var_method.t | 59 +---- dist/Data-Dumper/t/dumpperl.t | 296 +++++++++--------------- dist/Data-Dumper/t/freezer.t | 72 +------ dist/Data-Dumper/t/freezer_useperl.t | 106 +++++++++ dist/Data-Dumper/t/indent.t | 8 + dist/Data-Dumper/t/perl-74170.t | 22 +- dist/Data-Dumper/t/quotekeys.t | 67 +----- dist/Data-Dumper/t/sortkeys.t | 409 +++++++++++++-------------------- dist/Data-Dumper/t/sparseseen.t | 62 +---- dist/Data-Dumper/t/toaster.t | 62 +---- 14 files changed, 463 insertions(+), 731 deletions(-) create mode 100644 dist/Data-Dumper/t/freezer_useperl.t diff --git a/MANIFEST b/MANIFEST index 45fe093..a79fd32 100644 --- 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 diff --git a/dist/Data-Dumper/Changes b/dist/Data-Dumper/Changes index d2240d7..84627ba 100644 --- a/dist/Data-Dumper/Changes +++ b/dist/Data-Dumper/Changes @@ -6,6 +6,12 @@ Changes - public release history for Data::Dumper =over 8 +=item 2.145 (Mar 15 2013) + +Test refactoring and fixing wide and far. + +Various old-perl compat fixes. + =item 2.143 (Feb 26 2013) Address vstring related test failures on 5.8: Skip tests for diff --git a/dist/Data-Dumper/Dumper.pm b/dist/Data-Dumper/Dumper.pm index d5d25ed..a04024e 100644 --- a/dist/Data-Dumper/Dumper.pm +++ b/dist/Data-Dumper/Dumper.pm @@ -10,7 +10,7 @@ package Data::Dumper; BEGIN { - $VERSION = '2.144'; # Don't forget to set version and release + $VERSION = '2.145'; # Don't forget to set version and release } # date in POD below! #$| = 1; @@ -836,7 +836,8 @@ variable is output in a single Perl statement. Handles self-referential structures correctly. The return value can be C<eval>ed to get back an identical copy of the -original reference structure. +original reference structure. (Please do consider the security implications +of eval'ing code from untrusted sources!) Any references that are the same as one of those passed in will be named C<$VAR>I<n> (where I<n> is a numeric suffix), and other duplicate references @@ -1400,7 +1401,7 @@ modify it under the same terms as Perl itself. =head1 VERSION -Version 2.144 (March 07 2013) +Version 2.145 (March 15 2013)) =head1 SEE ALSO diff --git a/dist/Data-Dumper/t/bless.t b/dist/Data-Dumper/t/bless.t index 086332c..9866ea7 100644 --- a/dist/Data-Dumper/t/bless.t +++ b/dist/Data-Dumper/t/bless.t @@ -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() diff --git a/dist/Data-Dumper/t/bless_var_method.t b/dist/Data-Dumper/t/bless_var_method.t index 8f00f83..7af4cdb 100644 --- a/dist/Data-Dumper/t/bless_var_method.t +++ b/dist/Data-Dumper/t/bless_var_method.t @@ -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; diff --git a/dist/Data-Dumper/t/dumpperl.t b/dist/Data-Dumper/t/dumpperl.t index 6c1d096..9220430 100644 --- a/dist/Data-Dumper/t/dumpperl.t +++ b/dist/Data-Dumper/t/dumpperl.t @@ -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"); } - diff --git a/dist/Data-Dumper/t/freezer.t b/dist/Data-Dumper/t/freezer.t index 11b5c2b..7f3b7ac 100644 --- a/dist/Data-Dumper/t/freezer.t +++ b/dist/Data-Dumper/t/freezer.t @@ -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."); - } } { @@ -106,42 +76,6 @@ use Testing qw( _dumptostr ); 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"); - local $Data::Dumper::Freezer = ''; $obj = Data::Dumper->new( [ $foo ] ); $dumps{'ddfemptystr'} = _dumptostr($obj); diff --git a/dist/Data-Dumper/t/freezer_useperl.t b/dist/Data-Dumper/t/freezer_useperl.t new file mode 100644 index 0000000..b79c3c1 --- /dev/null +++ b/dist/Data-Dumper/t/freezer_useperl.t @@ -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" } diff --git a/dist/Data-Dumper/t/indent.t b/dist/Data-Dumper/t/indent.t index 90a3be0..a91027d 100644 --- a/dist/Data-Dumper/t/indent.t +++ b/dist/Data-Dumper/t/indent.t @@ -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}; diff --git a/dist/Data-Dumper/t/perl-74170.t b/dist/Data-Dumper/t/perl-74170.t index 4f8025d..cca94ae 100644 --- a/dist/Data-Dumper/t/perl-74170.t +++ b/dist/Data-Dumper/t/perl-74170.t @@ -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; } diff --git a/dist/Data-Dumper/t/quotekeys.t b/dist/Data-Dumper/t/quotekeys.t index 5b2f0ae..c633d56 100644 --- a/dist/Data-Dumper/t/quotekeys.t +++ b/dist/Data-Dumper/t/quotekeys.t @@ -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 = (); } diff --git a/dist/Data-Dumper/t/sortkeys.t b/dist/Data-Dumper/t/sortkeys.t index f4bbcb6..fbd8197 100644 --- a/dist/Data-Dumper/t/sortkeys.t +++ b/dist/Data-Dumper/t/sortkeys.t @@ -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} }; } diff --git a/dist/Data-Dumper/t/sparseseen.t b/dist/Data-Dumper/t/sparseseen.t index 3658b85..c78dec6 100644 --- a/dist/Data-Dumper/t/sparseseen.t +++ b/dist/Data-Dumper/t/sparseseen.t @@ -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 = (); - } diff --git a/dist/Data-Dumper/t/toaster.t b/dist/Data-Dumper/t/toaster.t index d82524d..6e7d0e0 100644 --- a/dist/Data-Dumper/t/toaster.t +++ b/dist/Data-Dumper/t/toaster.t @@ -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 = (); - } -- Perl5 Master Repository
