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