f_sort.t

source of perl for linux application,

#!perl

BEGIN {
    if ($ENV{PERL_CORE}){
	chdir('t') if -d 't';
	@INC = ('.', '../lib', '../ext/B/t');
    } else {
	unshift @INC, 't';
	push @INC, "../../t";
    }
    require Config;
    if (($Config::Config{'extensions'} !~ /\bB\b/) ){
        print "1..0 # Skip -- Perl configured without B module\n";
        exit 0;
    }
    if (!$Config::Config{useperlio}) {
        print "1..0 # Skip -- need perlio to walk the optree\n";
        exit 0;
    }
    # require q(test.pl); # now done by OptreeCheck;
}
use OptreeCheck;
plan tests => 20;

=head1 f_sort.t

Code test snippets here are adapted from `perldoc -f map`

Due to a bleadperl optimization (Dave Mitchell, circa apr 04), the
(map|grep)(start|while) opcodes have different flags in 5.9, their
private flags /1, /2 are gone in blead (for the cases covered)

When the optree stuff was integrated into 5.8.6, these tests failed,
and were todo'd.  Theyre now done, by version-specific tweaking in
mkCheckRex(), therefore the skip is removed too.

=head1 Test Notes

# chunk: #!perl
#examples poached from perldoc -f sort

NOTE: name is no longer a required arg for checkOptree, as label is
synthesized out of others.  HOWEVER, if the test-code has newlines in
it, the label must be overridden by an explicit name.

This is because t/TEST is quite particular about the test output it
processes, and multi-line labels violate its 1-line-per-test
expectations.

=for gentest

# chunk: # sort lexically
@articles = sort @files;

=cut

checkOptree(note   => q{},
	    bcopts => q{-exec},
	    code   => q{@articles = sort @files; },
	    expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1  <;> nextstate(main 545 (eval 15):1) v
# 2  <0> pushmark s
# 3  <0> pushmark s
# 4  <#> gv[*files] s
# 5  <1> rv2av[t4] lK/1
# 6  <@> sort lK
# 7  <0> pushmark s
# 8  <#> gv[*articles] s
# 9  <1> rv2av[t2] lKRM*/1
# a  <2> aassign[t5] KS/COMMON
# b  <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1  <;> nextstate(main 545 (eval 15):1) v
# 2  <0> pushmark s
# 3  <0> pushmark s
# 4  <$> gv(*files) s
# 5  <1> rv2av[t2] lK/1
# 6  <@> sort lK
# 7  <0> pushmark s
# 8  <$> gv(*articles) s
# 9  <1> rv2av[t1] lKRM*/1
# a  <2> aassign[t3] KS/COMMON
# b  <1> leavesub[1 ref] K/REFC,1
EONT_EONT
    

=for gentest

# chunk: # same thing, but with explicit sort routine
@articles = sort {$a cmp $b} @files;

=cut

checkOptree(note   => q{},
	    bcopts => q{-exec},
	    code   => q{@articles = sort {$a cmp $b} @files; },
	    expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1  <;> nextstate(main 546 (eval 15):1) v
# 2  <0> pushmark s
# 3  <0> pushmark s
# 4  <#> gv[*files] s
# 5  <1> rv2av[t7] lK/1
# 6  <@> sort lK
# 7  <0> pushmark s
# 8  <#> gv[*articles] s
# 9  <1> rv2av[t2] lKRM*/1
# a  <2> aassign[t3] KS/COMMON
# b  <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1  <;> nextstate(main 546 (eval 15):1) v
# 2  <0> pushmark s
# 3  <0> pushmark s
# 4  <$> gv(*files) s
# 5  <1> rv2av[t3] lK/1
# 6  <@> sort lK
# 7  <0> pushmark s
# 8  <$> gv(*articles) s
# 9  <1> rv2av[t1] lKRM*/1
# a  <2> aassign[t2] KS/COMMON
# b  <1> leavesub[1 ref] K/REFC,1
EONT_EONT
    

=for gentest

# chunk: # now case-insensitively
@articles = sort {uc($a) cmp uc($b)} @files;

=cut

checkOptree(note   => q{},
	    bcopts => q{-exec},
	    code   => q{@articles = sort {uc($a) cmp uc($b)} @files; },
	    expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1  <;> nextstate(main 546 (eval 15):1) v
# 2  <0> pushmark s
# 3  <0> pushmark s
# 4  <#> gv[*files] s
# 5  <1> rv2av[t9] lK/1
# 6  <@> sort lKS*
# 7  <0> pushmark s
# 8  <#> gv[*articles] s
# 9  <1> rv2av[t2] lKRM*/1
# a  <2> aassign[t10] KS/COMMON
# b  <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1  <;> nextstate(main 546 (eval 15):1) v
# 2  <0> pushmark s
# 3  <0> pushmark s
# 4  <$> gv(*files) s
# 5  <1> rv2av[t5] lK/1
# 6  <@> sort lKS*
# 7  <0> pushmark s
# 8  <$> gv(*articles) s
# 9  <1> rv2av[t1] lKRM*/1
# a  <2> aassign[t6] KS/COMMON
# b  <1> leavesub[1 ref] K/REFC,1
EONT_EONT
    

=for gentest

# chunk: # same thing in reversed order
@articles = sort {$b cmp $a} @files;

=cut

checkOptree(note   => q{},
	    bcopts => q{-exec},
	    code   => q{@articles = sort {$b cmp $a} @files; },
	    expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1  <;> nextstate(main 546 (eval 15):1) v
# 2  <0> pushmark s
# 3  <0> pushmark s
# 4  <#> gv[*files] s
# 5  <1> rv2av[t7] lK/1
# 6  <@> sort lK/DESC
# 7  <0> pushmark s
# 8  <#> gv[*articles] s
# 9  <1> rv2av[t2] lKRM*/1
# a  <2> aassign[t3] KS/COMMON
# b  <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1  <;> nextstate(main 546 (eval 15):1) v
# 2  <0> pushmark s
# 3  <0> pushmark s
# 4  <$> gv(*files) s
# 5  <1> rv2av[t3] lK/1
# 6  <@> sort lK/DESC
# 7  <0> pushmark s
# 8  <$> gv(*articles) s
# 9  <1> rv2av[t1] lKRM*/1
# a  <2> aassign[t2] KS/COMMON
# b  <1> leavesub[1 ref] K/REFC,1
EONT_EONT
    

=for gentest

# chunk: # sort numerically ascending
@articles = sort {$a <=> $b} @files;

=cut

checkOptree(note   => q{},
	    bcopts => q{-exec},
	    code   => q{@articles = sort {$a <=> $b} @files; },
	    expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1  <;> nextstate(main 546 (eval 15):1) v
# 2  <0> pushmark s
# 3  <0> pushmark s
# 4  <#> gv[*files] s
# 5  <1> rv2av[t7] lK/1
# 6  <@> sort lK/NUM
# 7  <0> pushmark s
# 8  <#> gv[*articles] s
# 9  <1> rv2av[t2] lKRM*/1
# a  <2> aassign[t3] KS/COMMON
# b  <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1  <;> nextstate(main 546 (eval 15):1) v
# 2  <0> pushmark s
# 3  <0> pushmark s
# 4  <$> gv(*files) s
# 5  <1> rv2av[t3] lK/1
# 6  <@> sort lK/NUM
# 7  <0> pushmark s
# 8  <$> gv(*articles) s
# 9  <1> rv2av[t1] lKRM*/1
# a  <2> aassign[t2] KS/COMMON
# b  <1> leavesub[1 ref] K/REFC,1
EONT_EONT
    

=for gentest

# chunk: # sort numerically descending
@articles = sort {$b <=> $a} @files;

=cut

checkOptree(note   => q{},
	    bcopts => q{-exec},
	    code   => q{@articles = sort {$b <=> $a} @files; },
	    expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1  <;> nextstate(main 587 (eval 26):1) v
# 2  <0> pushmark s
# 3  <0> pushmark s
# 4  <#> gv[*files] s
# 5  <1> rv2av[t7] lK/1
# 6  <@> sort lK/DESC,NUM
# 7  <0> pushmark s
# 8  <#> gv[*articles] s
# 9  <1> rv2av[t2] lKRM*/1
# a  <2> aassign[t3] KS/COMMON
# b  <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1  <;> nextstate(main 546 (eval 15):1) v
# 2  <0> pushmark s
# 3  <0> pushmark s
# 4  <$> gv(*files) s
# 5  <1> rv2av[t3] lK/1
# 6  <@> sort lK/DESC,NUM
# 7  <0> pushmark s
# 8  <$> gv(*articles) s
# 9  <1> rv2av[t1] lKRM*/1
# a  <2> aassign[t2] KS/COMMON
# b  <1> leavesub[1 ref] K/REFC,1
EONT_EONT


=for gentest

# chunk: # this sorts the %age hash by value instead of key
# using an in-line function
@eldest = sort { $age{$b} <=> $age{$a} } keys %age;

=cut

checkOptree(note   => q{},
	    bcopts => q{-exec},
	    code   => q{@eldest = sort { $age{$b} <=> $age{$a} } keys %age; },
	    expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1  <;> nextstate(main 592 (eval 28):1) v
# 2  <0> pushmark s
# 3  <0> pushmark s
# 4  <#> gv[*age] s
# 5  <1> rv2hv[t9] lKRM/1
# 6  <1> keys[t10] lK/1
# 7  <@> sort lKS*
# 8  <0> pushmark s
# 9  <#> gv[*eldest] s
# a  <1> rv2av[t2] lKRM*/1
# b  <2> aassign[t11] KS/COMMON
# c  <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1  <;> nextstate(main 546 (eval 15):1) v
# 2  <0> pushmark s
# 3  <0> pushmark s
# 4  <$> gv(*age) s
# 5  <1> rv2hv[t3] lKRM/1
# 6  <1> keys[t4] lK/1
# 7  <@> sort lKS*
# 8  <0> pushmark s
# 9  <$> gv(*eldest) s
# a  <1> rv2av[t1] lKRM*/1
# b  <2> aassign[t5] KS/COMMON
# c  <1> leavesub[1 ref] K/REFC,1
EONT_EONT
    

=for gentest

# chunk: # sort using explicit subroutine name
sub byage {
    $age{$a} <=> $age{$b};  # presuming numeric
}
@sortedclass = sort byage @class;

=cut

checkOptree(note   => q{},
	    bcopts => q{-exec},
	    code   => q{sub byage { $age{$a} <=> $age{$b}; } @sortedclass = sort byage @class; },
	    expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1  <;> nextstate(main 597 (eval 30):1) v
# 2  <0> pushmark s
# 3  <0> pushmark s
# 4  <$> const[PV "byage"] s/BARE
# 5  <#> gv[*class] s
# 6  <1> rv2av[t4] lK/1
# 7  <@> sort lKS
# 8  <0> pushmark s
# 9  <#> gv[*sortedclass] s
# a  <1> rv2av[t2] lKRM*/1
# b  <2> aassign[t5] KS/COMMON
# c  <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1  <;> nextstate(main 546 (eval 15):1) v
# 2  <0> pushmark s
# 3  <0> pushmark s
# 4  <$> const(PV "byage") s/BARE
# 5  <$> gv(*class) s
# 6  <1> rv2av[t2] lK/1
# 7  <@> sort lKS
# 8  <0> pushmark s
# 9  <$> gv(*sortedclass) s
# a  <1> rv2av[t1] lKRM*/1
# b  <2> aassign[t3] KS/COMMON
# c  <1> leavesub[1 ref] K/REFC,1
EONT_EONT
    

=for gentest

# chunk: sub backwards { $b cmp $a }
@harry  = qw(dog cat x Cain Abel);
@george = qw(gone chased yz Punished Axed);
print sort @harry;
# prints AbelCaincatdogx
print sort backwards @harry;
# prints xdogcatCainAbel
print sort @george, 'to', @harry;
# prints AbelAxedCainPunishedcatchaseddoggonetoxyz

=cut

checkOptree(name   => q{sort USERSUB LIST },
	    bcopts => q{-exec},
	    code   => q{sub backwards { $b cmp $a }
			@harry = qw(dog cat x Cain Abel);
			@george = qw(gone chased yz Punished Axed);
			print sort @harry; print sort backwards @harry; 
			print sort @george, 'to', @harry; },
	    expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1  <;> nextstate(main 602 (eval 32):2) v
# 2  <0> pushmark s
# 3  <$> const[PV "dog"] s
# 4  <$> const[PV "cat"] s
# 5  <$> const[PV "x"] s
# 6  <$> const[PV "Cain"] s
# 7  <$> const[PV "Abel"] s
# 8  <0> pushmark s
# 9  <#> gv[*harry] s
# a  <1> rv2av[t2] lKRM*/1
# b  <2> aassign[t3] vKS
# c  <;> nextstate(main 602 (eval 32):3) v
# d  <0> pushmark s
# e  <$> const[PV "gone"] s
# f  <$> const[PV "chased"] s
# g  <$> const[PV "yz"] s
# h  <$> const[PV "Punished"] s
# i  <$> const[PV "Axed"] s
# j  <0> pushmark s
# k  <#> gv[*george] s
# l  <1> rv2av[t5] lKRM*/1
# m  <2> aassign[t6] vKS
# n  <;> nextstate(main 602 (eval 32):4) v:{
# o  <0> pushmark s
# p  <0> pushmark s
# q  <#> gv[*harry] s
# r  <1> rv2av[t8] lK/1
# s  <@> sort lK
# t  <@> print vK
# u  <;> nextstate(main 602 (eval 32):4) v:{
# v  <0> pushmark s
# w  <0> pushmark s
# x  <$> const[PV "backwards"] s/BARE
# y  <#> gv[*harry] s
# z  <1> rv2av[t10] lK/1
# 10 <@> sort lKS
# 11 <@> print vK
# 12 <;> nextstate(main 602 (eval 32):5) v:{
# 13 <0> pushmark s
# 14 <0> pushmark s
# 15 <#> gv[*george] s
# 16 <1> rv2av[t12] lK/1
# 17 <$> const[PV "to"] s
# 18 <#> gv[*harry] s
# 19 <1> rv2av[t14] lK/1
# 1a <@> sort lK
# 1b <@> print sK
# 1c <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1  <;> nextstate(main 602 (eval 32):2) v
# 2  <0> pushmark s
# 3  <$> const(PV "dog") s
# 4  <$> const(PV "cat") s
# 5  <$> const(PV "x") s
# 6  <$> const(PV "Cain") s
# 7  <$> const(PV "Abel") s
# 8  <0> pushmark s
# 9  <$> gv(*harry) s
# a  <1> rv2av[t1] lKRM*/1
# b  <2> aassign[t2] vKS
# c  <;> nextstate(main 602 (eval 32):3) v
# d  <0> pushmark s
# e  <$> const(PV "gone") s
# f  <$> const(PV "chased") s
# g  <$> const(PV "yz") s
# h  <$> const(PV "Punished") s
# i  <$> const(PV "Axed") s
# j  <0> pushmark s
# k  <$> gv(*george) s
# l  <1> rv2av[t3] lKRM*/1
# m  <2> aassign[t4] vKS
# n  <;> nextstate(main 602 (eval 32):4) v:{
# o  <0> pushmark s
# p  <0> pushmark s
# q  <$> gv(*harry) s
# r  <1> rv2av[t5] lK/1
# s  <@> sort lK
# t  <@> print vK
# u  <;> nextstate(main 602 (eval 32):4) v:{
# v  <0> pushmark s
# w  <0> pushmark s
# x  <$> const(PV "backwards") s/BARE
# y  <$> gv(*harry) s
# z  <1> rv2av[t6] lK/1
# 10 <@> sort lKS
# 11 <@> print vK
# 12 <;> nextstate(main 602 (eval 32):5) v:{
# 13 <0> pushmark s
# 14 <0> pushmark s
# 15 <$> gv(*george) s
# 16 <1> rv2av[t7] lK/1
# 17 <$> const(PV "to") s
# 18 <$> gv(*harry) s
# 19 <1> rv2av[t8] lK/1
# 1a <@> sort lK
# 1b <@> print sK
# 1c <1> leavesub[1 ref] K/REFC,1
EONT_EONT
    

=for gentest

# chunk: # inefficiently sort by descending numeric compare using
# the first integer after the first = sign, or the
# whole record case-insensitively otherwise
@new = @old[ sort {
    $nums[$b] <=> $nums[$a]
	|| $caps[$a] cmp $caps[$b]
	} 0..$#old  ];

=cut
=for gentest

# chunk: # same thing, but without any temps