5 @INC = qw(../lib ../ext/B/t);
7 if (($Config::Config{'extensions'} !~ /\bB\b/) ){
8 print "1..0 # Skip -- Perl configured without B module\n";
20 #examples poached from perldoc -f sort
22 NOTE: name is no longer a required arg for checkOptree, as label is
23 synthesized out of others. HOWEVER, if the test-code has newlines in
24 it, the label must be overridden by an explicit name.
26 This is because t/TEST is quite particular about the test output it
27 processes, and multi-line labels violate its 1-line-per-test
32 # chunk: # sort lexically
33 @articles = sort @files;
37 checkOptree(note => q{},
39 code => q{@articles = sort @files; },
40 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
41 # 1 <;> nextstate(main 545 (eval 15):1) v
45 # 5 <1> rv2av[t4] lK/1
48 # 8 <#> gv[*articles] s
49 # 9 <1> rv2av[t2] lKRM*/1
50 # a <2> aassign[t5] KS
51 # b <1> leavesub[1 ref] K/REFC,1
53 # 1 <;> nextstate(main 545 (eval 15):1) v
57 # 5 <1> rv2av[t2] lK/1
60 # 8 <$> gv(*articles) s
61 # 9 <1> rv2av[t1] lKRM*/1
62 # a <2> aassign[t3] KS
63 # b <1> leavesub[1 ref] K/REFC,1
69 # chunk: # same thing, but with explicit sort routine
70 @articles = sort {$a cmp $b} @files;
74 checkOptree(note => q{},
76 code => q{@articles = sort {$a cmp $b} @files; },
77 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
78 # 1 <;> nextstate(main 546 (eval 15):1) v
82 # 5 <1> rv2av[t7] lK/1
85 # 8 <#> gv[*articles] s
86 # 9 <1> rv2av[t2] lKRM*/1
87 # a <2> aassign[t5] KS
88 # b <1> leavesub[1 ref] K/REFC,1
90 # 1 <;> nextstate(main 546 (eval 15):1) v
94 # 5 <1> rv2av[t3] lK/1
97 # 8 <$> gv(*articles) s
98 # 9 <1> rv2av[t1] lKRM*/1
99 # a <2> aassign[t2] KS
100 # b <1> leavesub[1 ref] K/REFC,1
106 # chunk: # now case-insensitively
107 @articles = sort {uc($a) cmp uc($b)} @files;
111 checkOptree(note => q{},
113 code => q{@articles = sort {uc($a) cmp uc($b)} @files; },
114 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
115 # 1 <;> nextstate(main 546 (eval 15):1) v
119 # 5 <1> rv2av[t9] lK/1
122 # 8 <#> gv[*articles] s
123 # 9 <1> rv2av[t2] lKRM*/1
124 # a <2> aassign[t10] KS
125 # b <1> leavesub[1 ref] K/REFC,1
127 # 1 <;> nextstate(main 546 (eval 15):1) v
131 # 5 <1> rv2av[t5] lK/1
134 # 8 <$> gv(*articles) s
135 # 9 <1> rv2av[t1] lKRM*/1
136 # a <2> aassign[t6] KS
137 # b <1> leavesub[1 ref] K/REFC,1
143 # chunk: # same thing in reversed order
144 @articles = sort {$b cmp $a} @files;
148 checkOptree(note => q{},
150 code => q{@articles = sort {$b cmp $a} @files; },
151 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
152 # 1 <;> nextstate(main 546 (eval 15):1) v
156 # 5 <1> rv2av[t7] lK/1
159 # 8 <#> gv[*articles] s
160 # 9 <1> rv2av[t2] lKRM*/1
161 # a <2> aassign[t5] KS
162 # b <1> leavesub[1 ref] K/REFC,1
164 # 1 <;> nextstate(main 546 (eval 15):1) v
168 # 5 <1> rv2av[t3] lK/1
171 # 8 <$> gv(*articles) s
172 # 9 <1> rv2av[t1] lKRM*/1
173 # a <2> aassign[t2] KS
174 # b <1> leavesub[1 ref] K/REFC,1
180 # chunk: # sort numerically ascending
181 @articles = sort {$a <=> $b} @files;
185 checkOptree(note => q{},
187 code => q{@articles = sort {$a <=> $b} @files; },
188 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
189 # 1 <;> nextstate(main 546 (eval 15):1) v
193 # 5 <1> rv2av[t7] lK/1
196 # 8 <#> gv[*articles] s
197 # 9 <1> rv2av[t2] lKRM*/1
198 # a <2> aassign[t5] KS
199 # b <1> leavesub[1 ref] K/REFC,1
201 # 1 <;> nextstate(main 546 (eval 15):1) v
205 # 5 <1> rv2av[t3] lK/1
208 # 8 <$> gv(*articles) s
209 # 9 <1> rv2av[t1] lKRM*/1
210 # a <2> aassign[t2] KS
211 # b <1> leavesub[1 ref] K/REFC,1
217 # chunk: # sort numerically descending
218 @articles = sort {$b <=> $a} @files;
222 checkOptree(note => q{},
224 code => q{@articles = sort {$b <=> $a} @files; },
225 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
226 # 1 <;> nextstate(main 587 (eval 26):1) v
230 # 5 <1> rv2av[t7] lK/1
231 # 6 <@> sort lK/REV,NUM
233 # 8 <#> gv[*articles] s
234 # 9 <1> rv2av[t2] lKRM*/1
235 # a <2> aassign[t5] KS
236 # b <1> leavesub[1 ref] K/REFC,1
238 # 1 <;> nextstate(main 546 (eval 15):1) v
242 # 5 <1> rv2av[t3] lK/1
243 # 6 <@> sort lK/REV,NUM
245 # 8 <$> gv(*articles) s
246 # 9 <1> rv2av[t1] lKRM*/1
247 # a <2> aassign[t2] KS
248 # b <1> leavesub[1 ref] K/REFC,1
254 # chunk: # this sorts the %age hash by value instead of key
255 # using an in-line function
256 @eldest = sort { $age{$b} <=> $age{$a} } keys %age;
260 checkOptree(note => q{},
262 code => q{@eldest = sort { $age{$b} <=> $age{$a} } keys %age; },
263 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
264 # 1 <;> nextstate(main 592 (eval 28):1) v
268 # 5 <1> rv2hv[t9] lKRM/1
269 # 6 <1> keys[t10] lK/1
272 # 9 <#> gv[*eldest] s
273 # a <1> rv2av[t2] lKRM*/1
274 # b <2> aassign[t11] KS
275 # c <1> leavesub[1 ref] K/REFC,1
277 # 1 <;> nextstate(main 546 (eval 15):1) v
281 # 5 <1> rv2hv[t3] lKRM/1
282 # 6 <1> keys[t4] lK/1
285 # 9 <$> gv(*eldest) s
286 # a <1> rv2av[t1] lKRM*/1
287 # b <2> aassign[t5] KS
288 # c <1> leavesub[1 ref] K/REFC,1
294 # chunk: # sort using explicit subroutine name
296 $age{$a} <=> $age{$b}; # presuming numeric
298 @sortedclass = sort byage @class;
302 checkOptree(note => q{},
304 code => q{sub byage { $age{$a} <=> $age{$b}; } @sortedclass = sort byage @class; },
305 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
306 # 1 <;> nextstate(main 597 (eval 30):1) v
309 # 4 <$> const[PV "byage"] s/BARE
311 # 6 <1> rv2av[t4] lK/1
314 # 9 <#> gv[*sortedclass] s
315 # a <1> rv2av[t2] lKRM*/1
316 # b <2> aassign[t5] KS
317 # c <1> leavesub[1 ref] K/REFC,1
319 # 1 <;> nextstate(main 546 (eval 15):1) v
322 # 4 <$> const(PV "byage") s/BARE
324 # 6 <1> rv2av[t2] lK/1
327 # 9 <$> gv(*sortedclass) s
328 # a <1> rv2av[t1] lKRM*/1
329 # b <2> aassign[t3] KS
330 # c <1> leavesub[1 ref] K/REFC,1
336 # chunk: sub backwards { $b cmp $a }
337 @harry = qw(dog cat x Cain Abel);
338 @george = qw(gone chased yz Punished Axed);
340 # prints AbelCaincatdogx
341 print sort backwards @harry;
342 # prints xdogcatCainAbel
343 print sort @george, 'to', @harry;
344 # prints AbelAxedCainPunishedcatchaseddoggonetoxyz
348 checkOptree(name => q{sort USERSUB LIST },
350 code => q{sub backwards { $b cmp $a }
351 @harry = qw(dog cat x Cain Abel);
352 @george = qw(gone chased yz Punished Axed);
353 print sort @harry; print sort backwards @harry;
354 print sort @george, 'to', @harry; },
355 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
356 # 1 <;> nextstate(main 602 (eval 32):2) v
358 # 3 <$> const[PV "dog"] s
359 # 4 <$> const[PV "cat"] s
360 # 5 <$> const[PV "x"] s
361 # 6 <$> const[PV "Cain"] s
362 # 7 <$> const[PV "Abel"] s
365 # a <1> rv2av[t2] lKRM*/1
366 # b <2> aassign[t3] vKS
367 # c <;> nextstate(main 602 (eval 32):3) v
369 # e <$> const[PV "gone"] s
370 # f <$> const[PV "chased"] s
371 # g <$> const[PV "yz"] s
372 # h <$> const[PV "Punished"] s
373 # i <$> const[PV "Axed"] s
375 # k <#> gv[*george] s
376 # l <1> rv2av[t5] lKRM*/1
377 # m <2> aassign[t6] vKS
378 # n <;> nextstate(main 602 (eval 32):4) v
382 # r <1> rv2av[t8] lK/1
385 # u <;> nextstate(main 602 (eval 32):4) v
388 # x <$> const[PV "backwards"] s/BARE
390 # z <1> rv2av[t10] lK/1
393 # 12 <;> nextstate(main 602 (eval 32):5) v
396 # 15 <#> gv[*george] s
397 # 16 <1> rv2av[t12] lK/1
398 # 17 <$> const[PV "to"] s
399 # 18 <#> gv[*harry] s
400 # 19 <1> rv2av[t14] lK/1
403 # 1c <1> leavesub[1 ref] K/REFC,1
405 # 1 <;> nextstate(main 602 (eval 32):2) v
407 # 3 <$> const(PV "dog") s
408 # 4 <$> const(PV "cat") s
409 # 5 <$> const(PV "x") s
410 # 6 <$> const(PV "Cain") s
411 # 7 <$> const(PV "Abel") s
414 # a <1> rv2av[t1] lKRM*/1
415 # b <2> aassign[t2] vKS
416 # c <;> nextstate(main 602 (eval 32):3) v
418 # e <$> const(PV "gone") s
419 # f <$> const(PV "chased") s
420 # g <$> const(PV "yz") s
421 # h <$> const(PV "Punished") s
422 # i <$> const(PV "Axed") s
424 # k <$> gv(*george) s
425 # l <1> rv2av[t3] lKRM*/1
426 # m <2> aassign[t4] vKS
427 # n <;> nextstate(main 602 (eval 32):4) v
431 # r <1> rv2av[t5] lK/1
434 # u <;> nextstate(main 602 (eval 32):4) v
437 # x <$> const(PV "backwards") s/BARE
439 # z <1> rv2av[t6] lK/1
442 # 12 <;> nextstate(main 602 (eval 32):5) v
445 # 15 <$> gv(*george) s
446 # 16 <1> rv2av[t7] lK/1
447 # 17 <$> const(PV "to") s
448 # 18 <$> gv(*harry) s
449 # 19 <1> rv2av[t8] lK/1
452 # 1c <1> leavesub[1 ref] K/REFC,1
458 # chunk: # inefficiently sort by descending numeric compare using
459 # the first integer after the first = sign, or the
460 # whole record case-insensitively otherwise
462 $nums[$b] <=> $nums[$a]
463 || $caps[$a] cmp $caps[$b]
469 # chunk: # same thing, but without any temps
470 @new = map { $_->[0] }
471 sort { $b->[1] <=> $a->[1]
472 || $a->[2] cmp $b->[2]
473 } map { [$_, /=(\d+)/, uc($_)] } @old;
477 checkOptree(name => q{Compound sort/map Expression },
479 code => q{ @new = map { $_->[0] }
480 sort { $b->[1] <=> $a->[1] || $a->[2] cmp $b->[2] }
481 map { [$_, /=(\d+)/, uc($_)] } @old; },
482 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
483 # 1 <;> nextstate(main 609 (eval 34):3) v
489 # 7 <1> rv2av[t19] lKM/1
491 # 9 <|> mapwhile(other->a)[t20] lK
493 # b <;> nextstate(main 608 (eval 34):2) v
496 # e </> match(/"=(\\d+)"/) l/RTIME
499 # h <@> anonlist sKRM/1
505 # m <|> mapwhile(other->n)[t26] lK
507 # o <1> rv2sv sKM/DREFAV,1
508 # p <1> rv2av[t4] sKR/1
509 # q <$> const[IV 0] s
515 # u <1> rv2av[t2] lKRM*/1
516 # v <2> aassign[t27] KS/COMMON
517 # w <1> leavesub[1 ref] K/REFC,1
519 # 1 <;> nextstate(main 609 (eval 34):3) v
525 # 7 <1> rv2av[t10] lKM/1
527 # 9 <|> mapwhile(other->a)[t11] lK
529 # b <;> nextstate(main 608 (eval 34):2) v
532 # e </> match(/"=(\\d+)"/) l/RTIME
535 # h <@> anonlist sKRM/1
541 # m <|> mapwhile(other->n)[t12] lK
543 # o <1> rv2sv sKM/DREFAV,1
544 # p <1> rv2av[t2] sKR/1
545 # q <$> const(IV 0) s
551 # u <1> rv2av[t1] lKRM*/1
552 # v <2> aassign[t13] KS/COMMON
553 # w <1> leavesub[1 ref] K/REFC,1
559 # chunk: # using a prototype allows you to use any comparison subroutine
560 # as a sort subroutine (including other package's subroutines)
562 sub backwards ($$) { $_[1] cmp $_[0]; } # $a and $b are not set here
564 @new = sort other::backwards @old;
568 checkOptree(name => q{sort other::sub LIST },
570 code => q{package other; sub backwards ($$) { $_[1] cmp $_[0]; }
571 package main; @new = sort other::backwards @old; },
572 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
573 # 1 <;> nextstate(main 614 (eval 36):2) v
576 # 4 <$> const[PV "other::backwards"] s/BARE
578 # 6 <1> rv2av[t4] lK/1
582 # a <1> rv2av[t2] lKRM*/1
583 # b <2> aassign[t5] KS
584 # c <1> leavesub[1 ref] K/REFC,1
586 # 1 <;> nextstate(main 614 (eval 36):2) v
589 # 4 <$> const(PV "other::backwards") s/BARE
591 # 6 <1> rv2av[t2] lK/1
595 # a <1> rv2av[t1] lKRM*/1
596 # b <2> aassign[t3] KS
597 # c <1> leavesub[1 ref] K/REFC,1
603 # chunk: # repeat, condensed. $main::a and $b are unaffected
604 sub other::backwards ($$) { $_[1] cmp $_[0]; }
605 @new = sort other::backwards @old;
609 checkOptree(note => q{},
611 code => q{sub other::backwards ($$) { $_[1] cmp $_[0]; } @new = sort other::backwards @old; },
612 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
613 # 1 <;> nextstate(main 619 (eval 38):1) v
616 # 4 <$> const[PV "other::backwards"] s/BARE
618 # 6 <1> rv2av[t4] lK/1
622 # a <1> rv2av[t2] lKRM*/1
623 # b <2> aassign[t5] KS
624 # c <1> leavesub[1 ref] K/REFC,1
626 # 1 <;> nextstate(main 546 (eval 15):1) v
629 # 4 <$> const(PV "other::backwards") s/BARE
631 # 6 <1> rv2av[t2] lK/1
635 # a <1> rv2av[t1] lKRM*/1
636 # b <2> aassign[t3] KS
637 # c <1> leavesub[1 ref] K/REFC,1
643 # chunk: # guarantee stability, regardless of algorithm
645 @new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old;
649 checkOptree(note => q{},
651 code => q{use sort 'stable'; @new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old; },
652 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
653 # 1 <;> nextstate(main 656 (eval 40):1) v
657 # 5 <1> rv2av[t9] lK/1
661 # 9 <1> rv2av[t2] lKRM*/1
662 # a <2> aassign[t14] KS
663 # b <1> leavesub[1 ref] K/REFC,1
665 # 1 <;> nextstate(main 578 (eval 15):1) v
669 # 5 <1> rv2av[t5] lK/1
673 # 9 <1> rv2av[t1] lKRM*/1
674 # a <2> aassign[t6] KS
675 # b <1> leavesub[1 ref] K/REFC,1
681 # chunk: # force use of mergesort (not portable outside Perl 5.8)
682 use sort '_mergesort';
683 @new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old;
687 checkOptree(note => q{},
689 code => q{use sort '_mergesort'; @new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old; },
690 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
691 # 1 <;> nextstate(main 662 (eval 42):1) v
695 # 5 <1> rv2av[t9] lK/1
699 # 9 <1> rv2av[t2] lKRM*/1
700 # a <2> aassign[t14] KS
701 # b <1> leavesub[1 ref] K/REFC,1
703 # 1 <;> nextstate(main 578 (eval 15):1) v
707 # 5 <1> rv2av[t5] lK/1
711 # 9 <1> rv2av[t1] lKRM*/1
712 # a <2> aassign[t6] KS
713 # b <1> leavesub[1 ref] K/REFC,1
719 # chunk: # you should have a good reason to do this!
720 @articles = sort {$FooPack::b <=> $FooPack::a} @files;
724 checkOptree(note => q{},
726 code => q{@articles = sort {$FooPack::b <=> $FooPack::a} @files; },
727 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
728 # 1 <;> nextstate(main 667 (eval 44):1) v
732 # 5 <1> rv2av[t7] lK/1
735 # 8 <#> gv[*articles] s
736 # 9 <1> rv2av[t2] lKRM*/1
737 # a <2> aassign[t8] KS
738 # b <1> leavesub[1 ref] K/REFC,1
740 # 1 <;> nextstate(main 546 (eval 15):1) v
744 # 5 <1> rv2av[t3] lK/1
747 # 8 <$> gv(*articles) s
748 # 9 <1> rv2av[t1] lKRM*/1
749 # a <2> aassign[t4] KS
750 # b <1> leavesub[1 ref] K/REFC,1
757 @result = sort { $a <=> $b } grep { $_ == $_ } @input;
761 checkOptree(note => q{},
763 code => q{@result = sort { $a <=> $b } grep { $_ == $_ } @input; },
764 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
765 # 1 <;> nextstate(main 673 (eval 46):1) v
770 # 6 <1> rv2av[t9] lKM/1
771 # 7 <@> grepstart lK*
772 # 8 <|> grepwhile(other->9)[t10] lK
780 # e <#> gv[*result] s
781 # f <1> rv2av[t2] lKRM*/1
782 # g <2> aassign[t5] KS/COMMON
783 # h <1> leavesub[1 ref] K/REFC,1
785 # 1 <;> nextstate(main 547 (eval 15):1) v
790 # 6 <1> rv2av[t3] lKM/1
791 # 7 <@> grepstart lK*
792 # 8 <|> grepwhile(other->9)[t4] lK
800 # e <$> gv(*result) s
801 # f <1> rv2av[t1] lKRM*/1
802 # g <2> aassign[t2] KS/COMMON
803 # h <1> leavesub[1 ref] K/REFC,1
809 # chunk: # void return context sort
810 sort { $a <=> $b } @input;
814 checkOptree(note => q{},
816 code => q{sort { $a <=> $b } @input; },
817 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
818 # 1 <;> nextstate(main 678 (eval 48):1) v
821 # 4 <1> rv2av[t5] lK/1
823 # 6 <1> leavesub[1 ref] K/REFC,1
825 # 1 <;> nextstate(main 546 (eval 15):1) v
828 # 4 <1> rv2av[t2] lK/1
830 # 6 <1> leavesub[1 ref] K/REFC,1
836 # chunk: # more void context, propagating ?
837 sort { $a <=> $b } grep { $_ == $_ } @input;
841 checkOptree(note => q{},
843 code => q{sort { $a <=> $b } grep { $_ == $_ } @input; },
844 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
845 # 1 <;> nextstate(main 684 (eval 50):1) v
849 # 5 <1> rv2av[t7] lKM/1
850 # 6 <@> grepstart lK*
851 # 7 <|> grepwhile(other->8)[t8] lK
858 # c <1> leavesub[1 ref] K/REFC,1
860 # 1 <;> nextstate(main 547 (eval 15):1) v
864 # 5 <1> rv2av[t2] lKM/1
865 # 6 <@> grepstart lK*
866 # 7 <|> grepwhile(other->8)[t3] lK
873 # c <1> leavesub[1 ref] K/REFC,1
879 # chunk: # scalar return context sort
880 $s = sort { $a <=> $b } @input;
884 checkOptree(note => q{},
886 code => q{$s = sort { $a <=> $b } @input; },
887 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
888 # 1 <;> nextstate(main 689 (eval 52):1) v
891 # 4 <1> rv2av[t6] lK/1
894 # 7 <2> sassign sKS/2
895 # 8 <1> leavesub[1 ref] K/REFC,1
897 # 1 <;> nextstate(main 546 (eval 15):1) v
900 # 4 <1> rv2av[t2] lK/1
903 # 7 <2> sassign sKS/2
904 # 8 <1> leavesub[1 ref] K/REFC,1
910 # chunk: $s = sort { $a <=> $b } grep { $_ == $_ } @input;
914 checkOptree(note => q{},
916 code => q{$s = sort { $a <=> $b } grep { $_ == $_ } @input; },
917 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
918 # 1 <;> nextstate(main 695 (eval 54):1) v
922 # 5 <1> rv2av[t8] lKM/1
923 # 6 <@> grepstart lK*
924 # 7 <|> grepwhile(other->8)[t9] lK
932 # d <2> sassign sKS/2
933 # e <1> leavesub[1 ref] K/REFC,1
935 # 1 <;> nextstate(main 547 (eval 15):1) v
939 # 5 <1> rv2av[t2] lKM/1
940 # 6 <@> grepstart lK*
941 # 7 <|> grepwhile(other->8)[t3] lK
949 # d <2> sassign sKS/2
950 # e <1> leavesub[1 ref] K/REFC,1