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, $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, $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 }