This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
sort fns: simplify handing uninit warnings
[perl5.git] / t / op / sort.t
CommitLineData
a687059c
LW
1#!./perl
2
9c007264
JH
3BEGIN {
4 chdir 't' if -d 't';
ab4454fc 5 require './test.pl';
43ece5b1 6 set_up_inc('../lib');
9c007264 7}
9f1b1f2d 8use warnings;
487e470d 9plan( tests => 183 );
a687059c 10
71a29c3c
GS
11# these shouldn't hang
12{
13 no warnings;
14 sort { for ($_ = 0;; $_++) {} } @a;
15 sort { while(1) {} } @a;
16 sort { while(1) { last; } } @a;
17 sort { while(0) { last; } } @a;
1937c63e
ST
18
19 # Change 26011: Re: A surprising segfault
20 map scalar(sort(+())), ('')x68;
71a29c3c
GS
21}
22
9f1b1f2d
GS
23sub Backwards { $a lt $b ? 1 : $a gt $b ? -1 : 0 }
24sub Backwards_stacked($$) { my($a,$b) = @_; $a lt $b ? 1 : $a gt $b ? -1 : 0 }
9850bf21 25sub Backwards_other { $a lt $b ? 1 : $a gt $b ? -1 : 0 }
a687059c 26
9d116dd7
JH
27my $upperfirst = 'A' lt 'a';
28
29# Beware: in future this may become hairier because of possible
59608b94 30# collation complications: qw(A a B b) can be sorted at least as
9d116dd7
JH
31# any of the following
32#
33# A a B b
34# A B a b
35# a b A B
36# a A b B
37#
38# All the above orders make sense.
39#
40# That said, EBCDIC sorts all small letters first, as opposed
41# to ASCII which sorts all big letters first.
42
a687059c 43@harry = ('dog','cat','x','Cain','Abel');
2f52a358 44@george = ('gone','chased','yz','punished','Axed');
a687059c
LW
45
46$x = join('', sort @harry);
9d116dd7 47$expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain';
f34362ee
DL
48
49cmp_ok($x,'eq',$expected,'upper first 1');
a687059c 50
9f1b1f2d 51$x = join('', sort( Backwards @harry));
9d116dd7 52$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat';
f34362ee
DL
53
54cmp_ok($x,'eq',$expected,'upper first 2');
a687059c 55
9f1b1f2d 56$x = join('', sort( Backwards_stacked @harry));
43481408 57$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat';
f34362ee
DL
58
59cmp_ok($x,'eq',$expected,'upper first 3');
43481408 60
a687059c 61$x = join('', sort @george, 'to', @harry);
9d116dd7
JH
62$expected = $upperfirst ?
63 'AbelAxedCaincatchaseddoggonepunishedtoxyz' :
64 'catchaseddoggonepunishedtoxyzAbelAxedCain' ;
03a14243 65
f34362ee
DL
66cmp_ok($x,'eq',$expected,'upper first 4');
67$" = ' ';
03a14243
LW
68@a = ();
69@b = reverse @a;
f34362ee 70cmp_ok("@b",'eq',"",'reverse 1');
03a14243
LW
71
72@a = (1);
73@b = reverse @a;
f34362ee 74cmp_ok("@b",'eq',"1",'reverse 2');
03a14243
LW
75
76@a = (1,2);
77@b = reverse @a;
f34362ee 78cmp_ok("@b",'eq',"2 1",'reverse 3');
03a14243
LW
79
80@a = (1,2,3);
81@b = reverse @a;
f34362ee 82cmp_ok("@b",'eq',"3 2 1",'reverse 4');
03a14243
LW
83
84@a = (1,2,3,4);
85@b = reverse @a;
f34362ee 86cmp_ok("@b",'eq',"4 3 2 1",'reverse 5');
55204971
LW
87
88@a = (10,2,3,4);
89@b = sort {$a <=> $b;} @a;
f34362ee 90cmp_ok("@b",'eq',"2 3 4 10",'sort numeric');
988174c1 91
9f1b1f2d 92$sub = 'Backwards';
988174c1 93$x = join('', sort $sub @harry);
9d116dd7 94$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat';
f34362ee
DL
95
96cmp_ok($x,'eq',$expected,'sorter sub name in var 1');
43481408 97
9f1b1f2d 98$sub = 'Backwards_stacked';
43481408
GS
99$x = join('', sort $sub @harry);
100$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat';
f34362ee
DL
101
102cmp_ok($x,'eq',$expected,'sorter sub name in var 2');
988174c1 103
cd5de442
GS
104# literals, combinations
105
106@b = sort (4,1,3,2);
f34362ee
DL
107cmp_ok("@b",'eq','1 2 3 4','just sort');
108
cd5de442
GS
109
110@b = sort grep { $_ } (4,1,3,2);
f34362ee
DL
111cmp_ok("@b",'eq','1 2 3 4','grep then sort');
112
cd5de442
GS
113
114@b = sort map { $_ } (4,1,3,2);
f34362ee
DL
115cmp_ok("@b",'eq','1 2 3 4','map then sort');
116
cd5de442
GS
117
118@b = sort reverse (4,1,3,2);
f34362ee
DL
119cmp_ok("@b",'eq','1 2 3 4','reverse then sort');
120
121
01b5ef50
FC
122@b = sort CORE::reverse (4,1,3,2);
123cmp_ok("@b",'eq','1 2 3 4','CORE::reverse then sort');
124
487e470d
FC
125eval { @b = sort CORE::revers (4,1,3,2); };
126like($@, qr/^Undefined sort subroutine "CORE::revers" called at /);
01b5ef50 127
7bac28a0 128
9850bf21 129sub twoface { no warnings 'redefine'; *twoface = sub { $a <=> $b }; &twoface }
7bac28a0 130eval { @b = sort twoface 4,1,3,2 };
f34362ee
DL
131cmp_ok("@b",'eq','1 2 3 4','redefine sort sub inside the sort sub');
132
7bac28a0 133
9f1b1f2d 134eval { no warnings 'redefine'; *twoface = sub { &Backwards } };
f34362ee 135ok(!$@,"redefining sort subs outside the sort \$@=[$@]");
7bac28a0
PP
136
137eval { @b = sort twoface 4,1,3,2 };
f34362ee 138cmp_ok("@b",'eq','4 3 2 1','twoface redefinition');
7bac28a0 139
9f1b1f2d
GS
140{
141 no warnings 'redefine';
9850bf21 142 *twoface = sub { *twoface = *Backwards_other; $a <=> $b };
9f1b1f2d 143}
f34362ee 144
9850bf21 145eval { @b = sort twoface 4,1,9,5 };
f34362ee 146ok(($@ eq "" && "@b" eq "1 4 5 9"),'redefinition should not take effect during the sort');
7bac28a0 147
9f1b1f2d
GS
148{
149 no warnings 'redefine';
150 *twoface = sub {
7bac28a0 151 eval 'sub twoface { $a <=> $b }';
f34362ee 152 die($@ eq "" ? "good\n" : "bad\n");
7bac28a0
PP
153 $a <=> $b;
154 };
9f1b1f2d 155}
7bac28a0 156eval { @b = sort twoface 4,1 };
f34362ee 157cmp_ok(substr($@,0,4), 'eq', 'good', 'twoface eval');
15f0808c
GS
158
159eval <<'CODE';
9f1b1f2d 160 my @result = sort main'Backwards 'one', 'two';
15f0808c 161CODE
f34362ee 162cmp_ok($@,'eq','',q(old skool package));
15f0808c
GS
163
164eval <<'CODE';
165 # "sort 'one', 'two'" should not try to parse "'one" as a sort sub
166 my @result = sort 'one', 'two';
167CODE
f34362ee 168cmp_ok($@,'eq','',q(one is not a sub));
c6e96bcb
GS
169
170{
9f1b1f2d
GS
171 my $sortsub = \&Backwards;
172 my $sortglob = *Backwards;
173 my $sortglobr = \*Backwards;
174 my $sortname = 'Backwards';
c6e96bcb 175 @b = sort $sortsub 4,1,3,2;
f34362ee 176 cmp_ok("@b",'eq','4 3 2 1','sortname 1');
c6e96bcb 177 @b = sort $sortglob 4,1,3,2;
f34362ee 178 cmp_ok("@b",'eq','4 3 2 1','sortname 2');
c6e96bcb 179 @b = sort $sortname 4,1,3,2;
f34362ee 180 cmp_ok("@b",'eq','4 3 2 1','sortname 3');
62f274bf 181 @b = sort $sortglobr 4,1,3,2;
f34362ee 182 cmp_ok("@b",'eq','4 3 2 1','sortname 4');
43481408
GS
183}
184
185{
9f1b1f2d
GS
186 my $sortsub = \&Backwards_stacked;
187 my $sortglob = *Backwards_stacked;
188 my $sortglobr = \*Backwards_stacked;
189 my $sortname = 'Backwards_stacked';
43481408 190 @b = sort $sortsub 4,1,3,2;
f34362ee 191 cmp_ok("@b",'eq','4 3 2 1','sortname 5');
43481408 192 @b = sort $sortglob 4,1,3,2;
f34362ee 193 cmp_ok("@b",'eq','4 3 2 1','sortname 6');
43481408 194 @b = sort $sortname 4,1,3,2;
f34362ee 195 cmp_ok("@b",'eq','4 3 2 1','sortname 7');
43481408 196 @b = sort $sortglobr 4,1,3,2;
f34362ee 197 cmp_ok("@b",'eq','4 3 2 1','sortname 8');
c6e96bcb
GS
198}
199
200{
9f1b1f2d
GS
201 local $sortsub = \&Backwards;
202 local $sortglob = *Backwards;
203 local $sortglobr = \*Backwards;
204 local $sortname = 'Backwards';
c6e96bcb 205 @b = sort $sortsub 4,1,3,2;
f34362ee 206 cmp_ok("@b",'eq','4 3 2 1','sortname local 1');
c6e96bcb 207 @b = sort $sortglob 4,1,3,2;
f34362ee 208 cmp_ok("@b",'eq','4 3 2 1','sortname local 2');
c6e96bcb 209 @b = sort $sortname 4,1,3,2;
f34362ee 210 cmp_ok("@b",'eq','4 3 2 1','sortname local 3');
62f274bf 211 @b = sort $sortglobr 4,1,3,2;
f34362ee 212 cmp_ok("@b",'eq','4 3 2 1','sortname local 4');
43481408
GS
213}
214
215{
9f1b1f2d
GS
216 local $sortsub = \&Backwards_stacked;
217 local $sortglob = *Backwards_stacked;
218 local $sortglobr = \*Backwards_stacked;
219 local $sortname = 'Backwards_stacked';
43481408 220 @b = sort $sortsub 4,1,3,2;
f34362ee 221 cmp_ok("@b",'eq','4 3 2 1','sortname local 5');
43481408 222 @b = sort $sortglob 4,1,3,2;
f34362ee 223 cmp_ok("@b",'eq','4 3 2 1','sortname local 6');
43481408 224 @b = sort $sortname 4,1,3,2;
f34362ee 225 cmp_ok("@b",'eq','4 3 2 1','sortname local 7');
43481408 226 @b = sort $sortglobr 4,1,3,2;
f34362ee 227 cmp_ok("@b",'eq','4 3 2 1','sortname local 8');
c6e96bcb
GS
228}
229
9c007264
JH
230## exercise sort builtins... ($a <=> $b already tested)
231@a = ( 5, 19, 1996, 255, 90 );
5d4fa709
GS
232@b = sort {
233 my $dummy; # force blockness
234 return $b <=> $a
235} @a;
f34362ee
DL
236cmp_ok("@b",'eq','1996 255 90 19 5','force blockness');
237
9c007264
JH
238$x = join('', sort { $a cmp $b } @harry);
239$expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain';
f34362ee
DL
240cmp_ok($x,'eq',$expected,'a cmp b');
241
9c007264
JH
242$x = join('', sort { $b cmp $a } @harry);
243$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat';
f34362ee
DL
244cmp_ok($x,'eq',$expected,'b cmp a');
245
9c007264
JH
246{
247 use integer;
248 @b = sort { $a <=> $b } @a;
f34362ee
DL
249 cmp_ok("@b",'eq','5 19 90 255 1996','integer a <=> b');
250
9c007264 251 @b = sort { $b <=> $a } @a;
f34362ee
DL
252 cmp_ok("@b",'eq','1996 255 90 19 5','integer b <=> a');
253
9c007264
JH
254 $x = join('', sort { $a cmp $b } @harry);
255 $expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain';
f34362ee
DL
256 cmp_ok($x,'eq',$expected,'integer a cmp b');
257
9c007264
JH
258 $x = join('', sort { $b cmp $a } @harry);
259 $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat';
f34362ee
DL
260 cmp_ok($x,'eq',$expected,'integer b cmp a');
261
9c007264 262}
e507f050 263
f34362ee
DL
264
265
e507f050 266$x = join('', sort { $a <=> $b } 3, 1, 2);
f34362ee 267cmp_ok($x,'eq','123',q(optimized-away comparison block doesn't take any other arguments away with it));
e507f050 268
9c007264 269# test sorting in non-main package
5823dc9f
MS
270{
271 package Foo;
272 @a = ( 5, 19, 1996, 255, 90 );
273 @b = sort { $b <=> $a } @a;
274 ::cmp_ok("@b",'eq','1996 255 90 19 5','not in main:: 1');
8e3f9bdf 275
5823dc9f
MS
276 @b = sort ::Backwards_stacked @a;
277 ::cmp_ok("@b",'eq','90 5 255 1996 19','not in main:: 2');
f34362ee 278
5823dc9f
MS
279 # check if context for sort arguments is handled right
280 sub test_if_list {
281 my $gimme = wantarray;
282 ::is($gimme,1,'wantarray 1');
283 }
284 my $m = sub { $a <=> $b };
285
286 sub cxt_one { sort $m test_if_list() }
287 cxt_one();
288 sub cxt_two { sort { $a <=> $b } test_if_list() }
289 cxt_two();
290 sub cxt_three { sort &test_if_list() }
291 cxt_three();
e9d9e6f3
FC
292 sub cxt_three_anna_half { sort 0, test_if_list() }
293 cxt_three_anna_half();
5823dc9f
MS
294
295 sub test_if_scalar {
296 my $gimme = wantarray;
297 ::is(!($gimme or !defined($gimme)),1,'wantarray 2');
298 }
f34362ee 299
5823dc9f
MS
300 $m = \&test_if_scalar;
301 sub cxt_four { sort $m 1,2 }
302 @x = cxt_four();
303 sub cxt_five { sort { test_if_scalar($a,$b); } 1,2 }
304 @x = cxt_five();
305 sub cxt_six { sort test_if_scalar 1,2 }
306 @x = cxt_six();
8e3f9bdf
GS
307}
308
8e664e10
GS
309
310# test against a reentrancy bug
311{
312 package Bar;
313 sub compare { $a cmp $b }
314 sub reenter { my @force = sort compare qw/a b/ }
315}
316{
317 my($def, $init) = (0, 0);
318 @b = sort {
319 $def = 1 if defined $Bar::a;
320 Bar::reenter() unless $init++;
321 $a <=> $b
322 } qw/4 3 1 2/;
5823dc9f 323 cmp_ok("@b",'eq','1 2 3 4','reenter 1');
f34362ee 324
5823dc9f 325 ok(!$def,'reenter 2');
8e664e10 326}
f0670693 327
f34362ee 328
f0670693
SC
329{
330 sub routine { "one", "two" };
331 @a = sort(routine(1));
5823dc9f 332 cmp_ok("@a",'eq',"one two",'bug id 19991001.003');
f0670693 333}
fe1bc4cf
DM
334
335
fe1bc4cf
DM
336# check for in-place optimisation of @a = sort @a
337{
338 my ($r1,$r2,@a);
339 our @g;
340 @g = (3,2,1); $r1 = \$g[2]; @g = sort @g; $r2 = \$g[0];
5823dc9f 341 is "$r1-@g", "$r2-1 2 3", "inplace sort of global";
fe1bc4cf
DM
342
343 @a = qw(b a c); $r1 = \$a[1]; @a = sort @a; $r2 = \$a[0];
5823dc9f 344 is "$r1-@a", "$r2-a b c", "inplace sort of lexical";
fe1bc4cf
DM
345
346 @g = (2,3,1); $r1 = \$g[1]; @g = sort { $b <=> $a } @g; $r2 = \$g[0];
5823dc9f 347 is "$r1-@g", "$r2-3 2 1", "inplace reversed sort of global";
fe1bc4cf
DM
348
349 @g = (2,3,1);
350 $r1 = \$g[1]; @g = sort { $a<$b?1:$a>$b?-1:0 } @g; $r2 = \$g[0];
5823dc9f 351 is "$r1-@g", "$r2-3 2 1", "inplace custom sort of global";
fe1bc4cf
DM
352
353 sub mysort { $b cmp $a };
354 @a = qw(b c a); $r1 = \$a[1]; @a = sort mysort @a; $r2 = \$a[0];
5823dc9f 355 is "$r1-@a", "$r2-c b a", "inplace sort with function of lexical";
fe1bc4cf
DM
356
357 use Tie::Array;
db7511db
DM
358 my @t;
359 tie @t, 'Tie::StdArray';
fe1bc4cf 360
db7511db 361 @t = qw(b c a); @t = sort @t;
5823dc9f 362 is "@t", "a b c", "inplace sort of tied array";
fe1bc4cf 363
db7511db 364 @t = qw(b c a); @t = sort mysort @t;
5823dc9f 365 is "@t", "c b a", "inplace sort of tied array with function";
db7511db
DM
366
367 # [perl #29790] don't optimise @a = ('a', sort @a) !
368
369 @g = (3,2,1); @g = ('0', sort @g);
5823dc9f 370 is "@g", "0 1 2 3", "un-inplace sort of global";
db7511db 371 @g = (3,2,1); @g = (sort(@g),'4');
5823dc9f 372 is "@g", "1 2 3 4", "un-inplace sort of global 2";
db7511db
DM
373
374 @a = qw(b a c); @a = ('x', sort @a);
5823dc9f 375 is "@a", "x a b c", "un-inplace sort of lexical";
db7511db 376 @a = qw(b a c); @a = ((sort @a), 'x');
5823dc9f 377 is "@a", "a b c x", "un-inplace sort of lexical 2";
db7511db
DM
378
379 @g = (2,3,1); @g = ('0', sort { $b <=> $a } @g);
5823dc9f 380 is "@g", "0 3 2 1", "un-inplace reversed sort of global";
db7511db 381 @g = (2,3,1); @g = ((sort { $b <=> $a } @g),'4');
5823dc9f 382 is "@g", "3 2 1 4", "un-inplace reversed sort of global 2";
db7511db
DM
383
384 @g = (2,3,1); @g = ('0', sort { $a<$b?1:$a>$b?-1:0 } @g);
5823dc9f 385 is "@g", "0 3 2 1", "un-inplace custom sort of global";
db7511db 386 @g = (2,3,1); @g = ((sort { $a<$b?1:$a>$b?-1:0 } @g),'4');
5823dc9f 387 is "@g", "3 2 1 4", "un-inplace custom sort of global 2";
db7511db
DM
388
389 @a = qw(b c a); @a = ('x', sort mysort @a);
5823dc9f 390 is "@a", "x c b a", "un-inplace sort with function of lexical";
db7511db 391 @a = qw(b c a); @a = ((sort mysort @a),'x');
5823dc9f 392 is "@a", "c b a x", "un-inplace sort with function of lexical 2";
aa6341cb
GG
393
394 # RT#54758. Git 62b40d2474e7487e6909e1872b6bccdf812c6818
8c1a9f82 395 no warnings 'void';
aa6341cb 396 my @m; push @m, 0 for 1 .. 1024; $#m; @m = sort @m;
5823dc9f 397 ::pass("in-place sorting segfault");
fe1bc4cf
DM
398}
399
eb209983
NC
400# Test optimisations of reversed sorts. As we now guarantee stability by
401# default, # optimisations which do not provide this are bogus.
fe1bc4cf 402
eb209983
NC
403{
404 package Oscalar;
405 use overload (qw("" stringify 0+ numify fallback 1));
406
407 sub new {
408 bless [$_[1], $_[2]], $_[0];
409 }
410
411 sub stringify { $_[0]->[0] }
412
413 sub numify { $_[0]->[1] }
414}
415
416sub generate {
417 my $count = 0;
418 map {new Oscalar $_, $count++} qw(A A A B B B C C C);
419}
420
421my @input = &generate;
422my @output = sort @input;
5823dc9f 423is join(" ", map {0+$_} @output), "0 1 2 3 4 5 6 7 8", "Simple stable sort";
eb209983
NC
424
425@input = &generate;
426@input = sort @input;
5823dc9f 427is join(" ", map {0+$_} @input), "0 1 2 3 4 5 6 7 8",
eb209983
NC
428 "Simple stable in place sort";
429
430# This won't be very interesting
431@input = &generate;
432@output = sort {$a <=> $b} @input;
5823dc9f 433is "@output", "A A A B B B C C C", 'stable $a <=> $b sort';
eb209983
NC
434
435@input = &generate;
436@output = sort {$a cmp $b} @input;
5823dc9f 437is join(" ", map {0+$_} @output), "0 1 2 3 4 5 6 7 8", 'stable $a cmp $b sort';
eb209983
NC
438
439@input = &generate;
440@input = sort {$a cmp $b} @input;
5823dc9f 441is join(" ", map {0+$_} @input), "0 1 2 3 4 5 6 7 8",
eb209983
NC
442 'stable $a cmp $b in place sort';
443
444@input = &generate;
445@output = sort {$b cmp $a} @input;
5823dc9f 446is join(" ", map {0+$_} @output), "6 7 8 3 4 5 0 1 2", 'stable $b cmp $a sort';
eb209983
NC
447
448@input = &generate;
449@input = sort {$b cmp $a} @input;
5823dc9f 450is join(" ", map {0+$_} @input), "6 7 8 3 4 5 0 1 2",
eb209983
NC
451 'stable $b cmp $a in place sort';
452
75dd5fa4 453@input = &generate;
eb209983 454@output = reverse sort @input;
5823dc9f 455is join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0", "Reversed stable sort";
eb209983
NC
456
457@input = &generate;
458@input = reverse sort @input;
5823dc9f 459is join(" ", map {0+$_} @input), "8 7 6 5 4 3 2 1 0",
eb209983
NC
460 "Reversed stable in place sort";
461
75dd5fa4
NC
462@input = &generate;
463my $output = reverse sort @input;
5823dc9f 464is $output, "CCCBBBAAA", "Reversed stable sort in scalar context";
75dd5fa4 465
eb209983
NC
466
467@input = &generate;
468@output = reverse sort {$a cmp $b} @input;
5823dc9f 469is join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0",
eb209983
NC
470 'reversed stable $a cmp $b sort';
471
472@input = &generate;
473@input = reverse sort {$a cmp $b} @input;
5823dc9f 474is join(" ", map {0+$_} @input), "8 7 6 5 4 3 2 1 0",
eb209983
NC
475 'revesed stable $a cmp $b in place sort';
476
477@input = &generate;
7e7a548e 478$output = reverse sort {$a cmp $b} @input;
5823dc9f 479is $output, "CCCBBBAAA", 'Reversed stable $a cmp $b sort in scalar context';
75dd5fa4
NC
480
481@input = &generate;
eb209983 482@output = reverse sort {$b cmp $a} @input;
5823dc9f 483is join(" ", map {0+$_} @output), "2 1 0 5 4 3 8 7 6",
eb209983
NC
484 'reversed stable $b cmp $a sort';
485
486@input = &generate;
487@input = reverse sort {$b cmp $a} @input;
5823dc9f 488is join(" ", map {0+$_} @input), "2 1 0 5 4 3 8 7 6",
eb209983
NC
489 'revesed stable $b cmp $a in place sort';
490
75dd5fa4
NC
491@input = &generate;
492$output = reverse sort {$b cmp $a} @input;
5823dc9f 493is $output, "AAABBBCCC", 'Reversed stable $b cmp $a sort in scalar context';
75dd5fa4 494
7e7a548e
NC
495sub stuff {
496 # Something complex enough to defeat any constant folding optimiser
497 $$ - $$;
498}
499
500@input = &generate;
501@output = reverse sort {stuff || $a cmp $b} @input;
5823dc9f 502is join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0",
7e7a548e
NC
503 'reversed stable complex sort';
504
505@input = &generate;
506@input = reverse sort {stuff || $a cmp $b} @input;
5823dc9f 507is join(" ", map {0+$_} @input), "8 7 6 5 4 3 2 1 0",
7e7a548e
NC
508 'revesed stable complex in place sort';
509
510@input = &generate;
511$output = reverse sort {stuff || $a cmp $b } @input;
5823dc9f 512is $output, "CCCBBBAAA", 'Reversed stable complex sort in scalar context';
7e7a548e 513
a1824f2a
NC
514sub sortr {
515 reverse sort @_;
516}
517
518@output = sortr &generate;
5823dc9f 519is join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0",
a1824f2a
NC
520 'reversed stable sort return list context';
521$output = sortr &generate;
5823dc9f 522is $output, "CCCBBBAAA",
a1824f2a
NC
523 'reversed stable sort return scalar context';
524
525sub sortcmpr {
526 reverse sort {$a cmp $b} @_;
527}
528
529@output = sortcmpr &generate;
5823dc9f 530is join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0",
a1824f2a
NC
531 'reversed stable $a cmp $b sort return list context';
532$output = sortcmpr &generate;
5823dc9f 533is $output, "CCCBBBAAA",
a1824f2a
NC
534 'reversed stable $a cmp $b sort return scalar context';
535
536sub sortcmprba {
537 reverse sort {$b cmp $a} @_;
538}
539
540@output = sortcmprba &generate;
5823dc9f 541is join(" ", map {0+$_} @output), "2 1 0 5 4 3 8 7 6",
a1824f2a
NC
542 'reversed stable $b cmp $a sort return list context';
543$output = sortcmprba &generate;
5823dc9f 544is $output, "AAABBBCCC",
a1824f2a 545'reversed stable $b cmp $a sort return scalar context';
eb209983 546
7e7a548e
NC
547sub sortcmprq {
548 reverse sort {stuff || $a cmp $b} @_;
549}
550
551@output = sortcmpr &generate;
5823dc9f 552is join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0",
7e7a548e
NC
553 'reversed stable complex sort return list context';
554$output = sortcmpr &generate;
5823dc9f 555is $output, "CCCBBBAAA",
7e7a548e
NC
556 'reversed stable complex sort return scalar context';
557
eb209983
NC
558# And now with numbers
559
560sub generate1 {
561 my $count = 'A';
562 map {new Oscalar $count++, $_} 0, 0, 0, 1, 1, 1, 2, 2, 2;
563}
564
565# This won't be very interesting
566@input = &generate1;
567@output = sort {$a cmp $b} @input;
5823dc9f 568is "@output", "A B C D E F G H I", 'stable $a cmp $b sort';
eb209983
NC
569
570@input = &generate1;
571@output = sort {$a <=> $b} @input;
5823dc9f 572is "@output", "A B C D E F G H I", 'stable $a <=> $b sort';
eb209983
NC
573
574@input = &generate1;
575@input = sort {$a <=> $b} @input;
5823dc9f 576is "@input", "A B C D E F G H I", 'stable $a <=> $b in place sort';
eb209983
NC
577
578@input = &generate1;
579@output = sort {$b <=> $a} @input;
5823dc9f 580is "@output", "G H I D E F A B C", 'stable $b <=> $a sort';
eb209983
NC
581
582@input = &generate1;
583@input = sort {$b <=> $a} @input;
5823dc9f 584is "@input", "G H I D E F A B C", 'stable $b <=> $a in place sort';
eb209983 585
59608b94
DN
586# test that optimized {$b cmp $a} and {$b <=> $a} remain stable
587# (new in 5.9) without overloading
588{ no warnings;
589@b = sort { $b <=> $a } @input = qw/5first 6first 5second 6second/;
5823dc9f 590is "@b" , "6first 6second 5first 5second", "optimized {$b <=> $a} without overloading" ;
59608b94 591@input = sort {$b <=> $a} @input;
5823dc9f 592is "@input" , "6first 6second 5first 5second","inline optimized {$b <=> $a} without overloading" ;
59608b94
DN
593};
594
eb209983 595# These two are actually doing string cmp on 0 1 and 2
75dd5fa4 596@input = &generate1;
eb209983 597@output = reverse sort @input;
5823dc9f 598is "@output", "I H G F E D C B A", "Reversed stable sort";
eb209983
NC
599
600@input = &generate1;
601@input = reverse sort @input;
5823dc9f 602is "@input", "I H G F E D C B A", "Reversed stable in place sort";
eb209983
NC
603
604@input = &generate1;
75dd5fa4 605$output = reverse sort @input;
5823dc9f 606is $output, "IHGFEDCBA", "Reversed stable sort in scalar context";
75dd5fa4
NC
607
608@input = &generate1;
eb209983 609@output = reverse sort {$a <=> $b} @input;
5823dc9f 610is "@output", "I H G F E D C B A", 'reversed stable $a <=> $b sort';
eb209983
NC
611
612@input = &generate1;
613@input = reverse sort {$a <=> $b} @input;
5823dc9f 614is "@input", "I H G F E D C B A", 'revesed stable $a <=> $b in place sort';
fe1bc4cf 615
eb209983 616@input = &generate1;
75dd5fa4 617$output = reverse sort {$a <=> $b} @input;
5823dc9f 618is $output, "IHGFEDCBA", 'reversed stable $a <=> $b sort in scalar context';
75dd5fa4
NC
619
620@input = &generate1;
eb209983 621@output = reverse sort {$b <=> $a} @input;
5823dc9f 622is "@output", "C B A F E D I H G", 'reversed stable $b <=> $a sort';
fe1bc4cf 623
eb209983
NC
624@input = &generate1;
625@input = reverse sort {$b <=> $a} @input;
5823dc9f 626is "@input", "C B A F E D I H G", 'revesed stable $b <=> $a in place sort';
75dd5fa4
NC
627
628@input = &generate1;
629$output = reverse sort {$b <=> $a} @input;
5823dc9f 630is $output, "CBAFEDIHG", 'reversed stable $b <=> $a sort in scalar context';
a1824f2a 631
7e7a548e
NC
632@input = &generate1;
633@output = reverse sort {stuff || $a <=> $b} @input;
5823dc9f 634is "@output", "I H G F E D C B A", 'reversed stable complex sort';
7e7a548e
NC
635
636@input = &generate1;
637@input = reverse sort {stuff || $a <=> $b} @input;
5823dc9f 638is "@input", "I H G F E D C B A", 'revesed stable complex in place sort';
7e7a548e
NC
639
640@input = &generate1;
641$output = reverse sort {stuff || $a <=> $b} @input;
5823dc9f 642is $output, "IHGFEDCBA", 'reversed stable complex sort in scalar context';
a1824f2a
NC
643
644sub sortnumr {
645 reverse sort {$a <=> $b} @_;
646}
647
648@output = sortnumr &generate1;
5823dc9f 649is "@output", "I H G F E D C B A",
a1824f2a
NC
650 'reversed stable $a <=> $b sort return list context';
651$output = sortnumr &generate1;
5823dc9f 652is $output, "IHGFEDCBA", 'reversed stable $a <=> $b sort return scalar context';
a1824f2a
NC
653
654sub sortnumrba {
655 reverse sort {$b <=> $a} @_;
656}
657
658@output = sortnumrba &generate1;
5823dc9f 659is "@output", "C B A F E D I H G",
a1824f2a
NC
660 'reversed stable $b <=> $a sort return list context';
661$output = sortnumrba &generate1;
5823dc9f 662is $output, "CBAFEDIHG", 'reversed stable $b <=> $a sort return scalar context';
7e7a548e
NC
663
664sub sortnumrq {
665 reverse sort {stuff || $a <=> $b} @_;
666}
667
668@output = sortnumrq &generate1;
5823dc9f 669is "@output", "I H G F E D C B A",
7e7a548e
NC
670 'reversed stable complex sort return list context';
671$output = sortnumrq &generate1;
5823dc9f 672is $output, "IHGFEDCBA", 'reversed stable complex sort return scalar context';
c093edd0
NC
673
674@output = reverse (sort(qw(C A B)), 0);
5823dc9f 675is "@output", "0 C B A", 'reversed sort with trailing argument';
c093edd0
NC
676
677@output = reverse (0, sort(qw(C A B)));
5823dc9f 678is "@output", "C B A 0", 'reversed sort with leading argument';
9850bf21
RH
679
680eval { @output = sort {goto sub {}} 1,2; };
f34362ee 681$fail_msg = q(Can't goto subroutine outside a subroutine);
5823dc9f 682cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'goto subr outside subr');
f34362ee
DL
683
684
9850bf21
RH
685
686sub goto_sub {goto sub{}}
687eval { @output = sort goto_sub 1,2; };
f34362ee 688$fail_msg = q(Can't goto subroutine from a sort sub);
5823dc9f 689cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'goto subr from a sort sub');
f34362ee
DL
690
691
9850bf21
RH
692
693eval { @output = sort {goto label} 1,2; };
f34362ee 694$fail_msg = q(Can't "goto" out of a pseudo block);
5823dc9f 695cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'goto out of a pseudo block 1');
f34362ee
DL
696
697
9850bf21
RH
698
699sub goto_label {goto label}
700label: eval { @output = sort goto_label 1,2; };
f34362ee 701$fail_msg = q(Can't "goto" out of a pseudo block);
5823dc9f 702cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'goto out of a pseudo block 2');
f34362ee
DL
703
704
9850bf21
RH
705
706sub self_immolate {undef &self_immolate; $a<=>$b}
707eval { @output = sort self_immolate 1,2,3 };
f34362ee 708$fail_msg = q(Can't undef active subroutine);
5823dc9f 709cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'undef active subr');
f34362ee
DL
710
711
8a27a13e
FC
712for(1,2) # We run this twice, to make sure sort does not lower the ref
713{ # count. See bug 71076.
9850bf21
RH
714 my $failed = 0;
715
716 sub rec {
717 my $n = shift;
718 if (!defined($n)) { # No arg means we're being called by sort()
719 return 1;
720 }
721 if ($n<5) { rec($n+1); }
722 else { () = sort rec 1,2; }
723
724 $failed = 1 if !defined $n;
725 }
726
727 rec(1);
5823dc9f 728 ok(!$failed, "sort from active sub");
9850bf21
RH
729}
730
731# $a and $b are set in the package the sort() is called from,
732# *not* the package the sort sub is in. This is longstanding
733# de facto behaviour that shouldn't be broken.
f34362ee 734my $answer = "good";
9850bf21
RH
735() = sort OtherPack::foo 1,2,3,4;
736
9da9462b
RGS
737{
738 package OtherPack;
739 no warnings 'once';
740 sub foo {
f34362ee 741 $answer = "something was unexpectedly defined or undefined" if
9da9462b
RGS
742 defined($a) || defined($b) || !defined($main::a) || !defined($main::b);
743 $main::a <=> $main::b;
744 }
745}
9850bf21 746
5823dc9f 747cmp_ok($answer,'eq','good','sort subr called from other package');
9850bf21
RH
748
749
750# Bug 36430 - sort called in package2 while a
751# sort in package1 is active should set $package2::a/b.
5823dc9f
MS
752{
753 my $answer = "good";
754 my @list = sort { A::min(@$a) <=> A::min(@$b) }
755 [3, 1, 5], [2, 4], [0];
756
757 cmp_ok($answer,'eq','good','bug 36430');
758
759 package A;
760 sub min {
761 my @list = sort {
762 $answer = '$a and/or $b are not defined ' if !defined($a) || !defined($b);
763 $a <=> $b;
764 } @_;
765 $list[0];
766 }
9850bf21
RH
767}
768
5823dc9f 769
9850bf21
RH
770# Bug 7567 - an array shouldn't be modifiable while it's being
771# sorted in-place.
5823dc9f
MS
772{
773 eval { @a=(1..8); @a = sort { @a = (0) } @a; };
f34362ee 774
5823dc9f
MS
775 $fail_msg = q(Modification of a read-only value attempted);
776 cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'bug 7567');
20d5dc23
FC
777 eval { @a=1..3 };
778 is $@, "", 'abrupt scope exit turns off readonliness';
5823dc9f 779}
f34362ee 780
84df657f
GG
781{
782 local $TODO = "sort should make sure elements are not freed in the sort block";
39984de3
FC
783 eval { @nomodify_x=(1..8);
784 our @copy = sort { undef @nomodify_x; 1 } (@nomodify_x, 3); };
84df657f
GG
785 is($@, "");
786}
787
9850bf21
RH
788
789# Sorting shouldn't increase the refcount of a sub
5823dc9f 790{
7f4622ec
RGS
791 sub sportello {(1+$a) <=> (1+$b)}
792 my $refcnt = &Internals::SvREFCNT(\&sportello);
793 @output = sort sportello 3,7,9;
5823dc9f
MS
794
795 {
7f4622ec
RGS
796 package Doc;
797 ::is($refcnt, &Internals::SvREFCNT(\&::sportello), "sort sub refcnt");
5823dc9f
MS
798 $fail_msg = q(Modification of a read-only value attempted);
799 # Sorting a read-only array in-place shouldn't be allowed
800 my @readonly = (1..10);
801 Internals::SvREADONLY(@readonly, 1);
802 eval { @readonly = sort @readonly; };
803 ::cmp_ok(substr($@,0,length($fail_msg)),'eq',$fail_msg,'in-place sort of read-only array');
804 }
805}
f34362ee 806
9850bf21
RH
807
808# Using return() should be okay even in a deeper context
809@b = sort {while (1) {return ($a <=> $b)} } 1..10;
5823dc9f 810is("@b", "1 2 3 4 5 6 7 8 9 10", "return within loop");
d7507f74
RH
811
812# Using return() should be okay even if there are other items
813# on the stack at the time.
814@b = sort {$_ = ($a<=>$b) + do{return $b<=> $a}} 1..10;
5823dc9f 815is("@b", "10 9 8 7 6 5 4 3 2 1", "return with SVs on stack");
d7507f74
RH
816
817# As above, but with a sort sub rather than a sort block.
818sub ret_with_stacked { $_ = ($a<=>$b) + do {return $b <=> $a} }
819@b = sort ret_with_stacked 1..10;
5823dc9f 820is("@b", "10 9 8 7 6 5 4 3 2 1", "return with SVs on stack");
93e19c0f
Z
821
822# Comparison code should be able to give result in non-integer representation.
823sub cmp_as_string($$) { $_[0] < $_[1] ? "-1" : $_[0] == $_[1] ? "0" : "+1" }
824@b = sort { cmp_as_string($a, $b) } (1,5,4,7,3,2,3);
825is("@b", "1 2 3 3 4 5 7", "comparison result as string");
826@b = sort cmp_as_string (1,5,4,7,3,2,3);
827is("@b", "1 2 3 3 4 5 7", "comparison result as string");
bdbefedf
DM
828
829# RT #34604: sort didn't honour overloading if the overloaded elements
830# were retrieved via tie
831
832{
833 package RT34604;
834
835 sub TIEHASH { bless {
836 p => bless({ val => 2 }),
837 q => bless({ val => 1 }),
838 }
839 }
840 sub FETCH { $_[0]{$_[1] } }
841
842 my $cc = 0;
843 sub compare { $cc++; $_[0]{val} cmp $_[1]{val} }
844 my $cs = 0;
845 sub str { $cs++; $_[0]{val} }
846
847 use overload 'cmp' => \&compare, '""' => \&str;
848
849 package main;
850
851 tie my %h, 'RT34604';
852 my @sorted = sort @h{qw(p q)};
853 is($cc, 1, 'overload compare called once');
854 is("@sorted","1 2", 'overload sort result');
855 is($cs, 2, 'overload string called twice');
856}
8f443ca6
GG
857
858fresh_perl_is('sub w ($$) {my ($l, my $r) = @_; my $v = \@_; undef @_; $l <=> $r}; print join q{ }, sort w 3, 1, 2, 0',
859 '0 1 2 3',
860 {stderr => 1, switches => ['-w']},
861 'RT #72334');
862
863fresh_perl_is('sub w ($$) {my ($l, my $r) = @_; my $v = \@_; undef @_; @_ = 0..2; $l <=> $r}; print join q{ }, sort w 3, 1, 2, 0',
864 '0 1 2 3',
865 {stderr => 1, switches => ['-w']},
866 'RT #72334');
133acf7b
NC
867
868{
869 my $count = 0;
870 {
871 package Counter;
872
873 sub new {
874 ++$count;
875 bless [];
876 }
877
878 sub DESTROY {
879 --$count;
880 }
881 }
882
883 sub sorter ($$) {
884 my ($l, $r) = @_;
885 my $q = \@_;
886 $l <=> $r;
887 }
888
889 is($count, 0, 'None before we start');
890 my @a = map { Counter->new() } 0..1;
891 is($count, 2, '2 here');
892
893 my @b = sort sorter @a;
894
895 is(scalar @b, 2);
896 cmp_ok($b[0], '<', $b[1], 'sorted!');
897
898 is($count, 2, 'still the same 2 here');
899
900 @a = (); @b = ();
901
902 is($count, 0, 'all gone');
903}
8e7d0c4b
FC
904
905# [perl #77930] The context stack may be reallocated during a sort, as a
906# result of deeply-nested (or not-so-deeply-nested) calls
907# from a custom sort subroutine.
908fresh_perl_is
909 '
910 $sub = sub {
911 local $count = $count+1;
912 ()->$sub if $count < 1000;
913 $a cmp $b
914 };
915 () = sort $sub qw<a b c d e f g>;
916 print "ok"
917 ',
918 'ok',
919 {},
92c404cd 920 '[perl #77930] cx_stack reallocation during sort'
8e7d0c4b 921;
ad021bfb
FC
922
923# [perl #76026]
924# Match vars should not leak from one sort sub call to the next
925{
926 my $output = '';
927 sub soarter {
928 $output .= $1;
929 "Leakage" =~ /(.*)/;
930 1
931 }
932 sub soarterdd($$) {
933 $output .= $1;
934 "Leakage" =~ /(.*)/;
935 1
936 }
937
938 "Win" =~ /(.*)/;
939 my @b = sort soarter 0..2;
940
941 like $output, qr/^(?:Win)+\z/,
942 "Match vars do not leak from one plain sort sub to the next";
943
944 $output = '';
945
946 "Win" =~ /(.*)/;
947 @b = sort soarterdd 0..2;
948
949 like $output, qr/^(?:Win)+\z/,
950 'Match vars do not leak from one $$ sort sub to the next';
951}
f7bc00ea
FC
952
953# [perl #30661] autoloading
954AUTOLOAD { $b <=> $a }
955sub stubbedsub;
956is join("", sort stubbedsub split//, '04381091'), '98431100',
957 'stubborn AUTOLOAD';
958is join("", sort hopefullynonexistent split//, '04381091'), '98431100',
959 'AUTOLOAD without stub';
960my $stubref = \&givemeastub;
961is join("", sort $stubref split//, '04381091'), '98431100',
962 'AUTOLOAD with stubref';
a46b39a8
FC
963
964# [perl #90030] sort without arguments
5d4b936e 965eval '@x = (sort); 1';
a46b39a8
FC
966is $@, '', '(sort) does not die';
967is @x, 0, '(sort) returns empty list';
5d4b936e 968eval '@x = sort; 1';
a46b39a8
FC
969is $@, '', 'sort; does not die';
970is @x, 0, 'sort; returns empty list';
971eval '{@x = sort} 1';
972is $@, '', '{sort} does not die';
973is @x, 0, '{sort} returns empty list';
a7fd8ef6
DM
974
975# this happened while the padrange op was being added. Sort blocks
976# are executed in void context, and the padrange op was skipping pushing
977# the item in void cx. The net result was that the return value was
978# whatever was on the stack last.
979
980{
981 my @a = sort {
982 my $r = $a <=> $b;
983 if ($r) {
984 undef; # this got returned by mistake
985 return $r
986 }
987 return 0;
988 } 5,1,3,6,0;
989 is "@a", "0 1 3 5 6", "padrange and void context";
990}
2f43ddf1
FC
991
992# Fatal warnings an sort sub returning a non-number
993# We need two evals, because the panic used to happen on scope exit.
994eval { eval { use warnings FATAL => 'all'; () = sort { undef } 1,2 } };
995is $@, "",
996 'no panic/crash with fatal warnings when sort sub returns undef';
997eval { eval { use warnings FATAL => 'all'; () = sort { "no thin" } 1,2 } };
998is $@, "",
999 'no panic/crash with fatal warnings when sort sub returns string';
1000sub notdef($$) { undef }
1001eval { eval { use warnings FATAL => 'all'; () = sort notdef 1,2 } };
1002is $@, "",
1003 'no panic/crash with fatal warnings when sort sub($$) returns undef';
1004sub yarn($$) { "no thinking aloud" }
1005eval { eval { use warnings FATAL => 'all'; () = sort yarn 1,2 } };
1006is $@, "",
1007 'no panic/crash with fatal warnings when sort sub($$) returns string';
f65493df
FC
1008
1009$#a = -1;
1010() = [sort { $a = 10; $b = 10; 0 } $#a, $#a];
1011is $#a, 10, 'sort block modifying $a and $b';
2d885586 1012
2d885586
FC
1013() = sort {
1014 is \$a, \$a, '[perl #78194] op return values passed to sort'; 0
1015} "${\''}", "${\''}";
8465ba45
FC
1016
1017package deletions {
1018 @_=sort { delete $deletions::{a}; delete $deletions::{b}; 3 } 1..3;
1019}
1020pass "no crash when sort block deletes *a and *b";