xref: /openbsd-src/gnu/usr.bin/perl/dist/Data-Dumper/t/sortkeys.t (revision f2da64fbbbf1b03f09f390ab01267c93dfd77c4c) 
1#!./perl -w
2# t/sortkeys.t - Test Sortkeys()
3
4BEGIN {
5    if ($ENV{PERL_CORE}){
6        require Config; import Config;
7        no warnings 'once';
8        if ($Config{'extensions'} !~ /\bData\/Dumper\b/) {
9            print "1..0 # Skip: Data::Dumper was not built\n";
10            exit 0;
11        }
12    }
13}
14
15use strict;
16
17use Data::Dumper;
18use Test::More tests => 26;
19use lib qw( ./t/lib );
20use Testing qw( _dumptostr );
21
22run_tests_for_sortkeys();
23SKIP: {
24    skip "XS version was unavailable, so we already ran with pure Perl", 13
25        if $Data::Dumper::Useperl;
26    local $Data::Dumper::Useperl = 1;
27    run_tests_for_sortkeys();
28}
29
30sub run_tests_for_sortkeys {
31    note("\$Data::Dumper::Useperl = $Data::Dumper::Useperl");
32
33    my %d = (
34        delta   => 'd',
35        beta    => 'b',
36        gamma   => 'c',
37        alpha   => 'a',
38    );
39
40    {
41        my ($obj, %dumps, $sortkeys, $starting);
42
43        note("\$Data::Dumper::Sortkeys and Sortkeys() set to true value");
44
45        $starting = $Data::Dumper::Sortkeys;
46        $sortkeys = 1;
47        local $Data::Dumper::Sortkeys = $sortkeys;
48        $obj = Data::Dumper->new( [ \%d ] );
49        $dumps{'ddskone'} = _dumptostr($obj);
50        local $Data::Dumper::Sortkeys = $starting;
51
52        $obj = Data::Dumper->new( [ \%d ] );
53        $obj->Sortkeys($sortkeys);
54        $dumps{'objskone'} = _dumptostr($obj);
55
56        is($dumps{'ddskone'}, $dumps{'objskone'},
57            "\$Data::Dumper::Sortkeys = 1 and Sortkeys(1) are equivalent");
58        like($dumps{'ddskone'},
59            qr/alpha.*?beta.*?delta.*?gamma/s,
60            "Sortkeys returned hash keys in Perl's default sort order");
61        %dumps = ();
62
63    }
64
65    {
66        my ($obj, %dumps, $starting);
67
68        note("\$Data::Dumper::Sortkeys and Sortkeys() set to coderef");
69
70        $starting = $Data::Dumper::Sortkeys;
71        local $Data::Dumper::Sortkeys = \&reversekeys;
72        $obj = Data::Dumper->new( [ \%d ] );
73        $dumps{'ddsksub'} = _dumptostr($obj);
74        local $Data::Dumper::Sortkeys = $starting;
75
76        $obj = Data::Dumper->new( [ \%d ] );
77        $obj->Sortkeys(\&reversekeys);
78        $dumps{'objsksub'} = _dumptostr($obj);
79
80        is($dumps{'ddsksub'}, $dumps{'objsksub'},
81            "\$Data::Dumper::Sortkeys = CODEREF and Sortkeys(CODEREF) are equivalent");
82        like($dumps{'ddsksub'},
83            qr/gamma.*?delta.*?beta.*?alpha/s,
84            "Sortkeys returned hash keys per sorting subroutine");
85        %dumps = ();
86
87    }
88
89    {
90        my ($obj, %dumps, $starting);
91
92        note("\$Data::Dumper::Sortkeys and Sortkeys() set to coderef with filter");
93        $starting = $Data::Dumper::Sortkeys;
94        local $Data::Dumper::Sortkeys = \&reversekeystrim;
95        $obj = Data::Dumper->new( [ \%d ] );
96        $dumps{'ddsksub'} = _dumptostr($obj);
97        local $Data::Dumper::Sortkeys = $starting;
98
99        $obj = Data::Dumper->new( [ \%d ] );
100        $obj->Sortkeys(\&reversekeystrim);
101        $dumps{'objsksub'} = _dumptostr($obj);
102
103        is($dumps{'ddsksub'}, $dumps{'objsksub'},
104            "\$Data::Dumper::Sortkeys = CODEREF and Sortkeys(CODEREF) select same keys");
105        like($dumps{'ddsksub'},
106            qr/gamma.*?delta.*?beta/s,
107            "Sortkeys returned hash keys per sorting subroutine");
108        unlike($dumps{'ddsksub'},
109            qr/alpha/s,
110            "Sortkeys filtered out one key per request");
111        %dumps = ();
112
113    }
114
115    {
116        my ($obj, %dumps, $sortkeys, $starting);
117
118        note("\$Data::Dumper::Sortkeys(undef) and Sortkeys(undef)");
119
120        $starting = $Data::Dumper::Sortkeys;
121        $sortkeys = 0;
122        local $Data::Dumper::Sortkeys = $sortkeys;
123        $obj = Data::Dumper->new( [ \%d ] );
124        $dumps{'ddskzero'} = _dumptostr($obj);
125        local $Data::Dumper::Sortkeys = $starting;
126
127        $obj = Data::Dumper->new( [ \%d ] );
128        $obj->Sortkeys($sortkeys);
129        $dumps{'objskzero'} = _dumptostr($obj);
130
131        $sortkeys = undef;
132        local $Data::Dumper::Sortkeys = $sortkeys;
133        $obj = Data::Dumper->new( [ \%d ] );
134        $dumps{'ddskundef'} = _dumptostr($obj);
135        local $Data::Dumper::Sortkeys = $starting;
136
137        $obj = Data::Dumper->new( [ \%d ] );
138        $obj->Sortkeys($sortkeys);
139        $dumps{'objskundef'} = _dumptostr($obj);
140
141        is($dumps{'ddskzero'}, $dumps{'objskzero'},
142            "\$Data::Dumper::Sortkeys = 0 and Sortkeys(0) are equivalent");
143        is($dumps{'ddskzero'}, $dumps{'ddskundef'},
144            "\$Data::Dumper::Sortkeys = 0 and = undef equivalent");
145        is($dumps{'objkzero'}, $dumps{'objkundef'},
146            "Sortkeys(0) and Sortkeys(undef) are equivalent");
147        %dumps = ();
148
149    }
150
151    note("Internal subroutine _sortkeys");
152    my %e = (
153        nu      => 'n',
154        lambda  => 'l',
155        kappa   => 'k',
156        mu      => 'm',
157        omicron => 'o',
158    );
159    my $rv = Data::Dumper::_sortkeys(\%e);
160    is(ref($rv), 'ARRAY', "Data::Dumper::_sortkeys returned an array ref");
161    is_deeply($rv, [ qw( kappa lambda mu nu omicron ) ],
162        "Got keys in Perl default order");
163    {
164        my $warning = '';
165        local $SIG{__WARN__} = sub { $warning = $_[0] };
166
167        my ($obj, %dumps, $starting);
168
169        note("\$Data::Dumper::Sortkeys and Sortkeys() set to coderef");
170
171        $starting = $Data::Dumper::Sortkeys;
172        local $Data::Dumper::Sortkeys = \&badreturnvalue;
173        $obj = Data::Dumper->new( [ \%d ] );
174        $dumps{'ddsksub'} = _dumptostr($obj);
175        like($warning, qr/^Sortkeys subroutine did not return ARRAYREF/,
176            "Got expected warning: sorting routine did not return array ref");
177    }
178
179}
180
181sub reversekeys { return [ reverse sort keys %{+shift} ]; }
182
183sub reversekeystrim {
184    my $hr = shift;
185    my @keys = sort keys %{$hr};
186    shift(@keys);
187    return [ reverse @keys ];
188}
189
190sub badreturnvalue { return { %{+shift} }; }
191