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