ext/B/t/f_sort.t

   1 #!perl
   2
   3 BEGIN {
   4     if ($ENV{PERL_CORE}){
   5         chdir('t') if -d 't';
   6         @INC = ('.', '../lib', '../ext/B/t');
   7     } else {
   8         unshift @INC, 't';
   9         push @INC, "../../t";
  10     }
  11     require Config;
  12     if (($Config::Config{'extensions'} !~ /\bB\b/) ){
  13         print "1..0 # Skip -- Perl configured without B module\n";
  14         exit 0;
  15     }
  16     if (!$Config::Config{useperlio}) {
  17         print "1..0 # Skip -- need perlio to walk the optree\n";
  18         exit 0;
  19     }
  20     # require q(test.pl); # now done by OptreeCheck;
  21 }
  22 use OptreeCheck;
  23 plan tests => 20;
  24
  25 =head1 f_sort.t
  26
  27 Code test snippets here are adapted from `perldoc -f map`
  28
  29 Due to a bleadperl optimization (Dave Mitchell, circa apr 04), the
  30 (map|grep)(start|while) opcodes have different flags in 5.9, their
  31 private flags /1, /2 are gone in blead (for the cases covered)
  32
  33 When the optree stuff was integrated into 5.8.6, these tests failed,
  34 and were todo'd.  Theyre now done, by version-specific tweaking in
  35 mkCheckRex(), therefore the skip is removed too.
  36
  37 =head1 Test Notes
  38
  39 # chunk: #!perl
  40 #examples poached from perldoc -f sort
  41
  42 NOTE: name is no longer a required arg for checkOptree, as label is
  43 synthesized out of others.  HOWEVER, if the test-code has newlines in
  44 it, the label must be overridden by an explicit name.
  45
  46 This is because t/TEST is quite particular about the test output it
  47 processes, and multi-line labels violate its 1-line-per-test
  48 expectations.
  49
  50 =for gentest
  51
  52 # chunk: # sort lexically
  53 @articles = sort @files;
  54
  55 =cut
  56
  57 checkOptree(note   => q{},
  58             bcopts => q{-exec},
  59             code   => q{@articles = sort @files; },
  60             expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
  61 # 1  <;> nextstate(main 545 (eval 15):1) v
  62 # 2  <0> pushmark s
  63 # 3  <0> pushmark s
  64 # 4  <#> gv[*files] s
  65 # 5  <1> rv2av[t4] lK/1
  66 # 6  <@> sort lK
  67 # 7  <0> pushmark s
  68 # 8  <#> gv[*articles] s
  69 # 9  <1> rv2av[t2] lKRM*/1
  70 # a  <2> aassign[t5] KS/COMMON
  71 # b  <1> leavesub[1 ref] K/REFC,1
  72 EOT_EOT
  73 # 1  <;> nextstate(main 545 (eval 15):1) v
  74 # 2  <0> pushmark s
  75 # 3  <0> pushmark s
  76 # 4  <$> gv(*files) s
  77 # 5  <1> rv2av[t2] lK/1
  78 # 6  <@> sort lK
  79 # 7  <0> pushmark s
  80 # 8  <$> gv(*articles) s
  81 # 9  <1> rv2av[t1] lKRM*/1
  82 # a  <2> aassign[t3] KS/COMMON
  83 # b  <1> leavesub[1 ref] K/REFC,1
  84 EONT_EONT
  85
  86
  87 =for gentest
  88
  89 # chunk: # same thing, but with explicit sort routine
  90 @articles = sort {$a cmp $b} @files;
  91
  92 =cut
  93
  94 checkOptree(note   => q{},
  95             bcopts => q{-exec},
  96             code   => q{@articles = sort {$a cmp $b} @files; },
  97             expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
  98 # 1  <;> nextstate(main 546 (eval 15):1) v
  99 # 2  <0> pushmark s
 100 # 3  <0> pushmark s
 101 # 4  <#> gv[*files] s
 102 # 5  <1> rv2av[t7] lK/1
 103 # 6  <@> sort lK
 104 # 7  <0> pushmark s
 105 # 8  <#> gv[*articles] s
 106 # 9  <1> rv2av[t2] lKRM*/1
 107 # a  <2> aassign[t3] KS/COMMON
 108 # b  <1> leavesub[1 ref] K/REFC,1
 109 EOT_EOT
 110 # 1  <;> nextstate(main 546 (eval 15):1) v
 111 # 2  <0> pushmark s
 112 # 3  <0> pushmark s
 113 # 4  <$> gv(*files) s
 114 # 5  <1> rv2av[t3] lK/1
 115 # 6  <@> sort lK
 116 # 7  <0> pushmark s
 117 # 8  <$> gv(*articles) s
 118 # 9  <1> rv2av[t1] lKRM*/1
 119 # a  <2> aassign[t2] KS/COMMON
 120 # b  <1> leavesub[1 ref] K/REFC,1
 121 EONT_EONT
 122
 123
 124 =for gentest
 125
 126 # chunk: # now case-insensitively
 127 @articles = sort {uc($a) cmp uc($b)} @files;
 128
 129 =cut
 130
 131 checkOptree(note   => q{},
 132             bcopts => q{-exec},
 133             code   => q{@articles = sort {uc($a) cmp uc($b)} @files; },
 134             expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 135 # 1  <;> nextstate(main 546 (eval 15):1) v
 136 # 2  <0> pushmark s
 137 # 3  <0> pushmark s
 138 # 4  <#> gv[*files] s
 139 # 5  <1> rv2av[t9] lK/1
 140 # 6  <@> sort lKS*
 141 # 7  <0> pushmark s
 142 # 8  <#> gv[*articles] s
 143 # 9  <1> rv2av[t2] lKRM*/1
 144 # a  <2> aassign[t10] KS/COMMON
 145 # b  <1> leavesub[1 ref] K/REFC,1
 146 EOT_EOT
 147 # 1  <;> nextstate(main 546 (eval 15):1) v
 148 # 2  <0> pushmark s
 149 # 3  <0> pushmark s
 150 # 4  <$> gv(*files) s
 151 # 5  <1> rv2av[t5] lK/1
 152 # 6  <@> sort lKS*
 153 # 7  <0> pushmark s
 154 # 8  <$> gv(*articles) s
 155 # 9  <1> rv2av[t1] lKRM*/1
 156 # a  <2> aassign[t6] KS/COMMON
 157 # b  <1> leavesub[1 ref] K/REFC,1
 158 EONT_EONT
 159
 160
 161 =for gentest
 162
 163 # chunk: # same thing in reversed order
 164 @articles = sort {$b cmp $a} @files;
 165
 166 =cut
 167
 168 checkOptree(note   => q{},
 169             bcopts => q{-exec},
 170             code   => q{@articles = sort {$b cmp $a} @files; },
 171             expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 172 # 1  <;> nextstate(main 546 (eval 15):1) v
 173 # 2  <0> pushmark s
 174 # 3  <0> pushmark s
 175 # 4  <#> gv[*files] s
 176 # 5  <1> rv2av[t7] lK/1
 177 # 6  <@> sort lK/DESC
 178 # 7  <0> pushmark s
 179 # 8  <#> gv[*articles] s
 180 # 9  <1> rv2av[t2] lKRM*/1
 181 # a  <2> aassign[t3] KS/COMMON
 182 # b  <1> leavesub[1 ref] K/REFC,1
 183 EOT_EOT
 184 # 1  <;> nextstate(main 546 (eval 15):1) v
 185 # 2  <0> pushmark s
 186 # 3  <0> pushmark s
 187 # 4  <$> gv(*files) s
 188 # 5  <1> rv2av[t3] lK/1
 189 # 6  <@> sort lK/DESC
 190 # 7  <0> pushmark s
 191 # 8  <$> gv(*articles) s
 192 # 9  <1> rv2av[t1] lKRM*/1
 193 # a  <2> aassign[t2] KS/COMMON
 194 # b  <1> leavesub[1 ref] K/REFC,1
 195 EONT_EONT
 196
 197
 198 =for gentest
 199
 200 # chunk: # sort numerically ascending
 201 @articles = sort {$a <=> $b} @files;
 202
 203 =cut
 204
 205 checkOptree(note   => q{},
 206             bcopts => q{-exec},
 207             code   => q{@articles = sort {$a <=> $b} @files; },
 208             expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 209 # 1  <;> nextstate(main 546 (eval 15):1) v
 210 # 2  <0> pushmark s
 211 # 3  <0> pushmark s
 212 # 4  <#> gv[*files] s
 213 # 5  <1> rv2av[t7] lK/1
 214 # 6  <@> sort lK/NUM
 215 # 7  <0> pushmark s
 216 # 8  <#> gv[*articles] s
 217 # 9  <1> rv2av[t2] lKRM*/1
 218 # a  <2> aassign[t3] KS/COMMON
 219 # b  <1> leavesub[1 ref] K/REFC,1
 220 EOT_EOT
 221 # 1  <;> nextstate(main 546 (eval 15):1) v
 222 # 2  <0> pushmark s
 223 # 3  <0> pushmark s
 224 # 4  <$> gv(*files) s
 225 # 5  <1> rv2av[t3] lK/1
 226 # 6  <@> sort lK/NUM
 227 # 7  <0> pushmark s
 228 # 8  <$> gv(*articles) s
 229 # 9  <1> rv2av[t1] lKRM*/1
 230 # a  <2> aassign[t2] KS/COMMON
 231 # b  <1> leavesub[1 ref] K/REFC,1
 232 EONT_EONT
 233
 234
 235 =for gentest
 236
 237 # chunk: # sort numerically descending
 238 @articles = sort {$b <=> $a} @files;
 239
 240 =cut
 241
 242 checkOptree(note   => q{},
 243             bcopts => q{-exec},
 244             code   => q{@articles = sort {$b <=> $a} @files; },
 245             expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 246 # 1  <;> nextstate(main 587 (eval 26):1) v
 247 # 2  <0> pushmark s
 248 # 3  <0> pushmark s
 249 # 4  <#> gv[*files] s
 250 # 5  <1> rv2av[t7] lK/1
 251 # 6  <@> sort lK/DESC,NUM
 252 # 7  <0> pushmark s
 253 # 8  <#> gv[*articles] s
 254 # 9  <1> rv2av[t2] lKRM*/1
 255 # a  <2> aassign[t3] KS/COMMON
 256 # b  <1> leavesub[1 ref] K/REFC,1
 257 EOT_EOT
 258 # 1  <;> nextstate(main 546 (eval 15):1) v
 259 # 2  <0> pushmark s
 260 # 3  <0> pushmark s
 261 # 4  <$> gv(*files) s
 262 # 5  <1> rv2av[t3] lK/1
 263 # 6  <@> sort lK/DESC,NUM
 264 # 7  <0> pushmark s
 265 # 8  <$> gv(*articles) s
 266 # 9  <1> rv2av[t1] lKRM*/1
 267 # a  <2> aassign[t2] KS/COMMON
 268 # b  <1> leavesub[1 ref] K/REFC,1
 269 EONT_EONT
 270
 271
 272 =for gentest
 273
 274 # chunk: # this sorts the %age hash by value instead of key
 275 # using an in-line function
 276 @eldest = sort { $age{$b} <=> $age{$a} } keys %age;
 277
 278 =cut
 279
 280 checkOptree(note   => q{},
 281             bcopts => q{-exec},
 282             code   => q{@eldest = sort { $age{$b} <=> $age{$a} } keys %age; },
 283             expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 284 # 1  <;> nextstate(main 592 (eval 28):1) v
 285 # 2  <0> pushmark s
 286 # 3  <0> pushmark s
 287 # 4  <#> gv[*age] s
 288 # 5  <1> rv2hv[t9] lKRM/1
 289 # 6  <1> keys[t10] lK/1
 290 # 7  <@> sort lKS*
 291 # 8  <0> pushmark s
 292 # 9  <#> gv[*eldest] s
 293 # a  <1> rv2av[t2] lKRM*/1
 294 # b  <2> aassign[t11] KS/COMMON
 295 # c  <1> leavesub[1 ref] K/REFC,1
 296 EOT_EOT
 297 # 1  <;> nextstate(main 546 (eval 15):1) v
 298 # 2  <0> pushmark s
 299 # 3  <0> pushmark s
 300 # 4  <$> gv(*age) s
 301 # 5  <1> rv2hv[t3] lKRM/1
 302 # 6  <1> keys[t4] lK/1
 303 # 7  <@> sort lKS*
 304 # 8  <0> pushmark s
 305 # 9  <$> gv(*eldest) s
 306 # a  <1> rv2av[t1] lKRM*/1
 307 # b  <2> aassign[t5] KS/COMMON
 308 # c  <1> leavesub[1 ref] K/REFC,1
 309 EONT_EONT
 310
 311
 312 =for gentest
 313
 314 # chunk: # sort using explicit subroutine name
 315 sub byage {
 316     $age{$a} <=> $age{$b};  # presuming numeric
 317 }
 318 @sortedclass = sort byage @class;
 319
 320 =cut
 321
 322 checkOptree(note   => q{},
 323             bcopts => q{-exec},
 324             code   => q{sub byage { $age{$a} <=> $age{$b}; } @sortedclass = sort byage @class; },
 325             expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 326 # 1  <;> nextstate(main 597 (eval 30):1) v
 327 # 2  <0> pushmark s
 328 # 3  <0> pushmark s
 329 # 4  <$> const[PV "byage"] s/BARE
 330 # 5  <#> gv[*class] s
 331 # 6  <1> rv2av[t4] lK/1
 332 # 7  <@> sort lKS
 333 # 8  <0> pushmark s
 334 # 9  <#> gv[*sortedclass] s
 335 # a  <1> rv2av[t2] lKRM*/1
 336 # b  <2> aassign[t5] KS/COMMON
 337 # c  <1> leavesub[1 ref] K/REFC,1
 338 EOT_EOT
 339 # 1  <;> nextstate(main 546 (eval 15):1) v
 340 # 2  <0> pushmark s
 341 # 3  <0> pushmark s
 342 # 4  <$> const(PV "byage") s/BARE
 343 # 5  <$> gv(*class) s
 344 # 6  <1> rv2av[t2] lK/1
 345 # 7  <@> sort lKS
 346 # 8  <0> pushmark s
 347 # 9  <$> gv(*sortedclass) s
 348 # a  <1> rv2av[t1] lKRM*/1
 349 # b  <2> aassign[t3] KS/COMMON
 350 # c  <1> leavesub[1 ref] K/REFC,1
 351 EONT_EONT
 352
 353
 354 =for gentest
 355
 356 # chunk: sub backwards { $b cmp $a }
 357 @harry  = qw(dog cat x Cain Abel);
 358 @george = qw(gone chased yz Punished Axed);
 359 print sort @harry;
 360 # prints AbelCaincatdogx
 361 print sort backwards @harry;
 362 # prints xdogcatCainAbel
 363 print sort @george, 'to', @harry;
 364 # prints AbelAxedCainPunishedcatchaseddoggonetoxyz
 365
 366 =cut
 367
 368 checkOptree(name   => q{sort USERSUB LIST },
 369             bcopts => q{-exec},
 370             code   => q{sub backwards { $b cmp $a }
 371                         @harry = qw(dog cat x Cain Abel);
 372                         @george = qw(gone chased yz Punished Axed);
 373                         print sort @harry; print sort backwards @harry;
 374                         print sort @george, 'to', @harry; },
 375             expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 376 # 1  <;> nextstate(main 602 (eval 32):2) v
 377 # 2  <0> pushmark s
 378 # 3  <$> const[PV "dog"] s
 379 # 4  <$> const[PV "cat"] s
 380 # 5  <$> const[PV "x"] s
 381 # 6  <$> const[PV "Cain"] s
 382 # 7  <$> const[PV "Abel"] s
 383 # 8  <0> pushmark s
 384 # 9  <#> gv[*harry] s
 385 # a  <1> rv2av[t2] lKRM*/1
 386 # b  <2> aassign[t3] vKS
 387 # c  <;> nextstate(main 602 (eval 32):3) v
 388 # d  <0> pushmark s
 389 # e  <$> const[PV "gone"] s
 390 # f  <$> const[PV "chased"] s
 391 # g  <$> const[PV "yz"] s
 392 # h  <$> const[PV "Punished"] s
 393 # i  <$> const[PV "Axed"] s
 394 # j  <0> pushmark s
 395 # k  <#> gv[*george] s
 396 # l  <1> rv2av[t5] lKRM*/1
 397 # m  <2> aassign[t6] vKS
 398 # n  <;> nextstate(main 602 (eval 32):4) v:{
 399 # o  <0> pushmark s
 400 # p  <0> pushmark s
 401 # q  <#> gv[*harry] s
 402 # r  <1> rv2av[t8] lK/1
 403 # s  <@> sort lK
 404 # t  <@> print vK
 405 # u  <;> nextstate(main 602 (eval 32):4) v:{
 406 # v  <0> pushmark s
 407 # w  <0> pushmark s
 408 # x  <$> const[PV "backwards"] s/BARE
 409 # y  <#> gv[*harry] s
 410 # z  <1> rv2av[t10] lK/1
 411 # 10 <@> sort lKS
 412 # 11 <@> print vK
 413 # 12 <;> nextstate(main 602 (eval 32):5) v:{
 414 # 13 <0> pushmark s
 415 # 14 <0> pushmark s
 416 # 15 <#> gv[*george] s
 417 # 16 <1> rv2av[t12] lK/1
 418 # 17 <$> const[PV "to"] s
 419 # 18 <#> gv[*harry] s
 420 # 19 <1> rv2av[t14] lK/1
 421 # 1a <@> sort lK
 422 # 1b <@> print sK
 423 # 1c <1> leavesub[1 ref] K/REFC,1
 424 EOT_EOT
 425 # 1  <;> nextstate(main 602 (eval 32):2) v
 426 # 2  <0> pushmark s
 427 # 3  <$> const(PV "dog") s
 428 # 4  <$> const(PV "cat") s
 429 # 5  <$> const(PV "x") s
 430 # 6  <$> const(PV "Cain") s
 431 # 7  <$> const(PV "Abel") s
 432 # 8  <0> pushmark s
 433 # 9  <$> gv(*harry) s
 434 # a  <1> rv2av[t1] lKRM*/1
 435 # b  <2> aassign[t2] vKS
 436 # c  <;> nextstate(main 602 (eval 32):3) v
 437 # d  <0> pushmark s
 438 # e  <$> const(PV "gone") s
 439 # f  <$> const(PV "chased") s
 440 # g  <$> const(PV "yz") s
 441 # h  <$> const(PV "Punished") s
 442 # i  <$> const(PV "Axed") s
 443 # j  <0> pushmark s
 444 # k  <$> gv(*george) s
 445 # l  <1> rv2av[t3] lKRM*/1
 446 # m  <2> aassign[t4] vKS
 447 # n  <;> nextstate(main 602 (eval 32):4) v:{
 448 # o  <0> pushmark s
 449 # p  <0> pushmark s
 450 # q  <$> gv(*harry) s
 451 # r  <1> rv2av[t5] lK/1
 452 # s  <@> sort lK
 453 # t  <@> print vK
 454 # u  <;> nextstate(main 602 (eval 32):4) v:{
 455 # v  <0> pushmark s
 456 # w  <0> pushmark s
 457 # x  <$> const(PV "backwards") s/BARE
 458 # y  <$> gv(*harry) s
 459 # z  <1> rv2av[t6] lK/1
 460 # 10 <@> sort lKS
 461 # 11 <@> print vK
 462 # 12 <;> nextstate(main 602 (eval 32):5) v:{
 463 # 13 <0> pushmark s
 464 # 14 <0> pushmark s
 465 # 15 <$> gv(*george) s
 466 # 16 <1> rv2av[t7] lK/1
 467 # 17 <$> const(PV "to") s
 468 # 18 <$> gv(*harry) s
 469 # 19 <1> rv2av[t8] lK/1
 470 # 1a <@> sort lK
 471 # 1b <@> print sK
 472 # 1c <1> leavesub[1 ref] K/REFC,1
 473 EONT_EONT
 474
 475
 476 =for gentest
 477
 478 # chunk: # inefficiently sort by descending numeric compare using
 479 # the first integer after the first = sign, or the
 480 # whole record case-insensitively otherwise
 481 @new = @old[ sort {
 482     $nums[$b] <=> $nums[$a]
 483         || $caps[$a] cmp $caps[$b]
 484         } 0..$#old  ];
 485
 486 =cut
 487 =for gentest
 488
 489 # chunk: # same thing, but without any temps
 490 @new = map { $_->[0] }
 491 sort { $b->[1] <=> $a->[1]
 492            || $a->[2] cmp $b->[2]
 493            } map { [$_, /=(\d+)/, uc($_)] } @old;
 494
 495 =cut
 496
 497 checkOptree(name   => q{Compound sort/map Expression },
 498             bcopts => q{-exec},
 499             code   => q{ @new = map { $_->[0] }
 500                          sort { $b->[1] <=> $a->[1] || $a->[2] cmp $b->[2] }
 501                          map { [$_, /=(\d+)/, uc($_)] } @old; },
 502             expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 503 # 1  <;> nextstate(main 609 (eval 34):3) v:{
 504 # 2  <0> pushmark s
 505 # 3  <0> pushmark s
 506 # 4  <0> pushmark s
 507 # 5  <0> pushmark s
 508 # 6  <#> gv[*old] s
 509 # 7  <1> rv2av[t19] lKM/1
 510 # 8  <@> mapstart lK*
 511 # 9  <|> mapwhile(other->a)[t20] lK
 512 # a      <0> enter l
 513 # b      <;> nextstate(main 608 (eval 34):2) v:{
 514 # c      <0> pushmark s
 515 # d      <#> gvsv[*_] s
 516 # e      </> match(/"=(\\d+)"/) l/RTIME
 517 # f      <#> gvsv[*_] s
 518 # g      <1> uc[t17] sK/1
 519 # h      <@> anonlist sK*/1
 520 # i      <@> leave lKP
 521 #            goto 9
 522 # j  <@> sort lKMS*
 523 # k  <@> mapstart lK*
 524 # l  <|> mapwhile(other->m)[t26] lK
 525 # m      <#> gv[*_] s
 526 # n      <1> rv2sv sKM/DREFAV,1
 527 # o      <1> rv2av[t4] sKR/1
 528 # p      <$> const[IV 0] s
 529 # q      <2> aelem sK/2
 530 # -      <@> scope lK
 531 #            goto l
 532 # r  <0> pushmark s
 533 # s  <#> gv[*new] s
 534 # t  <1> rv2av[t2] lKRM*/1
 535 # u  <2> aassign[t27] KS/COMMON
 536 # v  <1> leavesub[1 ref] K/REFC,1
 537 EOT_EOT
 538 # 1  <;> nextstate(main 609 (eval 34):3) v:{
 539 # 2  <0> pushmark s
 540 # 3  <0> pushmark s
 541 # 4  <0> pushmark s
 542 # 5  <0> pushmark s
 543 # 6  <$> gv(*old) s
 544 # 7  <1> rv2av[t10] lKM/1
 545 # 8  <@> mapstart lK*
 546 # 9  <|> mapwhile(other->a)[t11] lK
 547 # a      <0> enter l
 548 # b      <;> nextstate(main 608 (eval 34):2) v:{
 549 # c      <0> pushmark s
 550 # d      <$> gvsv(*_) s
 551 # e      </> match(/"=(\\d+)"/) l/RTIME
 552 # f      <$> gvsv(*_) s
 553 # g      <1> uc[t9] sK/1
 554 # h      <@> anonlist sK*/1
 555 # i      <@> leave lKP
 556 #            goto 9
 557 # j  <@> sort lKMS*
 558 # k  <@> mapstart lK*
 559 # l  <|> mapwhile(other->m)[t12] lK
 560 # m      <$> gv(*_) s
 561 # n      <1> rv2sv sKM/DREFAV,1
 562 # o      <1> rv2av[t2] sKR/1
 563 # p      <$> const(IV 0) s
 564 # q      <2> aelem sK/2
 565 # -      <@> scope lK
 566 #            goto l
 567 # r  <0> pushmark s
 568 # s  <$> gv(*new) s
 569 # t  <1> rv2av[t1] lKRM*/1
 570 # u  <2> aassign[t13] KS/COMMON
 571 # v  <1> leavesub[1 ref] K/REFC,1
 572 EONT_EONT
 573
 574
 575 =for gentest
 576
 577 # chunk: # using a prototype allows you to use any comparison subroutine
 578 # as a sort subroutine (including other package's subroutines)
 579 package other;
 580 sub backwards ($$) { $_[1] cmp $_[0]; }     # $a and $b are not set here
 581 package main;
 582 @new = sort other::backwards @old;
 583
 584 =cut
 585
 586 checkOptree(name   => q{sort other::sub LIST },
 587             bcopts => q{-exec},
 588             code   => q{package other; sub backwards ($$) { $_[1] cmp $_[0]; }
 589                         package main; @new = sort other::backwards @old; },
 590             expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 591 # 1  <;> nextstate(main 614 (eval 36):2) v:{
 592 # 2  <0> pushmark s
 593 # 3  <0> pushmark s
 594 # 4  <$> const[PV "other::backwards"] s/BARE
 595 # 5  <#> gv[*old] s
 596 # 6  <1> rv2av[t4] lK/1
 597 # 7  <@> sort lKS
 598 # 8  <0> pushmark s
 599 # 9  <#> gv[*new] s
 600 # a  <1> rv2av[t2] lKRM*/1
 601 # b  <2> aassign[t5] KS/COMMON
 602 # c  <1> leavesub[1 ref] K/REFC,1
 603 EOT_EOT
 604 # 1  <;> nextstate(main 614 (eval 36):2) v:{
 605 # 2  <0> pushmark s
 606 # 3  <0> pushmark s
 607 # 4  <$> const(PV "other::backwards") s/BARE
 608 # 5  <$> gv(*old) s
 609 # 6  <1> rv2av[t2] lK/1
 610 # 7  <@> sort lKS
 611 # 8  <0> pushmark s
 612 # 9  <$> gv(*new) s
 613 # a  <1> rv2av[t1] lKRM*/1
 614 # b  <2> aassign[t3] KS/COMMON
 615 # c  <1> leavesub[1 ref] K/REFC,1
 616 EONT_EONT
 617
 618
 619 =for gentest
 620
 621 # chunk: # repeat, condensed. $main::a and $b are unaffected
 622 sub other::backwards ($$) { $_[1] cmp $_[0]; }
 623 @new = sort other::backwards @old;
 624
 625 =cut
 626
 627 checkOptree(note   => q{},
 628             bcopts => q{-exec},
 629             code   => q{sub other::backwards ($$) { $_[1] cmp $_[0]; } @new = sort other::backwards @old; },
 630             expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 631 # 1  <;> nextstate(main 619 (eval 38):1) v
 632 # 2  <0> pushmark s
 633 # 3  <0> pushmark s
 634 # 4  <$> const[PV "other::backwards"] s/BARE
 635 # 5  <#> gv[*old] s
 636 # 6  <1> rv2av[t4] lK/1
 637 # 7  <@> sort lKS
 638 # 8  <0> pushmark s
 639 # 9  <#> gv[*new] s
 640 # a  <1> rv2av[t2] lKRM*/1
 641 # b  <2> aassign[t5] KS/COMMON
 642 # c  <1> leavesub[1 ref] K/REFC,1
 643 EOT_EOT
 644 # 1  <;> nextstate(main 546 (eval 15):1) v
 645 # 2  <0> pushmark s
 646 # 3  <0> pushmark s
 647 # 4  <$> const(PV "other::backwards") s/BARE
 648 # 5  <$> gv(*old) s
 649 # 6  <1> rv2av[t2] lK/1
 650 # 7  <@> sort lKS
 651 # 8  <0> pushmark s
 652 # 9  <$> gv(*new) s
 653 # a  <1> rv2av[t1] lKRM*/1
 654 # b  <2> aassign[t3] KS/COMMON
 655 # c  <1> leavesub[1 ref] K/REFC,1
 656 EONT_EONT
 657
 658
 659 =for gentest
 660
 661 # chunk: # guarantee stability, regardless of algorithm
 662 use sort 'stable';
 663 @new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old;
 664
 665 =cut
 666
 667 my ($expect, $expect_nt) = (<<'EOT_EOT', <<'EONT_EONT');
 668 # 1  <;> nextstate(main 656 (eval 40):1) v:%,{
 669 # 2  <0> pushmark s
 670 # 3  <0> pushmark s
 671 # 4  <#> gv[*old] s
 672 # 5  <1> rv2av[t9] lK/1
 673 # 6  <@> sort lKS*/STABLE
 674 # 7  <0> pushmark s
 675 # 8  <#> gv[*new] s
 676 # 9  <1> rv2av[t2] lKRM*/1
 677 # a  <2> aassign[t14] KS/COMMON
 678 # b  <1> leavesub[1 ref] K/REFC,1
 679 EOT_EOT
 680 # 1  <;> nextstate(main 578 (eval 15):1) v:%,{
 681 # 2  <0> pushmark s
 682 # 3  <0> pushmark s
 683 # 4  <$> gv(*old) s
 684 # 5  <1> rv2av[t5] lK/1
 685 # 6  <@> sort lKS*/STABLE
 686 # 7  <0> pushmark s
 687 # 8  <$> gv(*new) s
 688 # 9  <1> rv2av[t1] lKRM*/1
 689 # a  <2> aassign[t6] KS/COMMON
 690 # b  <1> leavesub[1 ref] K/REFC,1
 691 EONT_EONT
 692
 693 if($] < 5.009) {
 694     # 5.8.x doesn't show the /STABLE flag, so massage the golden results.
 695     s!/STABLE!!s foreach ($expect, $expect_nt);
 696 }
 697
 698 checkOptree(note   => q{},
 699             bcopts => q{-exec},
 700             code   => q{use sort 'stable'; @new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old; },
 701             expect => $expect, expect_nt => $expect_nt);
 702
 703 =for gentest
 704
 705 # chunk: # force use of mergesort (not portable outside Perl 5.8)
 706 use sort '_mergesort';
 707 @new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old;
 708
 709 =cut
 710
 711 checkOptree(note   => q{},
 712             bcopts => q{-exec},
 713             code   => q{use sort '_mergesort'; @new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old; },
 714             expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 715 # 1  <;> nextstate(main 662 (eval 42):1) v:%,{
 716 # 2  <0> pushmark s
 717 # 3  <0> pushmark s
 718 # 4  <#> gv[*old] s
 719 # 5  <1> rv2av[t9] lK/1
 720 # 6  <@> sort lKS*
 721 # 7  <0> pushmark s
 722 # 8  <#> gv[*new] s
 723 # 9  <1> rv2av[t2] lKRM*/1
 724 # a  <2> aassign[t14] KS/COMMON
 725 # b  <1> leavesub[1 ref] K/REFC,1
 726 EOT_EOT
 727 # 1  <;> nextstate(main 578 (eval 15):1) v:%,{
 728 # 2  <0> pushmark s
 729 # 3  <0> pushmark s
 730 # 4  <$> gv(*old) s
 731 # 5  <1> rv2av[t5] lK/1
 732 # 6  <@> sort lKS*
 733 # 7  <0> pushmark s
 734 # 8  <$> gv(*new) s
 735 # 9  <1> rv2av[t1] lKRM*/1
 736 # a  <2> aassign[t6] KS/COMMON
 737 # b  <1> leavesub[1 ref] K/REFC,1
 738 EONT_EONT
 739
 740
 741 =for gentest
 742
 743 # chunk: # you should have a good reason to do this!
 744 @articles = sort {$FooPack::b <=> $FooPack::a} @files;
 745
 746 =cut
 747
 748 checkOptree(note   => q{},
 749             bcopts => q{-exec},
 750             code   => q{@articles = sort {$FooPack::b <=> $FooPack::a} @files; },
 751             expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 752 # 1  <;> nextstate(main 667 (eval 44):1) v
 753 # 2  <0> pushmark s
 754 # 3  <0> pushmark s
 755 # 4  <#> gv[*files] s
 756 # 5  <1> rv2av[t7] lK/1
 757 # 6  <@> sort lKS*
 758 # 7  <0> pushmark s
 759 # 8  <#> gv[*articles] s
 760 # 9  <1> rv2av[t2] lKRM*/1
 761 # a  <2> aassign[t8] KS/COMMON
 762 # b  <1> leavesub[1 ref] K/REFC,1
 763 EOT_EOT
 764 # 1  <;> nextstate(main 546 (eval 15):1) v
 765 # 2  <0> pushmark s
 766 # 3  <0> pushmark s
 767 # 4  <$> gv(*files) s
 768 # 5  <1> rv2av[t3] lK/1
 769 # 6  <@> sort lKS*
 770 # 7  <0> pushmark s
 771 # 8  <$> gv(*articles) s
 772 # 9  <1> rv2av[t1] lKRM*/1
 773 # a  <2> aassign[t4] KS/COMMON
 774 # b  <1> leavesub[1 ref] K/REFC,1
 775 EONT_EONT
 776
 777
 778 =for gentest
 779
 780 # chunk: # fancy
 781 @result = sort { $a <=> $b } grep { $_ == $_ } @input;
 782
 783 =cut
 784
 785 checkOptree(note   => q{},
 786             bcopts => q{-exec},
 787             code   => q{@result = sort { $a <=> $b } grep { $_ == $_ } @input; },
 788             expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 789 # 1  <;> nextstate(main 673 (eval 46):1) v
 790 # 2  <0> pushmark s
 791 # 3  <0> pushmark s
 792 # 4  <0> pushmark s
 793 # 5  <#> gv[*input] s
 794 # 6  <1> rv2av[t9] lKM/1
 795 # 7  <@> grepstart lK*
 796 # 8  <|> grepwhile(other->9)[t10] lK
 797 # 9      <#> gvsv[*_] s
 798 # a      <#> gvsv[*_] s
 799 # b      <2> eq sK/2
 800 # -      <@> scope sK
 801 #            goto 8
 802 # c  <@> sort lK/NUM
 803 # d  <0> pushmark s
 804 # e  <#> gv[*result] s
 805 # f  <1> rv2av[t2] lKRM*/1
 806 # g  <2> aassign[t3] KS/COMMON
 807 # h  <1> leavesub[1 ref] K/REFC,1
 808 EOT_EOT
 809 # 1  <;> nextstate(main 547 (eval 15):1) v
 810 # 2  <0> pushmark s
 811 # 3  <0> pushmark s
 812 # 4  <0> pushmark s
 813 # 5  <$> gv(*input) s
 814 # 6  <1> rv2av[t3] lKM/1
 815 # 7  <@> grepstart lK*
 816 # 8  <|> grepwhile(other->9)[t4] lK
 817 # 9      <$> gvsv(*_) s
 818 # a      <$> gvsv(*_) s
 819 # b      <2> eq sK/2
 820 # -      <@> scope sK
 821 #            goto 8
 822 # c  <@> sort lK/NUM
 823 # d  <0> pushmark s
 824 # e  <$> gv(*result) s
 825 # f  <1> rv2av[t1] lKRM*/1
 826 # g  <2> aassign[t2] KS/COMMON
 827 # h  <1> leavesub[1 ref] K/REFC,1
 828 EONT_EONT
 829
 830
 831 =for gentest
 832
 833 # chunk: # void return context sort
 834 sort { $a <=> $b } @input;
 835
 836 =cut
 837
 838 checkOptree(note   => q{},
 839             bcopts => q{-exec},
 840             code   => q{sort { $a <=> $b } @input; },
 841             expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 842 # 1  <;> nextstate(main 678 (eval 48):1) v
 843 # 2  <0> pushmark s
 844 # 3  <#> gv[*input] s
 845 # 4  <1> rv2av[t5] lK/1
 846 # 5  <@> sort K/NUM
 847 # 6  <1> leavesub[1 ref] K/REFC,1
 848 EOT_EOT
 849 # 1  <;> nextstate(main 546 (eval 15):1) v
 850 # 2  <0> pushmark s
 851 # 3  <$> gv(*input) s
 852 # 4  <1> rv2av[t2] lK/1
 853 # 5  <@> sort K/NUM
 854 # 6  <1> leavesub[1 ref] K/REFC,1
 855 EONT_EONT
 856
 857
 858 =for gentest
 859
 860 # chunk: # more void context, propagating ?
 861 sort { $a <=> $b } grep { $_ == $_ } @input;
 862
 863 =cut
 864
 865 checkOptree(note   => q{},
 866             bcopts => q{-exec},
 867             code   => q{sort { $a <=> $b } grep { $_ == $_ } @input; },
 868             expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 869 # 1  <;> nextstate(main 684 (eval 50):1) v
 870 # 2  <0> pushmark s
 871 # 3  <0> pushmark s
 872 # 4  <#> gv[*input] s
 873 # 5  <1> rv2av[t7] lKM/1
 874 # 6  <@> grepstart lK*
 875 # 7  <|> grepwhile(other->8)[t8] lK
 876 # 8      <#> gvsv[*_] s
 877 # 9      <#> gvsv[*_] s
 878 # a      <2> eq sK/2
 879 # -      <@> scope sK
 880 #            goto 7
 881 # b  <@> sort K/NUM
 882 # c  <1> leavesub[1 ref] K/REFC,1
 883 EOT_EOT
 884 # 1  <;> nextstate(main 547 (eval 15):1) v
 885 # 2  <0> pushmark s
 886 # 3  <0> pushmark s
 887 # 4  <$> gv(*input) s
 888 # 5  <1> rv2av[t2] lKM/1
 889 # 6  <@> grepstart lK*
 890 # 7  <|> grepwhile(other->8)[t3] lK
 891 # 8      <$> gvsv(*_) s
 892 # 9      <$> gvsv(*_) s
 893 # a      <2> eq sK/2
 894 # -      <@> scope sK
 895 #            goto 7
 896 # b  <@> sort K/NUM
 897 # c  <1> leavesub[1 ref] K/REFC,1
 898 EONT_EONT
 899
 900
 901 =for gentest
 902
 903 # chunk: # scalar return context sort
 904 $s = sort { $a <=> $b } @input;
 905
 906 =cut
 907
 908 checkOptree(note   => q{},
 909             bcopts => q{-exec},
 910             code   => q{$s = sort { $a <=> $b } @input; },
 911             expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 912 # 1  <;> nextstate(main 689 (eval 52):1) v:{
 913 # 2  <0> pushmark s
 914 # 3  <#> gv[*input] s
 915 # 4  <1> rv2av[t6] lK/1
 916 # 5  <@> sort sK/NUM
 917 # 6  <#> gvsv[*s] s
 918 # 7  <2> sassign sKS/2
 919 # 8  <1> leavesub[1 ref] K/REFC,1
 920 EOT_EOT
 921 # 1  <;> nextstate(main 546 (eval 15):1) v:{
 922 # 2  <0> pushmark s
 923 # 3  <$> gv(*input) s
 924 # 4  <1> rv2av[t2] lK/1
 925 # 5  <@> sort sK/NUM
 926 # 6  <$> gvsv(*s) s
 927 # 7  <2> sassign sKS/2
 928 # 8  <1> leavesub[1 ref] K/REFC,1
 929 EONT_EONT
 930
 931
 932 =for gentest
 933
 934 # chunk: $s = sort { $a <=> $b } grep { $_ == $_ } @input;
 935
 936 =cut
 937
 938 checkOptree(note   => q{},
 939             bcopts => q{-exec},
 940             code   => q{$s = sort { $a <=> $b } grep { $_ == $_ } @input; },
 941             expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 942 # 1  <;> nextstate(main 695 (eval 54):1) v:{
 943 # 2  <0> pushmark s
 944 # 3  <0> pushmark s
 945 # 4  <#> gv[*input] s
 946 # 5  <1> rv2av[t8] lKM/1
 947 # 6  <@> grepstart lK*
 948 # 7  <|> grepwhile(other->8)[t9] lK
 949 # 8      <#> gvsv[*_] s
 950 # 9      <#> gvsv[*_] s
 951 # a      <2> eq sK/2
 952 # -      <@> scope sK
 953 #            goto 7
 954 # b  <@> sort sK/NUM
 955 # c  <#> gvsv[*s] s
 956 # d  <2> sassign sKS/2
 957 # e  <1> leavesub[1 ref] K/REFC,1
 958 EOT_EOT
 959 # 1  <;> nextstate(main 547 (eval 15):1) v:{
 960 # 2  <0> pushmark s
 961 # 3  <0> pushmark s
 962 # 4  <$> gv(*input) s
 963 # 5  <1> rv2av[t2] lKM/1
 964 # 6  <@> grepstart lK*
 965 # 7  <|> grepwhile(other->8)[t3] lK
 966 # 8      <$> gvsv(*_) s
 967 # 9      <$> gvsv(*_) s
 968 # a      <2> eq sK/2
 969 # -      <@> scope sK
 970 #            goto 7
 971 # b  <@> sort sK/NUM
 972 # c  <$> gvsv(*s) s
 973 # d  <2> sassign sKS/2
 974 # e  <1> leavesub[1 ref] K/REFC,1
 975 EONT_EONT
 976