f_sort.t

source of perl for linux application,

@new = map { $_->[0] }
sort { $b->[1] <=> $a->[1] 
	   || $a->[2] cmp $b->[2]
	   } map { [$_, /=(\d+)/, uc($_)] } @old;

=cut

checkOptree(name   => q{Compound sort/map Expression },
	    bcopts => q{-exec},
	    code   => q{ @new = map { $_->[0] }
			 sort { $b->[1] <=> $a->[1] || $a->[2] cmp $b->[2] }
			 map { [$_, /=(\d+)/, uc($_)] } @old; },
	    expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1  <;> nextstate(main 609 (eval 34):3) v:{
# 2  <0> pushmark s
# 3  <0> pushmark s
# 4  <0> pushmark s
# 5  <0> pushmark s
# 6  <#> gv[*old] s
# 7  <1> rv2av[t19] lKM/1
# 8  <@> mapstart lK*
# 9  <|> mapwhile(other->a)[t20] lK
# a      <0> enter l
# b      <;> nextstate(main 608 (eval 34):2) v:{
# c      <0> pushmark s
# d      <#> gvsv[*_] s
# e      </> match(/"=(\\d+)"/) l/RTIME
# f      <#> gvsv[*_] s
# g      <1> uc[t17] sK/1
# h      <@> anonlist sK*/1
# i      <@> leave lKP
#            goto 9
# j  <@> sort lKMS*
# k  <@> mapstart lK*
# l  <|> mapwhile(other->m)[t26] lK
# m      <#> gv[*_] s
# n      <1> rv2sv sKM/DREFAV,1
# o      <1> rv2av[t4] sKR/1
# p      <$> const[IV 0] s
# q      <2> aelem sK/2
# -      <@> scope lK
#            goto l
# r  <0> pushmark s
# s  <#> gv[*new] s
# t  <1> rv2av[t2] lKRM*/1
# u  <2> aassign[t27] KS/COMMON
# v  <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1  <;> nextstate(main 609 (eval 34):3) v:{
# 2  <0> pushmark s
# 3  <0> pushmark s
# 4  <0> pushmark s
# 5  <0> pushmark s
# 6  <$> gv(*old) s
# 7  <1> rv2av[t10] lKM/1
# 8  <@> mapstart lK*
# 9  <|> mapwhile(other->a)[t11] lK
# a      <0> enter l
# b      <;> nextstate(main 608 (eval 34):2) v:{
# c      <0> pushmark s
# d      <$> gvsv(*_) s
# e      </> match(/"=(\\d+)"/) l/RTIME
# f      <$> gvsv(*_) s
# g      <1> uc[t9] sK/1
# h      <@> anonlist sK*/1
# i      <@> leave lKP
#            goto 9
# j  <@> sort lKMS*
# k  <@> mapstart lK*
# l  <|> mapwhile(other->m)[t12] lK
# m      <$> gv(*_) s
# n      <1> rv2sv sKM/DREFAV,1
# o      <1> rv2av[t2] sKR/1
# p      <$> const(IV 0) s
# q      <2> aelem sK/2
# -      <@> scope lK
#            goto l
# r  <0> pushmark s
# s  <$> gv(*new) s
# t  <1> rv2av[t1] lKRM*/1
# u  <2> aassign[t13] KS/COMMON
# v  <1> leavesub[1 ref] K/REFC,1
EONT_EONT
    

=for gentest

# chunk: # using a prototype allows you to use any comparison subroutine
# as a sort subroutine (including other package's subroutines)
package other;
sub backwards ($$) { $_[1] cmp $_[0]; }     # $a and $b are not set here
package main;
@new = sort other::backwards @old;

=cut

checkOptree(name   => q{sort other::sub LIST },
	    bcopts => q{-exec},
	    code   => q{package other; sub backwards ($$) { $_[1] cmp $_[0]; }
			package main; @new = sort other::backwards @old; },
	    expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1  <;> nextstate(main 614 (eval 36):2) v:{
# 2  <0> pushmark s
# 3  <0> pushmark s
# 4  <$> const[PV "other::backwards"] s/BARE
# 5  <#> gv[*old] s
# 6  <1> rv2av[t4] lK/1
# 7  <@> sort lKS
# 8  <0> pushmark s
# 9  <#> gv[*new] 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 614 (eval 36):2) v:{
# 2  <0> pushmark s
# 3  <0> pushmark s
# 4  <$> const(PV "other::backwards") s/BARE
# 5  <$> gv(*old) s
# 6  <1> rv2av[t2] lK/1
# 7  <@> sort lKS
# 8  <0> pushmark s
# 9  <$> gv(*new) 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: # repeat, condensed. $main::a and $b are unaffected
sub other::backwards ($$) { $_[1] cmp $_[0]; }
@new = sort other::backwards @old;

=cut

checkOptree(note   => q{},
	    bcopts => q{-exec},
	    code   => q{sub other::backwards ($$) { $_[1] cmp $_[0]; } @new = sort other::backwards @old; },
	    expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1  <;> nextstate(main 619 (eval 38):1) v
# 2  <0> pushmark s
# 3  <0> pushmark s
# 4  <$> const[PV "other::backwards"] s/BARE
# 5  <#> gv[*old] s
# 6  <1> rv2av[t4] lK/1
# 7  <@> sort lKS
# 8  <0> pushmark s
# 9  <#> gv[*new] 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 "other::backwards") s/BARE
# 5  <$> gv(*old) s
# 6  <1> rv2av[t2] lK/1
# 7  <@> sort lKS
# 8  <0> pushmark s
# 9  <$> gv(*new) 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: # guarantee stability, regardless of algorithm
use sort 'stable';
@new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old;

=cut

my ($expect, $expect_nt) = (<<'EOT_EOT', <<'EONT_EONT');
# 1  <;> nextstate(main 656 (eval 40):1) v:%,{
# 2  <0> pushmark s
# 3  <0> pushmark s
# 4  <#> gv[*old] s
# 5  <1> rv2av[t9] lK/1
# 6  <@> sort lKS*/STABLE
# 7  <0> pushmark s
# 8  <#> gv[*new] s
# 9  <1> rv2av[t2] lKRM*/1
# a  <2> aassign[t14] KS/COMMON
# b  <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1  <;> nextstate(main 578 (eval 15):1) v:%,{
# 2  <0> pushmark s
# 3  <0> pushmark s
# 4  <$> gv(*old) s
# 5  <1> rv2av[t5] lK/1
# 6  <@> sort lKS*/STABLE
# 7  <0> pushmark s
# 8  <$> gv(*new) s
# 9  <1> rv2av[t1] lKRM*/1
# a  <2> aassign[t6] KS/COMMON
# b  <1> leavesub[1 ref] K/REFC,1
EONT_EONT

if($] < 5.009) {
    # 5.8.x doesn't show the /STABLE flag, so massage the golden results.
    s!/STABLE!!s foreach ($expect, $expect_nt);
}

checkOptree(note   => q{},
	    bcopts => q{-exec},
	    code   => q{use sort 'stable'; @new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old; },
	    expect => $expect, expect_nt => $expect_nt);

=for gentest

# chunk: # force use of mergesort (not portable outside Perl 5.8)
use sort '_mergesort';
@new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old;

=cut

checkOptree(note   => q{},
	    bcopts => q{-exec},
	    code   => q{use sort '_mergesort'; @new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old; },
	    expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1  <;> nextstate(main 662 (eval 42):1) v:%,{
# 2  <0> pushmark s
# 3  <0> pushmark s
# 4  <#> gv[*old] s
# 5  <1> rv2av[t9] lK/1
# 6  <@> sort lKS*
# 7  <0> pushmark s
# 8  <#> gv[*new] s
# 9  <1> rv2av[t2] lKRM*/1
# a  <2> aassign[t14] KS/COMMON
# b  <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1  <;> nextstate(main 578 (eval 15):1) v:%,{
# 2  <0> pushmark s
# 3  <0> pushmark s
# 4  <$> gv(*old) s
# 5  <1> rv2av[t5] lK/1
# 6  <@> sort lKS*
# 7  <0> pushmark s
# 8  <$> gv(*new) 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: # you should have a good reason to do this!
@articles = sort {$FooPack::b <=> $FooPack::a} @files;

=cut

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

=for gentest

# chunk: # fancy
@result = sort { $a <=> $b } grep { $_ == $_ } @input;

=cut

checkOptree(note   => q{},
	    bcopts => q{-exec},
	    code   => q{@result = sort { $a <=> $b } grep { $_ == $_ } @input; },
	    expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1  <;> nextstate(main 673 (eval 46):1) v
# 2  <0> pushmark s
# 3  <0> pushmark s
# 4  <0> pushmark s
# 5  <#> gv[*input] s
# 6  <1> rv2av[t9] lKM/1
# 7  <@> grepstart lK*
# 8  <|> grepwhile(other->9)[t10] lK
# 9      <#> gvsv[*_] s
# a      <#> gvsv[*_] s
# b      <2> eq sK/2
# -      <@> scope sK
#            goto 8
# c  <@> sort lK/NUM
# d  <0> pushmark s
# e  <#> gv[*result] s
# f  <1> rv2av[t2] lKRM*/1
# g  <2> aassign[t3] KS/COMMON
# h  <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1  <;> nextstate(main 547 (eval 15):1) v
# 2  <0> pushmark s
# 3  <0> pushmark s
# 4  <0> pushmark s
# 5  <$> gv(*input) s
# 6  <1> rv2av[t3] lKM/1
# 7  <@> grepstart lK*
# 8  <|> grepwhile(other->9)[t4] lK
# 9      <$> gvsv(*_) s
# a      <$> gvsv(*_) s
# b      <2> eq sK/2
# -      <@> scope sK
#            goto 8
# c  <@> sort lK/NUM
# d  <0> pushmark s
# e  <$> gv(*result) s
# f  <1> rv2av[t1] lKRM*/1
# g  <2> aassign[t2] KS/COMMON
# h  <1> leavesub[1 ref] K/REFC,1
EONT_EONT
    

=for gentest

# chunk: # void return context sort
sort { $a <=> $b } @input;

=cut

checkOptree(note   => q{},
	    bcopts => q{-exec},
	    code   => q{sort { $a <=> $b } @input; },
	    expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1  <;> nextstate(main 678 (eval 48):1) v
# 2  <0> pushmark s
# 3  <#> gv[*input] s
# 4  <1> rv2av[t5] lK/1
# 5  <@> sort K/NUM
# 6  <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1  <;> nextstate(main 546 (eval 15):1) v
# 2  <0> pushmark s
# 3  <$> gv(*input) s
# 4  <1> rv2av[t2] lK/1
# 5  <@> sort K/NUM
# 6  <1> leavesub[1 ref] K/REFC,1
EONT_EONT
    

=for gentest

# chunk: # more void context, propagating ?
sort { $a <=> $b } grep { $_ == $_ } @input;

=cut

checkOptree(note   => q{},
	    bcopts => q{-exec},
	    code   => q{sort { $a <=> $b } grep { $_ == $_ } @input; },
	    expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1  <;> nextstate(main 684 (eval 50):1) v
# 2  <0> pushmark s
# 3  <0> pushmark s
# 4  <#> gv[*input] s
# 5  <1> rv2av[t7] lKM/1
# 6  <@> grepstart lK*
# 7  <|> grepwhile(other->8)[t8] lK
# 8      <#> gvsv[*_] s
# 9      <#> gvsv[*_] s
# a      <2> eq sK/2
# -      <@> scope sK
#            goto 7
# b  <@> sort K/NUM
# c  <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1  <;> nextstate(main 547 (eval 15):1) v
# 2  <0> pushmark s
# 3  <0> pushmark s
# 4  <$> gv(*input) s
# 5  <1> rv2av[t2] lKM/1
# 6  <@> grepstart lK*
# 7  <|> grepwhile(other->8)[t3] lK
# 8      <$> gvsv(*_) s
# 9      <$> gvsv(*_) s
# a      <2> eq sK/2
# -      <@> scope sK
#            goto 7
# b  <@> sort K/NUM
# c  <1> leavesub[1 ref] K/REFC,1
EONT_EONT
    

=for gentest

# chunk: # scalar return context sort
$s = sort { $a <=> $b } @input;

=cut

checkOptree(note   => q{},
	    bcopts => q{-exec},
	    code   => q{$s = sort { $a <=> $b } @input; },
	    expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1  <;> nextstate(main 689 (eval 52):1) v:{
# 2  <0> pushmark s
# 3  <#> gv[*input] s
# 4  <1> rv2av[t6] lK/1
# 5  <@> sort sK/NUM
# 6  <#> gvsv[*s] s
# 7  <2> sassign sKS/2
# 8  <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1  <;> nextstate(main 546 (eval 15):1) v:{
# 2  <0> pushmark s
# 3  <$> gv(*input) s
# 4  <1> rv2av[t2] lK/1
# 5  <@> sort sK/NUM
# 6  <$> gvsv(*s) s
# 7  <2> sassign sKS/2
# 8  <1> leavesub[1 ref] K/REFC,1
EONT_EONT
    

=for gentest

# chunk: $s = sort { $a <=> $b } grep { $_ == $_ } @input;

=cut

checkOptree(note   => q{},
	    bcopts => q{-exec},
	    code   => q{$s = sort { $a <=> $b } grep { $_ == $_ } @input; },
	    expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1  <;> nextstate(main 695 (eval 54):1) v:{
# 2  <0> pushmark s
# 3  <0> pushmark s
# 4  <#> gv[*input] s
# 5  <1> rv2av[t8] lKM/1
# 6  <@> grepstart lK*
# 7  <|> grepwhile(other->8)[t9] lK
# 8      <#> gvsv[*_] s
# 9      <#> gvsv[*_] s
# a      <2> eq sK/2
# -      <@> scope sK
#            goto 7
# b  <@> sort sK/NUM
# c  <#> gvsv[*s] s
# d  <2> sassign sKS/2
# e  <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1  <;> nextstate(main 547 (eval 15):1) v:{
# 2  <0> pushmark s
# 3  <0> pushmark s
# 4  <$> gv(*input) s
# 5  <1> rv2av[t2] lKM/1
# 6  <@> grepstart lK*
# 7  <|> grepwhile(other->8)[t3] lK
# 8      <$> gvsv(*_) s
# 9      <$> gvsv(*_) s
# a      <2> eq sK/2
# -      <@> scope sK
#            goto 7
# b  <@> sort sK/NUM
# c  <$> gvsv(*s) s
# d  <2> sassign sKS/2
# e  <1> leavesub[1 ref] K/REFC,1
EONT_EONT