Gecko [ www.blackthorn-inc.com ]

Name	Size	Permission	Date
lib	[ DIR ]	drwxr-xr-x	2015-02-14 16:56
bless.t	1.33 KB	-r--r--r--	2014-12-27 11:48
bless_var_method.t	2.31 KB	-r--r--r--	2014-12-27 11:48
bugs.t	3.61 KB	-r--r--r--	2014-12-27 11:48
deparse.t	2.44 KB	-r--r--r--	2014-12-27 11:48
dumper.t	38.19 KB	-r--r--r--	2014-12-27 11:49
dumpperl.t	3.7 KB	-r--r--r--	2014-12-27 11:48
freezer.t	3.14 KB	-r--r--r--	2014-12-27 11:48
freezer_useperl.t	2.72 KB	-r--r--r--	2014-12-27 11:48
indent.t	3 KB	-r--r--r--	2014-12-27 11:48
misc.t	5.95 KB	-r--r--r--	2014-12-27 11:48
names.t	2.1 KB	-r--r--r--	2014-12-27 11:48
overload.t	610 B	-r--r--r--	2014-12-27 11:48
pair.t	1.87 KB	-r--r--r--	2014-12-27 11:48
perl-74170.t	5.33 KB	-r--r--r--	2014-12-27 11:48
purity_deepcopy_maxdepth.t	10.76 KB	-r--r--r--	2014-12-27 11:48
qr.t	515 B	-r--r--r--	2014-12-27 11:48
quotekeys.t	4.08 KB	-r--r--r--	2014-12-27 11:48
recurse.t	1.64 KB	-r--r--r--	2015-01-10 12:06
seen.t	2.56 KB	-r--r--r--	2014-12-27 11:48
sortkeys.t	5.85 KB	-r--r--r--	2014-12-27 11:48
sparseseen.t	2.46 KB	-r--r--r--	2014-12-27 11:48
terse.t	1.33 KB	-r--r--r--	2014-12-27 11:48
toaster.t	2.43 KB	-r--r--r--	2014-12-27 11:48
values.t	1.06 KB	-r--r--r--	2014-12-27 11:48

Rename

#!./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 => 26;
use lib qw( ./t/lib );
use Testing qw( _dumptostr );

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();
}

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");
    }

}

sub reversekeys { return [ reverse sort keys %{+shift} ]; }

sub reversekeystrim {
    my $hr = shift;
    my @keys = sort keys %{$hr};
    shift(@keys);
    return [ reverse @keys ];
}

sub badreturnvalue { return { %{+shift} }; }