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