1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
|
#!./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} }; }
|
