dslinux/user/perl/ext/B/t OptreeCheck.pm asmdata.t assembler.t b.t bblock.t bytecode.t concise-xs.t concise.t debug.t deparse.t f_map f_map.t f_sort f_sort.t lint.t o.t optree_check.t optree_concise.t optree_samples.t optree_sort.t optree_specials.t optree_varinit.t showlex.t stash.t terse.t xref.t
cayenne
dslinux_cayenne at user.in-berlin.de
Mon Dec 4 17:59:09 CET 2006
Update of /cvsroot/dslinux/dslinux/user/perl/ext/B/t
In directory antilope:/tmp/cvs-serv17422/ext/B/t
Added Files:
OptreeCheck.pm asmdata.t assembler.t b.t bblock.t bytecode.t
concise-xs.t concise.t debug.t deparse.t f_map f_map.t f_sort
f_sort.t lint.t o.t optree_check.t optree_concise.t
optree_samples.t optree_sort.t optree_specials.t
optree_varinit.t showlex.t stash.t terse.t xref.t
Log Message:
Adding fresh perl source to HEAD to branch from
--- NEW FILE: assembler.t ---
#!./perl -w
=pod
=head1 TEST FOR B::Assembler.pm AND B::Disassembler.pm
=head2 Description
The general idea is to test by assembling a choice set of assembler
instructions, then disassemble them, and check that we've completed the
round trip. Also, error checking of Assembler.pm is tested by feeding
it assorted errors.
Since Assembler.pm likes to assemble a file, we comply by writing a
text file. This file contains three sections:
testing operand categories
use each opcode
erronous assembler instructions
An "operand category" is identified by the suffix of the PUT_/GET_
subroutines as shown in the C<%Asmdata::insn_data> initialization, e.g.
opcode C<ldsv> has operand category C<svindex>:
insn_data{ldsv} = [1, \&PUT_svindex, "GET_svindex"];
Because Disassembler.pm also assumes input from a file, we write the
resulting object code to a file. And disassembled output is written to
yet another text file which is then compared to the original input.
(Erronous assembler instructions still generate code, but this is not
written to the object file; therefore disassembly bails out at the first
instruction in error.)
All files are kept in memory by using TIEHASH.
=head2 Caveats
An error where Assembler.pm and Disassembler.pm agree but Assembler.pm
generates invalid object code will not be detected.
Due to the way this test has been set up, failure of a single test
could cause all subsequent tests to fail as well: After an unexpected
assembler error no output is written, and disassembled lines will be
out of sync for all lines thereafter.
Not all possibilities for writing a valid operand value can be tested
because disassembly results in a uniform representation.
=head2 Maintenance
New opcodes are added automatically.
A new operand category will cause this program to die ("no operand list
for XXX"). The cure is to add suitable entries to C<%goodlist> and
C<%badlist>. (Since the data in Asmdata.pm is autogenerated, it may also
happen that the corresponding assembly or disassembly subroutine is
missing.) Note that an empty array as a C<%goodlist> entry means that
opcodes of the operand category do not take an operand (and therefore the
corresponding entry in C<%badlist> should have one). An C<undef> entry
in C<%badlist> means that any value is acceptable (and thus there is no
way to cause an error).
Set C<$dbg> to debug this test.
=cut
package VirtFile;
use strict;
# Note: This is NOT a general purpose package. It implements
# sequential text and binary file i/o in a rather simple form.
sub TIEHANDLE($;$){
my( $class, $data ) = @_;
my $obj = { data => defined( $data ) ? $data : '',
pos => 0 };
return bless( $obj, $class );
}
sub PRINT($@){
my( $self ) = shift;
$self->{data} .= join( '', @_ );
}
sub WRITE($$;$$){
my( $self, $buf, $len, $offset ) = @_;
unless( defined( $len ) ){
$len = length( $buf );
$offset = 0;
}
unless( defined( $offset ) ){
$offset = 0;
}
$self->{data} .= substr( $buf, $offset, $len );
return $len;
}
sub GETC($){
my( $self ) = @_;
return undef() if $self->{pos} >= length( $self->{data} );
return substr( $self->{data}, $self->{pos}++, 1 );
}
sub READLINE($){
my( $self ) = @_;
return undef() if $self->{pos} >= length( $self->{data} );
my $lfpos = index( $self->{data}, "\n", $self->{pos} );
if( $lfpos < 0 ){
$lfpos = length( $self->{data} );
}
my $pos = $self->{pos};
$self->{pos} = $lfpos + 1;
return substr( $self->{data}, $pos, $self->{pos} - $pos );
}
sub READ($@){
my $self = shift();
my $bufref = \$_[0];
my( undef, $len, $offset ) = @_;
if( $offset ){
die( "offset beyond end of buffer\n" )
if ! defined( $$bufref ) || $offset > length( $$bufref );
} else {
$$bufref = '';
$offset = 0;
}
my $remlen = length( $self->{data} ) - $self->{pos};
$len = $remlen if $remlen < $len;
return 0 unless $len;
substr( $$bufref, $offset, $len ) =
substr( $self->{data}, $self->{pos}, $len );
$self->{pos} += $len;
return $len;
}
sub TELL($){
my $self = shift();
return $self->{pos};
}
sub CLOSE($){
my( $self ) = @_;
$self->{pos} = 0;
}
1;
package main;
use strict;
use Test::More;
use Config qw(%Config);
BEGIN {
if (($Config{'extensions'} !~ /\bB\b/) ){
print "1..0 # Skip -- Perl configured without B module\n";
exit 0;
}
if (($Config{'extensions'} !~ /\bByteLoader\b/) ){
print "1..0 # Skip -- Perl configured without ByteLoader module\n";
exit 0;
}
}
use B::Asmdata qw( %insn_data );
use B::Assembler qw( &assemble_fh );
use B::Disassembler qw( &disassemble_fh &get_header );
my( %opsByType, @code2name );
my( $lineno, $dbg, $firstbadline, @descr );
$dbg = 0; # debug switch
# $SIG{__WARN__} handler to catch Assembler error messages
#
my $warnmsg;
sub catchwarn($){
$warnmsg = $_[0];
print "error: $warnmsg\n" if $dbg;
}
# Callback for writing assembled bytes. This is where we check
# that we do get an error.
#
sub putobj($){
if( ++$lineno >= $firstbadline ){
ok( $warnmsg && $warnmsg =~ /^\d+:\s/, $descr[$lineno] );
undef( $warnmsg );
} else {
my $l = syswrite( OBJ, $_[0] );
}
}
# Callback for writing a disassembled statement.
#
sub putdis(@){
my $line = join( ' ', @_ );
++$lineno;
print DIS "$line\n";
printf "%5d %s\n", $lineno, $line if $dbg;
}
# Generate assembler instructions from a hash of operand types: each
# existing entry contains a list of good or bad operand values. The
# corresponding opcodes can be found in %opsByType.
#
sub gen_type($$$){
my( $href, $descref, $text ) = @_;
for my $odt ( sort( keys( %opsByType ) ) ){
my $opcode = $opsByType{$odt}->[0];
my $sel = $odt;
$sel =~ s/^GET_//;
die( "no operand list for $sel\n" ) unless exists( $href->{$sel} );
if( defined( $href->{$sel} ) ){
if( @{$href->{$sel}} ){
for my $od ( @{$href->{$sel}} ){
++$lineno;
$descref->[$lineno] = "$text: $code2name[$opcode] $od";
print ASM "$code2name[$opcode] $od\n";
printf "%5d %s %s\n", $lineno, $code2name[$opcode], $od if $dbg;
}
} else {
++$lineno;
$descref->[$lineno] = "$text: $code2name[$opcode]";
print ASM "$code2name[$opcode]\n";
printf "%5d %s\n", $lineno, $code2name[$opcode] if $dbg;
}
}
}
}
# Interesting operand values
#
my %goodlist = (
comment_t => [ '"a comment"' ], # no \n
none => [],
svindex => [ 0x7fffffff, 0 ],
opindex => [ 0x7fffffff, 0 ],
pvindex => [ 0x7fffffff, 0 ],
U32 => [ 0xffffffff, 0 ],
U8 => [ 0xff, 0 ],
PV => [ '""', '"a string"', ],
I32 => [ -0x80000000, 0x7fffffff ],
IV64 => [ '0x000000000', '0x0ffffffff', '0x000000001' ], # disass formats 0x%09x
IV => $Config{ivsize} == 4 ?
[ -0x80000000, 0x7fffffff ] :
[ '0x000000000', '0x0ffffffff', '0x000000001' ],
NV => [ 1.23456789E3 ],
U16 => [ 0xffff, 0 ],
pvcontents => [],
strconst => [ '""', '"another string"' ], # no NUL
op_tr_array => [ join( ',', 256, 0..255 ) ],
PADOFFSET => undef,
long => undef,
);
# Erronous operand values
#
my %badlist = (
comment_t => [ '"multi-line\ncomment"' ], # no \n
none => [ '"spurious arg"' ],
svindex => [ 0xffffffff * 2, -1 ],
opindex => [ 0xffffffff * 2, -2 ],
pvindex => [ 0xffffffff * 2, -3 ],
U32 => [ 0xffffffff * 2, -4 ],
U16 => [ 0x5ffff, -5 ],
U8 => [ 0x6ff, -6 ],
PV => [ 'no quote"' ],
I32 => [ -0x80000001, 0x80000000 ],
IV64 => undef, # PUT_IV64 doesn't check - no integrity there
IV => $Config{ivsize} == 4 ?
[ -0x80000001, 0x80000000 ] : undef,
NV => undef, # PUT_NV accepts anything - it shouldn't, real-ly
pvcontents => [ '"spurious arg"' ],
strconst => [ 'no quote"', '"with NUL '."\0".' char"' ], # no NUL
op_tr_array => undef, # op_pv_tr is no longer exactly 256 shorts
PADOFFSET => undef,
long => undef,
);
# Determine all operand types from %Asmdata::insn_data
#
for my $opname ( keys( %insn_data ) ){
my ( $opcode, $put, $getname ) = @{$insn_data{$opname}};
push( @{$opsByType{$getname}}, $opcode );
$code2name[$opcode] = $opname;
}
# Write instruction(s) for correct operand values each operand type class
#
$lineno = 0;
tie( *ASM, 'VirtFile' );
gen_type( \%goodlist, \@descr, 'round trip' );
# Write one instruction for each opcode.
#
for my $opcode ( 0..$#code2name ){
next unless defined( $code2name[$opcode] );
my $sel = $insn_data{$code2name[$opcode]}->[2];
$sel =~ s/^GET_//;
die( "no operand list for $sel\n" ) unless exists( $goodlist{$sel} );
if( defined( $goodlist{$sel} ) ){
++$lineno;
if( @{$goodlist{$sel}} ){
my $od = $goodlist{$sel}[0];
$descr[$lineno] = "round trip: $code2name[$opcode] $od";
print ASM "$code2name[$opcode] $od\n";
printf "%5d %s %s\n", $lineno, $code2name[$opcode], $od if $dbg;
} else {
$descr[$lineno] = "round trip: $code2name[$opcode]";
print ASM "$code2name[$opcode]\n";
printf "%5d %s\n", $lineno, $code2name[$opcode] if $dbg;
}
}
}
# Write instruction(s) for incorrect operand values each operand type class
#
$firstbadline = $lineno + 1;
gen_type( \%badlist, \@descr, 'asm error' );
# invalid opcode is an odd-man-out ;-)
#
++$lineno;
$descr[$lineno] = "asm error: Gollum";
print ASM "Gollum\n";
printf "%5d %s\n", $lineno, 'Gollum' if $dbg;
close( ASM );
# Now that we have defined all of our tests: plan
#
plan( tests => $lineno );
print "firstbadline=$firstbadline\n" if $dbg;
# assemble (guard against warnings and death from assembly errors)
#
$SIG{'__WARN__'} = \&catchwarn;
$lineno = -1; # account for the assembly header
tie( *OBJ, 'VirtFile' );
eval { assemble_fh( \*ASM, \&putobj ); };
print "eval: $@" if $dbg;
close( ASM );
close( OBJ );
$SIG{'__WARN__'} = 'DEFAULT';
# disassemble
#
print "--- disassembling ---\n" if $dbg;
$lineno = 0;
tie( *DIS, 'VirtFile' );
disassemble_fh( \*OBJ, \&putdis );
close( OBJ );
close( DIS );
# get header (for debugging only)
#
if( $dbg ){
my( $magic, $archname, $blversion, $ivsize, $ptrsize, $byteorder ) =
get_header();
printf "Magic: 0x%08x\n", $magic;
print "Architecture: $archname\n";
print "Byteloader V: $blversion\n";
print "ivsize: $ivsize\n";
print "ptrsize: $ptrsize\n";
print "Byteorder: $byteorder\n";
}
# check by comparing files line by line
#
print "--- checking ---\n" if $dbg;
$lineno = 0;
my( $asmline, $disline );
while( defined( $asmline = <ASM> ) ){
$disline = <DIS>;
++$lineno;
last if $lineno eq $firstbadline; # bail out where errors begin
ok( $asmline eq $disline, $descr[$lineno] );
printf "%5d %s\n", $lineno, $asmline if $dbg;
}
close( ASM );
close( DIS );
__END__
--- NEW FILE: f_map.t ---
#!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 => 9;
=head1 f_map.t
Code test snippets here are adapted from `perldoc -f map`
Due to a bleadperl optimization (Dave Mitchell, circa may 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.
=for gentest
# chunk: #!perl
# examples shamelessly snatched from perldoc -f map
=cut
=for gentest
# chunk: # translates a list of numbers to the corresponding characters.
@chars = map(chr, @nums);
=cut
checkOptree(note => q{},
bcopts => q{-exec},
code => q{@chars = map(chr, @nums); },
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1 <;> nextstate(main 475 (eval 10):1) v
# 2 <0> pushmark s
# 3 <0> pushmark s
# 4 <#> gv[*nums] s
# 5 <1> rv2av[t7] lKM/1
# 6 <@> mapstart lK
# 7 <|> mapwhile(other->8)[t8] lK
# 8 <#> gvsv[*_] s
# 9 <1> chr[t5] sK/1
# goto 7
# a <0> pushmark s
# b <#> gv[*chars] s
# c <1> rv2av[t2] lKRM*/1
# d <2> aassign[t9] KS/COMMON
# e <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 559 (eval 15):1) v
# 2 <0> pushmark s
# 3 <0> pushmark s
# 4 <$> gv(*nums) s
# 5 <1> rv2av[t4] lKM/1
# 6 <@> mapstart lK
# 7 <|> mapwhile(other->8)[t5] lK
# 8 <$> gvsv(*_) s
# 9 <1> chr[t3] sK/1
# goto 7
# a <0> pushmark s
# b <$> gv(*chars) s
# c <1> rv2av[t1] lKRM*/1
# d <2> aassign[t6] KS/COMMON
# e <1> leavesub[1 ref] K/REFC,1
EONT_EONT
=for gentest
# chunk: %hash = map { getkey($_) => $_ } @array;
=cut
checkOptree(note => q{},
bcopts => q{-exec},
code => q{%hash = map { getkey($_) => $_ } @array; },
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1 <;> nextstate(main 476 (eval 10):1) v
# 2 <0> pushmark s
# 3 <0> pushmark s
# 4 <#> gv[*array] s
# 5 <1> rv2av[t8] lKM/1
# 6 <@> mapstart lK*
# 7 <|> mapwhile(other->8)[t9] lK
# 8 <0> enter l
# 9 <;> nextstate(main 475 (eval 10):1) v
# a <0> pushmark s
# b <0> pushmark s
# c <#> gvsv[*_] s
# d <#> gv[*getkey] s/EARLYCV
# e <1> entersub[t5] lKS/TARG,1
# f <#> gvsv[*_] s
# g <@> list lK
# h <@> leave lKP
# goto 7
# i <0> pushmark s
# j <#> gv[*hash] s
# k <1> rv2hv[t2] lKRM*/1
# l <2> aassign[t10] KS/COMMON
# m <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 560 (eval 15):1) v
# 2 <0> pushmark s
# 3 <0> pushmark s
# 4 <$> gv(*array) s
# 5 <1> rv2av[t3] lKM/1
# 6 <@> mapstart lK*
# 7 <|> mapwhile(other->8)[t4] lK
# 8 <0> enter l
# 9 <;> nextstate(main 559 (eval 15):1) v
# a <0> pushmark s
# b <0> pushmark s
# c <$> gvsv(*_) s
# d <$> gv(*getkey) s/EARLYCV
# e <1> entersub[t2] lKS/TARG,1
# f <$> gvsv(*_) s
# g <@> list lK
# h <@> leave lKP
# goto 7
# i <0> pushmark s
# j <$> gv(*hash) s
# k <1> rv2hv[t1] lKRM*/1
# l <2> aassign[t5] KS/COMMON
# m <1> leavesub[1 ref] K/REFC,1
EONT_EONT
=for gentest
# chunk: {
%hash = ();
foreach $_ (@array) {
$hash{getkey($_)} = $_;
}
}
=cut
checkOptree(note => q{},
bcopts => q{-exec},
code => q{{ %hash = (); foreach $_ (@array) { $hash{getkey($_)} = $_; } } },
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1 <;> nextstate(main 478 (eval 10):1) v
# 2 <{> enterloop(next->u last->u redo->3)
# 3 <;> nextstate(main 475 (eval 10):1) v
# 4 <0> pushmark s
# 5 <0> pushmark s
# 6 <#> gv[*hash] s
# 7 <1> rv2hv[t2] lKRM*/1
# 8 <2> aassign[t3] vKS
# 9 <;> nextstate(main 476 (eval 10):1) v
# a <0> pushmark sM
# b <#> gv[*array] s
# c <1> rv2av[t6] sKRM/1
# d <#> gv[*_] s
# e <1> rv2gv sKRM/1
# f <{> enteriter(next->q last->t redo->g) lKS
# r <0> iter s
# s <|> and(other->g) K/1
# g <;> nextstate(main 475 (eval 10):1) v
# h <#> gvsv[*_] s
# i <#> gv[*hash] s
# j <1> rv2hv sKR/1
# k <0> pushmark s
# l <#> gvsv[*_] s
# m <#> gv[*getkey] s/EARLYCV
# n <1> entersub[t10] sKS/TARG,1
# o <2> helem sKRM*/2
# p <2> sassign vKS/2
# q <0> unstack s
# goto r
# t <2> leaveloop K/2
# u <2> leaveloop K/2
# v <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 562 (eval 15):1) v
# 2 <{> enterloop(next->u last->u redo->3)
# 3 <;> nextstate(main 559 (eval 15):1) v
# 4 <0> pushmark s
# 5 <0> pushmark s
# 6 <$> gv(*hash) s
# 7 <1> rv2hv[t1] lKRM*/1
# 8 <2> aassign[t2] vKS
# 9 <;> nextstate(main 560 (eval 15):1) v
# a <0> pushmark sM
# b <$> gv(*array) s
# c <1> rv2av[t3] sKRM/1
# d <$> gv(*_) s
# e <1> rv2gv sKRM/1
# f <{> enteriter(next->q last->t redo->g) lKS
# r <0> iter s
# s <|> and(other->g) K/1
# g <;> nextstate(main 559 (eval 15):1) v
# h <$> gvsv(*_) s
# i <$> gv(*hash) s
# j <1> rv2hv sKR/1
# k <0> pushmark s
# l <$> gvsv(*_) s
# m <$> gv(*getkey) s/EARLYCV
# n <1> entersub[t4] sKS/TARG,1
# o <2> helem sKRM*/2
# p <2> sassign vKS/2
# q <0> unstack s
# goto r
# t <2> leaveloop K/2
# u <2> leaveloop K/2
# v <1> leavesub[1 ref] K/REFC,1
EONT_EONT
=for gentest
# chunk: #%hash = map { "\L$_", 1 } @array; # perl guesses EXPR. wrong
%hash = map { +"\L$_", 1 } @array; # perl guesses BLOCK. right
=cut
checkOptree(note => q{},
bcopts => q{-exec},
code => q{%hash = map { +"\L$_", 1 } @array; },
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1 <;> nextstate(main 476 (eval 10):1) v
# 2 <0> pushmark s
# 3 <0> pushmark s
# 4 <#> gv[*array] s
# 5 <1> rv2av[t7] lKM/1
# 6 <@> mapstart lK*
# 7 <|> mapwhile(other->8)[t9] lK
# 8 <0> pushmark s
# 9 <#> gvsv[*_] s
# a <1> lc[t4] sK/1
# b <@> stringify[t5] sK/1
# c <$> const[IV 1] s
# d <@> list lK
# - <@> scope lK
# goto 7
# e <0> pushmark s
# f <#> gv[*hash] s
# g <1> rv2hv[t2] lKRM*/1
# h <2> aassign[t10] KS/COMMON
# i <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 560 (eval 15):1) v
# 2 <0> pushmark s
# 3 <0> pushmark s
# 4 <$> gv(*array) s
# 5 <1> rv2av[t4] lKM/1
# 6 <@> mapstart lK*
# 7 <|> mapwhile(other->8)[t5] lK
# 8 <0> pushmark s
# 9 <$> gvsv(*_) s
# a <1> lc[t2] sK/1
# b <@> stringify[t3] sK/1
# c <$> const(IV 1) s
# d <@> list lK
# - <@> scope lK
# goto 7
# e <0> pushmark s
# f <$> gv(*hash) s
# g <1> rv2hv[t1] lKRM*/1
# h <2> aassign[t6] KS/COMMON
# i <1> leavesub[1 ref] K/REFC,1
EONT_EONT
=for gentest
# chunk: %hash = map { ("\L$_", 1) } @array; # this also works
=cut
checkOptree(note => q{},
bcopts => q{-exec},
code => q{%hash = map { ("\L$_", 1) } @array; },
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1 <;> nextstate(main 476 (eval 10):1) v
# 2 <0> pushmark s
# 3 <0> pushmark s
# 4 <#> gv[*array] s
# 5 <1> rv2av[t7] lKM/1
# 6 <@> mapstart lK*
# 7 <|> mapwhile(other->8)[t9] lK
# 8 <0> pushmark s
# 9 <#> gvsv[*_] s
# a <1> lc[t4] sK/1
# b <@> stringify[t5] sK/1
# c <$> const[IV 1] s
# d <@> list lKP
# - <@> scope lK
# goto 7
# e <0> pushmark s
# f <#> gv[*hash] s
# g <1> rv2hv[t2] lKRM*/1
# h <2> aassign[t10] KS/COMMON
# i <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 560 (eval 15):1) v
# 2 <0> pushmark s
# 3 <0> pushmark s
# 4 <$> gv(*array) s
# 5 <1> rv2av[t4] lKM/1
# 6 <@> mapstart lK*
# 7 <|> mapwhile(other->8)[t5] lK
# 8 <0> pushmark s
# 9 <$> gvsv(*_) s
# a <1> lc[t2] sK/1
# b <@> stringify[t3] sK/1
# c <$> const(IV 1) s
# d <@> list lKP
# - <@> scope lK
# goto 7
# e <0> pushmark s
# f <$> gv(*hash) s
# g <1> rv2hv[t1] lKRM*/1
# h <2> aassign[t6] KS/COMMON
# i <1> leavesub[1 ref] K/REFC,1
EONT_EONT
=for gentest
# chunk: %hash = map { lc($_), 1 } @array; # as does this.
=cut
checkOptree(note => q{},
bcopts => q{-exec},
code => q{%hash = map { lc($_), 1 } @array; },
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1 <;> nextstate(main 476 (eval 10):1) v
# 2 <0> pushmark s
# 3 <0> pushmark s
# 4 <#> gv[*array] s
# 5 <1> rv2av[t6] lKM/1
# 6 <@> mapstart lK*
# 7 <|> mapwhile(other->8)[t8] lK
# 8 <0> pushmark s
# 9 <#> gvsv[*_] s
# a <1> lc[t4] sK/1
# b <$> const[IV 1] s
# c <@> list lK
# - <@> scope lK
# goto 7
# d <0> pushmark s
# e <#> gv[*hash] s
# f <1> rv2hv[t2] lKRM*/1
# g <2> aassign[t9] KS/COMMON
# h <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 589 (eval 26):1) v
# 2 <0> pushmark s
# 3 <0> pushmark s
# 4 <$> gv(*array) s
# 5 <1> rv2av[t3] lKM/1
# 6 <@> mapstart lK*
# 7 <|> mapwhile(other->8)[t4] lK
# 8 <0> pushmark s
# 9 <$> gvsv(*_) s
# a <1> lc[t2] sK/1
# b <$> const(IV 1) s
# c <@> list lK
# - <@> scope lK
# goto 7
# d <0> pushmark s
# e <$> gv(*hash) s
# f <1> rv2hv[t1] lKRM*/1
# g <2> aassign[t5] KS/COMMON
# h <1> leavesub[1 ref] K/REFC,1
EONT_EONT
=for gentest
# chunk: %hash = map +( lc($_), 1 ), @array; # this is EXPR and works!
=cut
checkOptree(note => q{},
bcopts => q{-exec},
code => q{%hash = map +( lc($_), 1 ), @array; },
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1 <;> nextstate(main 475 (eval 10):1) v
# 2 <0> pushmark s
# 3 <0> pushmark s
# 4 <#> gv[*array] s
# 5 <1> rv2av[t6] lKM/1
# 6 <@> mapstart lK
# 7 <|> mapwhile(other->8)[t7] lK
# 8 <0> pushmark s
# 9 <#> gvsv[*_] s
# a <1> lc[t4] sK/1
# b <$> const[IV 1] s
# c <@> list lKP
# goto 7
# d <0> pushmark s
# e <#> gv[*hash] s
# f <1> rv2hv[t2] lKRM*/1
# g <2> aassign[t8] KS/COMMON
# h <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 593 (eval 28):1) v
# 2 <0> pushmark s
# 3 <0> pushmark s
# 4 <$> gv(*array) s
# 5 <1> rv2av[t3] lKM/1
# 6 <@> mapstart lK
# 7 <|> mapwhile(other->8)[t4] lK
# 8 <0> pushmark s
# 9 <$> gvsv(*_) s
# a <1> lc[t2] sK/1
# b <$> const(IV 1) s
# c <@> list lKP
# goto 7
# d <0> pushmark s
# e <$> gv(*hash) s
# f <1> rv2hv[t1] lKRM*/1
# g <2> aassign[t5] KS/COMMON
# h <1> leavesub[1 ref] K/REFC,1
EONT_EONT
=for gentest
# chunk: %hash = map ( lc($_), 1 ), @array; # evaluates to (1, @array)
=cut
checkOptree(note => q{},
bcopts => q{-exec},
code => q{%hash = map ( lc($_), 1 ), @array; },
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1 <;> nextstate(main 475 (eval 10):1) v
# 2 <0> pushmark s
# 3 <0> pushmark s
# 4 <0> pushmark s
# 5 <$> const[IV 1] sM
# 6 <@> mapstart lK
# 7 <|> mapwhile(other->8)[t5] lK
# 8 <#> gvsv[*_] s
# 9 <1> lc[t4] sK/1
# goto 7
# a <0> pushmark s
# b <#> gv[*hash] s
# c <1> rv2hv[t2] lKRM*/1
# d <2> aassign[t6] KS/COMMON
# e <#> gv[*array] s
# f <1> rv2av[t8] K/1
# g <@> list K
# h <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 597 (eval 30):1) v
# 2 <0> pushmark s
# 3 <0> pushmark s
# 4 <0> pushmark s
# 5 <$> const(IV 1) sM
# 6 <@> mapstart lK
# 7 <|> mapwhile(other->8)[t3] lK
# 8 <$> gvsv(*_) s
# 9 <1> lc[t2] sK/1
# goto 7
# a <0> pushmark s
# b <$> gv(*hash) s
# c <1> rv2hv[t1] lKRM*/1
# d <2> aassign[t4] KS/COMMON
# e <$> gv(*array) s
# f <1> rv2av[t5] K/1
# g <@> list K
# h <1> leavesub[1 ref] K/REFC,1
EONT_EONT
=for gentest
# chunk: @hashes = map +{ lc($_), 1 }, @array # EXPR, so needs , at end
=cut
checkOptree(note => q{},
bcopts => q{-exec},
code => q{@hashes = map +{ lc($_), 1 }, @array },
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1 <;> nextstate(main 475 (eval 10):1) v
# 2 <0> pushmark s
# 3 <0> pushmark s
# 4 <#> gv[*array] s
# 5 <1> rv2av[t6] lKM/1
# 6 <@> mapstart lK
# 7 <|> mapwhile(other->8)[t7] lK
# 8 <0> pushmark s
# 9 <#> gvsv[*_] s
# a <1> lc[t4] sK/1
# b <$> const[IV 1] s
# c <@> anonhash sKRM/1
# d <1> srefgen sK/1
# goto 7
# e <0> pushmark s
# f <#> gv[*hashes] s
# g <1> rv2av[t2] lKRM*/1
# h <2> aassign[t8] KS/COMMON
# i <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 601 (eval 32):1) v
# 2 <0> pushmark s
# 3 <0> pushmark s
# 4 <$> gv(*array) s
# 5 <1> rv2av[t3] lKM/1
# 6 <@> mapstart lK
# 7 <|> mapwhile(other->8)[t4] lK
# 8 <0> pushmark s
# 9 <$> gvsv(*_) s
# a <1> lc[t2] sK/1
# b <$> const(IV 1) s
# c <@> anonhash sKRM/1
# d <1> srefgen sK/1
# goto 7
# e <0> pushmark s
# f <$> gv(*hashes) s
# g <1> rv2av[t1] lKRM*/1
# h <2> aassign[t5] KS/COMMON
# i <1> leavesub[1 ref] K/REFC,1
EONT_EONT
--- NEW FILE: optree_specials.t ---
#!./perl
# This tests the B:: module(s) with CHECK, BEGIN, END and INIT blocks. The
# text excerpts below marked with "# " in front are the expected output. They
# are there twice, EOT for threading, and EONT for a non-threading Perl. The
# output is matched losely. If the match fails even though the "got" and
# "expected" output look exactly the same, then watch for trailing, invisible
# spaces.
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;
}
# require 'test.pl'; # now done by OptreeCheck
}
# import checkOptree(), and %gOpts (containing test state)
use OptreeCheck; # ALSO DOES @ARGV HANDLING !!!!!!
use Config;
plan tests => 7;
require_ok("B::Concise");
my $out = runperl(
switches => ["-MO=Concise,BEGIN,CHECK,INIT,END,-exec"],
prog => q{$a=$b && print q/foo/},
stderr => 1 );
#print "out:$out\n";
my $src = q[our ($beg, $chk, $init, $end) = qq{'foo'}; BEGIN { $beg++ } CHECK { $chk++ } INIT { $init++ } END { $end++ }];
my @warnings_todo;
@warnings_todo = (todo =>
"Change 23768 (Remove Carp from warnings.pm) alters expected output, not"
. "propagated to 5.8.x")
if $] < 5.009;
checkOptree ( name => 'BEGIN',
bcopts => 'BEGIN',
prog => $src,
@warnings_todo,
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# BEGIN 1:
# b <1> leavesub[1 ref] K/REFC,1 ->(end)
# - <@> lineseq KP ->b
# 1 <;> nextstate(B::Concise -234 Concise.pm:328) v/2 ->2
# 3 <1> require sK/1 ->4
# 2 <$> const[PV "warnings.pm"] s/BARE ->3
# 4 <;> nextstate(B::Concise -234 Concise.pm:328) v/2 ->5
# - <@> lineseq K ->-
# 5 <;> nextstate(B::Concise -234 Concise.pm:328) /2 ->6
# a <1> entersub[t1] KS*/TARG,2 ->b
# 6 <0> pushmark s ->7
# 7 <$> const[PV "warnings"] sM ->8
# 8 <$> const[PV "qw"] sM ->9
# 9 <$> method_named[PVIV 1520340202] ->a
# BEGIN 2:
# f <1> leavesub[1 ref] K/REFC,1 ->(end)
# - <@> lineseq KP ->f
# c <;> nextstate(main 2 -e:1) v ->d
# e <1> postinc[t3] sK/1 ->f
# - <1> ex-rv2sv sKRM/1 ->e
# d <#> gvsv[*beg] s ->e
EOT_EOT
# BEGIN 1:
# b <1> leavesub[1 ref] K/REFC,1 ->(end)
# - <@> lineseq KP ->b
# 1 <;> nextstate(B::Concise -234 Concise.pm:328) v/2 ->2
# 3 <1> require sK/1 ->4
# 2 <$> const(PV "warnings.pm") s/BARE ->3
# 4 <;> nextstate(B::Concise -234 Concise.pm:328) v/2 ->5
# - <@> lineseq K ->-
# 5 <;> nextstate(B::Concise -234 Concise.pm:328) /2 ->6
# a <1> entersub[t1] KS*/TARG,2 ->b
# 6 <0> pushmark s ->7
# 7 <$> const(PV "warnings") sM ->8
# 8 <$> const(PV "qw") sM ->9
# 9 <$> method_named(PVIV 1520340202) ->a
# BEGIN 2:
# f <1> leavesub[1 ref] K/REFC,1 ->(end)
# - <@> lineseq KP ->f
# c <;> nextstate(main 2 -e:1) v ->d
# e <1> postinc[t2] sK/1 ->f
# - <1> ex-rv2sv sKRM/1 ->e
# d <$> gvsv(*beg) s ->e
EONT_EONT
checkOptree ( name => 'END',
bcopts => 'END',
prog => $src,
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# END 1:
# 4 <1> leavesub[1 ref] K/REFC,1 ->(end)
# - <@> lineseq KP ->4
# 1 <;> nextstate(main 5 -e:6) v ->2
# 3 <1> postinc[t3] sK/1 ->4
# - <1> ex-rv2sv sKRM/1 ->3
# 2 <#> gvsv[*end] s ->3
EOT_EOT
# END 1:
# 4 <1> leavesub[1 ref] K/REFC,1 ->(end)
# - <@> lineseq KP ->4
# 1 <;> nextstate(main 5 -e:6) v ->2
# 3 <1> postinc[t2] sK/1 ->4
# - <1> ex-rv2sv sKRM/1 ->3
# 2 <$> gvsv(*end) s ->3
EONT_EONT
checkOptree ( name => 'CHECK',
bcopts => 'CHECK',
prog => $src,
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# CHECK 1:
# 4 <1> leavesub[1 ref] K/REFC,1 ->(end)
# - <@> lineseq KP ->4
# 1 <;> nextstate(main 3 -e:4) v ->2
# 3 <1> postinc[t3] sK/1 ->4
# - <1> ex-rv2sv sKRM/1 ->3
# 2 <#> gvsv[*chk] s ->3
EOT_EOT
# CHECK 1:
# 4 <1> leavesub[1 ref] K/REFC,1 ->(end)
# - <@> lineseq KP ->4
# 1 <;> nextstate(main 3 -e:4) v ->2
# 3 <1> postinc[t2] sK/1 ->4
# - <1> ex-rv2sv sKRM/1 ->3
# 2 <$> gvsv(*chk) s ->3
EONT_EONT
checkOptree ( name => 'INIT',
bcopts => 'INIT',
#todo => 'get working',
prog => $src,
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# INIT 1:
# 4 <1> leavesub[1 ref] K/REFC,1 ->(end)
# - <@> lineseq KP ->4
# 1 <;> nextstate(main 4 -e:5) v ->2
# 3 <1> postinc[t3] sK/1 ->4
# - <1> ex-rv2sv sKRM/1 ->3
# 2 <#> gvsv[*init] s ->3
EOT_EOT
# INIT 1:
# 4 <1> leavesub[1 ref] K/REFC,1 ->(end)
# - <@> lineseq KP ->4
# 1 <;> nextstate(main 4 -e:5) v ->2
# 3 <1> postinc[t2] sK/1 ->4
# - <1> ex-rv2sv sKRM/1 ->3
# 2 <$> gvsv(*init) s ->3
EONT_EONT
checkOptree ( name => 'all of BEGIN END INIT CHECK -exec',
bcopts => [qw/ BEGIN END INIT CHECK -exec /],
prog => $src,
@warnings_todo,
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# BEGIN 1:
# 1 <;> nextstate(B::Concise -234 Concise.pm:328) v/2
# 2 <$> const[PV "warnings.pm"] s/BARE
# 3 <1> require sK/1
# 4 <;> nextstate(B::Concise -234 Concise.pm:328) v/2
# 5 <;> nextstate(B::Concise -234 Concise.pm:328) /2
# 6 <0> pushmark s
# 7 <$> const[PV "warnings"] sM
# 8 <$> const[PV "qw"] sM
# 9 <$> method_named[PVIV 1520340202]
# a <1> entersub[t1] KS*/TARG,2
# b <1> leavesub[1 ref] K/REFC,1
# BEGIN 2:
# c <;> nextstate(main 2 -e:1) v
# d <#> gvsv[*beg] s
# e <1> postinc[t3] sK/1
# f <1> leavesub[1 ref] K/REFC,1
# END 1:
# g <;> nextstate(main 5 -e:1) v
# h <#> gvsv[*end] s
# i <1> postinc[t3] sK/1
# j <1> leavesub[1 ref] K/REFC,1
# INIT 1:
# k <;> nextstate(main 4 -e:1) v
# l <#> gvsv[*init] s
# m <1> postinc[t3] sK/1
# n <1> leavesub[1 ref] K/REFC,1
# CHECK 1:
# o <;> nextstate(main 3 -e:1) v
# p <#> gvsv[*chk] s
# q <1> postinc[t3] sK/1
# r <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# BEGIN 1:
# 1 <;> nextstate(B::Concise -234 Concise.pm:328) v/2
# 2 <$> const(PV "warnings.pm") s/BARE
# 3 <1> require sK/1
# 4 <;> nextstate(B::Concise -234 Concise.pm:328) v/2
# 5 <;> nextstate(B::Concise -234 Concise.pm:328) /2
# 6 <0> pushmark s
# 7 <$> const(PV "warnings") sM
# 8 <$> const(PV "qw") sM
# 9 <$> method_named(PVIV 1520340202)
# a <1> entersub[t1] KS*/TARG,2
# b <1> leavesub[1 ref] K/REFC,1
# BEGIN 2:
# c <;> nextstate(main 2 -e:1) v
# d <$> gvsv(*beg) s
# e <1> postinc[t2] sK/1
# f <1> leavesub[1 ref] K/REFC,1
# END 1:
# g <;> nextstate(main 5 -e:1) v
# h <$> gvsv(*end) s
# i <1> postinc[t2] sK/1
# j <1> leavesub[1 ref] K/REFC,1
# INIT 1:
# k <;> nextstate(main 4 -e:1) v
# l <$> gvsv(*init) s
# m <1> postinc[t2] sK/1
# n <1> leavesub[1 ref] K/REFC,1
# CHECK 1:
# o <;> nextstate(main 3 -e:1) v
# p <$> gvsv(*chk) s
# q <1> postinc[t2] sK/1
# r <1> leavesub[1 ref] K/REFC,1
EONT_EONT
# perl "-I../lib" -MO=Concise,BEGIN,CHECK,INIT,END,-exec -e '$a=$b && print q/foo/'
checkOptree ( name => 'regression test for patch 25352',
bcopts => [qw/ BEGIN END INIT CHECK -exec /],
prog => 'print q/foo/',
@warnings_todo,
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# BEGIN 1:
# 1 <;> nextstate(B::Concise -234 Concise.pm:359) v/2
# 2 <$> const[PV "warnings.pm"] s/BARE
# 3 <1> require sK/1
# 4 <;> nextstate(B::Concise -234 Concise.pm:359) v/2
# 5 <;> nextstate(B::Concise -234 Concise.pm:359) /2
# 6 <0> pushmark s
# 7 <$> const[PV "warnings"] sM
# 8 <$> const[PV "qw"] sM
# 9 <$> method_named[PV "unimport"]
# a <1> entersub[t1] KS*/TARG,2
# b <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# BEGIN 1:
# 1 <;> nextstate(B::Concise -234 Concise.pm:359) v/2
# 2 <$> const(PV "warnings.pm") s/BARE
# 3 <1> require sK/1
# 4 <;> nextstate(B::Concise -234 Concise.pm:359) v/2
# 5 <;> nextstate(B::Concise -234 Concise.pm:359) /2
# 6 <0> pushmark s
# 7 <$> const(PV "warnings") sM
# 8 <$> const(PV "qw") sM
# 9 <$> method_named(PV "unimport")
# a <1> entersub[t1] KS*/TARG,2
# b <1> leavesub[1 ref] K/REFC,1
EONT_EONT
--- NEW FILE: deparse.t ---
#!./perl
BEGIN {
if ($ENV{PERL_CORE}){
chdir('t') if -d 't';
if ($^O eq 'MacOS') {
@INC = qw(: ::lib ::macos:lib);
} else {
@INC = '.';
push @INC, '../lib';
}
} else {
unshift @INC, 't';
}
require Config;
if (($Config::Config{'extensions'} !~ /\bB\b/) ){
print "1..0 # Skip -- Perl configured without B module\n";
exit 0;
}
}
$| = 1;
use warnings;
use strict;
use Config;
print "1..39\n";
use B::Deparse;
my $deparse = B::Deparse->new() or print "not ";
my $i=1;
print "ok " . $i++ . "\n";
# Tell B::Deparse about our ambient pragmas
{ my ($hint_bits, $warning_bits);
BEGIN { ($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS}); }
$deparse->ambient_pragmas (
hint_bits => $hint_bits,
warning_bits => $warning_bits,
'$[' => 0 + $[
);
}
$/ = "\n####\n";
while (<DATA>) {
chomp;
s/#.*$//mg;
my ($input, $expected);
if (/(.*)\n>>>>\n(.*)/s) {
($input, $expected) = ($1, $2);
}
else {
($input, $expected) = ($_, $_);
}
my $coderef = eval "sub {$input}";
if ($@) {
print "not ok " . $i++ . "\n";
print "# $@";
}
else {
my $deparsed = $deparse->coderef2text( $coderef );
my $regex = quotemeta($expected);
do {
no warnings 'misc';
$regex =~ s/\s+/\s+/g;
};
my $ok = ($deparsed =~ /^\{\s*$regex\s*\}$/);
print (($ok ? "ok " : "not ok ") . $i++ . "\n");
if (!$ok) {
print "# EXPECTED:\n";
$regex =~ s/^/# /mg;
print "$regex\n";
print "\n# GOT: \n";
$deparsed =~ s/^/# /mg;
print "$deparsed\n";
}
}
}
use constant 'c', 'stuff';
print "not " if (eval "sub ".$deparse->coderef2text(\&c))->() ne 'stuff';
print "ok " . $i++ . "\n";
$a = 0;
print "not " if "{\n (-1) ** \$a;\n}"
ne $deparse->coderef2text(sub{(-1) ** $a });
print "ok " . $i++ . "\n";
use constant cr => ['hello'];
my $string = "sub " . $deparse->coderef2text(\&cr);
my $val = (eval $string)->();
print "not " if ref($val) ne 'ARRAY' || $val->[0] ne 'hello';
print "ok " . $i++ . "\n";
my $a;
my $Is_VMS = $^O eq 'VMS';
my $Is_MacOS = $^O eq 'MacOS';
my $path = join " ", map { qq["-I$_"] } @INC;
$path .= " -MMac::err=unix" if $Is_MacOS;
my $redir = $Is_MacOS ? "" : "2>&1";
$a = `$^X $path "-MO=Deparse" -anlwi.bak -e 1 $redir`;
$a =~ s/-e syntax OK\n//g;
$a =~ s/.*possible typo.*\n//; # Remove warning line
$a =~ s{\\340\\242}{\\s} if (ord("\\") == 224); # EBCDIC, cp 1047 or 037
$a =~ s{\\274\\242}{\\s} if (ord("\\") == 188); # $^O eq 'posix-bc'
$b = <<'EOF';
BEGIN { $^I = ".bak"; }
BEGIN { $^W = 1; }
BEGIN { $/ = "\n"; $\ = "\n"; }
LINE: while (defined($_ = <ARGV>)) {
chomp $_;
our(@F) = split(" ", $_, 0);
'???';
}
EOF
$b =~ s/(LINE:)/sub BEGIN {
'MacPerl'->bootstrap;
'OSA'->bootstrap;
'XL'->bootstrap;
}
$1/ if $Is_MacOS;
print "# [$a]\n\# vs expected\n# [$b]\nnot " if $a ne $b;
print "ok " . $i++ . "\n";
#Re: perlbug #35857, patch #24505
#handle warnings::register-ed packages properly.
package B::Deparse::Wrapper;
use strict;
use warnings;
use warnings::register;
sub getcode {
my $deparser = B::Deparse->new();
return $deparser->coderef2text(shift);
}
package main;
use strict;
use warnings;
sub test {
my $val = shift;
my $res = B::Deparse::Wrapper::getcode($val);
print $res =~ /use warnings/ ? '' : 'not ', 'ok ', $i++, "\n";
}
my ($q,$p);
my $x=sub { ++$q,++$p };
test($x);
eval <<EOFCODE and test($x);
package bar;
use strict;
use warnings;
use warnings::register;
package main;
1
EOFCODE
__DATA__
# 2
1;
####
# 3
{
no warnings;
'???';
2;
}
####
# 4
my $test;
++$test and $test /= 2;
>>>>
my $test;
$test /= 2 if ++$test;
####
# 5
-((1, 2) x 2);
####
# 6
{
my $test = sub : lvalue {
my $x;
}
;
}
####
# 7
{
my $test = sub : method {
my $x;
}
;
}
####
# 8
{
my $test = sub : locked method {
my $x;
}
;
}
####
# 9
{
234;
}
continue {
123;
}
####
# 10
my $x;
print $main::x;
####
# 11
my @x;
print $main::x[1];
####
# 12
my %x;
$x{warn()};
####
# 13
my $foo;
$_ .= <ARGV> . <$foo>;
####
# 14
my $foo = "Ab\x{100}\200\x{200}\377Cd\000Ef\x{1000}\cA\x{2000}\cZ";
####
# 15
s/x/'y';/e;
####
# 16 - various lypes of loop
{ my $x; }
####
# 17
while (1) { my $k; }
####
# 18
my ($x, at a);
$x=1 for @a;
>>>>
my($x, @a);
$x = 1 foreach (@a);
####
# 19
for (my $i = 0; $i < 2;) {
my $z = 1;
}
####
# 20
for (my $i = 0; $i < 2; ++$i) {
my $z = 1;
}
####
# 21
for (my $i = 0; $i < 2; ++$i) {
my $z = 1;
}
####
# 22
my $i;
while ($i) { my $z = 1; } continue { $i = 99; }
####
# 23
foreach $i (1, 2) {
my $z = 1;
}
####
# 24
my $i;
foreach $i (1, 2) {
my $z = 1;
}
####
# 25
my $i;
foreach my $i (1, 2) {
my $z = 1;
}
####
# 26
foreach my $i (1, 2) {
my $z = 1;
}
####
# 27
foreach our $i (1, 2) {
my $z = 1;
}
####
# 28
my $i;
foreach our $i (1, 2) {
my $z = 1;
}
####
# 29
my @x;
print reverse sort(@x);
####
# 30
my @x;
print((sort {$b cmp $a} @x));
####
# 31
my @x;
print((reverse sort {$b <=> $a} @x));
####
# 32
our @a;
print $_ foreach (reverse @a);
####
# 33
our @a;
print $_ foreach (reverse 1, 2..5);
--- NEW FILE: bytecode.t ---
#!./perl
my $keep_plc = 0; # set it to keep the bytecode files
my $keep_plc_fail = 1; # set it to keep the bytecode files on failures
BEGIN {
if ($^O eq 'VMS') {
print "1..0 # skip - Bytecode/ByteLoader doesn't work on VMS\n";
exit 0;
}
if ($ENV{PERL_CORE}){
chdir('t') if -d 't';
@INC = ('.', '../lib');
} else {
unshift @INC, 't';
push @INC, "../../t";
}
use Config;
if (($Config{'extensions'} !~ /\bB\b/) ){
print "1..0 # Skip -- Perl configured without B module\n";
exit 0;
}
if ($Config{ccflags} =~ /-DPERL_COPY_ON_WRITE/) {
print "1..0 # skip - no COW for now\n";
exit 0;
}
require 'test.pl'; # for run_perl()
}
use strict;
undef $/;
my @tests = split /\n###+\n/, <DATA>;
print "1..".($#tests+1)."\n";
my $cnt = 1;
my $test;
for (@tests) {
my $got;
my ($script, $expect) = split />>>+\n/;
$expect =~ s/\n$//;
$test = "bytecode$cnt.pl";
open T, ">$test"; print T $script; close T;
$got = run_perl(switches => [ "-MO=Bytecode,-H,-o${test}c" ],
verbose => 0, # for debugging
stderr => 1, # to capture the "bytecode.pl syntax ok"
progfile => $test);
unless ($?) {
$got = run_perl(progfile => "${test}c"); # run the .plc
unless ($?) {
if ($got =~ /^$expect$/) {
print "ok $cnt\n";
next;
} else {
$keep_plc = $keep_plc_fail unless $keep_plc;
print <<"EOT"; next;
not ok $cnt
--------- SCRIPT
$script
--------- GOT
$got
--------- EXPECT
$expect
----------------
EOT
}
}
}
print <<"EOT";
not ok $cnt
--------- SCRIPT
$script
--------- \$\? = $?
$got
EOT
} continue {
1 while unlink($test, $keep_plc ? () : "${test}c");
$cnt++;
}
__DATA__
print 'hi'
>>>>
hi
############################################################
for (1,2,3) { print if /\d/ }
>>>>
123
############################################################
$_ = "xyxyx"; %j=(1,2); s/x/$j{print('z')}/ge; print $_
>>>>
zzz2y2y2
############################################################
$_ = "xyxyx"; %j=(1,2); s/x/$j{print('z')}/g; print $_
>>>>
z2y2y2
############################################################
split /a/,"bananarama"; print @_
>>>>
bnnrm
############################################################
{ package P; sub x { print 'ya' } x }
>>>>
ya
############################################################
@z = split /:/,"b:r:n:f:g"; print @z
>>>>
brnfg
############################################################
sub AUTOLOAD { print 1 } &{"a"}()
>>>>
1
############################################################
my $l = 3; $x = sub { print $l }; &$x
>>>>
3
############################################################
my $i = 1;
my $foo = sub {$i = shift if @_};
&$foo(3);
print 'ok';
>>>>
ok
############################################################
$x="Cannot use"; print index $x, "Can"
>>>>
0
############################################################
my $i=6; eval "print \$i\n"
>>>>
6
############################################################
BEGIN { %h=(1=>2,3=>4) } print $h{3}
>>>>
4
############################################################
open our $T,"a";
print 'ok';
>>>>
ok
############################################################
print <DATA>
__DATA__
a
b
>>>>
a
b
############################################################
BEGIN { tie @a, __PACKAGE__; sub TIEARRAY { bless{} } sub FETCH { 1 } }
print $a[1]
>>>>
1
############################################################
my $i=3; print 1 .. $i
>>>>
123
############################################################
my $h = { a=>3, b=>1 }; print sort {$h->{$a} <=> $h->{$b}} keys %$h
>>>>
ba
############################################################
print sort { my $p; $b <=> $a } 1,4,3
>>>>
431
--- NEW FILE: optree_samples.t ---
#!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;
}
# require 'test.pl'; # now done by OptreeCheck
}
use OptreeCheck;
use Config;
plan tests => 20;
SKIP: {
skip "no perlio in this build", 20 unless $Config::Config{useperlio};
pass("GENERAL OPTREE EXAMPLES");
pass("IF,THEN,ELSE, ?:");
checkOptree ( name => '-basic sub {if shift print then,else}',
bcopts => '-basic',
code => sub { if (shift) { print "then" }
else { print "else" }
},
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 9 <1> leavesub[1 ref] K/REFC,1 ->(end)
# - <@> lineseq KP ->9
# 1 <;> nextstate(main 426 optree.t:16) v ->2
# - <1> null K/1 ->-
# 5 <|> cond_expr(other->6) K/1 ->a
# 4 <1> shift sK/1 ->5
# 3 <1> rv2av[t2] sKRM/1 ->4
# 2 <#> gv[*_] s ->3
# - <@> scope K ->-
# - <0> ex-nextstate v ->6
# 8 <@> print sK ->9
# 6 <0> pushmark s ->7
# 7 <$> const[PV "then"] s ->8
# f <@> leave KP ->9
# a <0> enter ->b
# b <;> nextstate(main 424 optree.t:17) v ->c
# e <@> print sK ->f
# c <0> pushmark s ->d
# d <$> const[PV "else"] s ->e
EOT_EOT
# 9 <1> leavesub[1 ref] K/REFC,1 ->(end)
# - <@> lineseq KP ->9
# 1 <;> nextstate(main 427 optree_samples.t:18) v ->2
# - <1> null K/1 ->-
# 5 <|> cond_expr(other->6) K/1 ->a
# 4 <1> shift sK/1 ->5
# 3 <1> rv2av[t1] sKRM/1 ->4
# 2 <$> gv(*_) s ->3
# - <@> scope K ->-
# - <0> ex-nextstate v ->6
# 8 <@> print sK ->9
# 6 <0> pushmark s ->7
# 7 <$> const(PV "then") s ->8
# f <@> leave KP ->9
# a <0> enter ->b
# b <;> nextstate(main 425 optree_samples.t:19) v ->c
# e <@> print sK ->f
# c <0> pushmark s ->d
# d <$> const(PV "else") s ->e
EONT_EONT
checkOptree ( name => '-basic (see above, with my $a = shift)',
bcopts => '-basic',
code => sub { my $a = shift;
if ($a) { print "foo" }
else { print "bar" }
},
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# d <1> leavesub[1 ref] K/REFC,1 ->(end)
# - <@> lineseq KP ->d
# 1 <;> nextstate(main 431 optree.t:68) v ->2
# 6 <2> sassign vKS/2 ->7
# 4 <1> shift sK/1 ->5
# 3 <1> rv2av[t3] sKRM/1 ->4
# 2 <#> gv[*_] s ->3
# 5 <0> padsv[$a:431,435] sRM*/LVINTRO ->6
# 7 <;> nextstate(main 435 optree.t:69) v ->8
# - <1> null K/1 ->-
# 9 <|> cond_expr(other->a) K/1 ->e
# 8 <0> padsv[$a:431,435] s ->9
# - <@> scope K ->-
# - <0> ex-nextstate v ->a
# c <@> print sK ->d
# a <0> pushmark s ->b
# b <$> const[PV "foo"] s ->c
# j <@> leave KP ->d
# e <0> enter ->f
# f <;> nextstate(main 433 optree.t:70) v ->g
# i <@> print sK ->j
# g <0> pushmark s ->h
# h <$> const[PV "bar"] s ->i
EOT_EOT
# d <1> leavesub[1 ref] K/REFC,1 ->(end)
# - <@> lineseq KP ->d
# 1 <;> nextstate(main 428 optree_samples.t:48) v ->2
# 6 <2> sassign vKS/2 ->7
# 4 <1> shift sK/1 ->5
# 3 <1> rv2av[t2] sKRM/1 ->4
# 2 <$> gv(*_) s ->3
# 5 <0> padsv[$a:428,432] sRM*/LVINTRO ->6
# 7 <;> nextstate(main 432 optree_samples.t:49) v ->8
# - <1> null K/1 ->-
# 9 <|> cond_expr(other->a) K/1 ->e
# 8 <0> padsv[$a:428,432] s ->9
# - <@> scope K ->-
# - <0> ex-nextstate v ->a
# c <@> print sK ->d
# a <0> pushmark s ->b
# b <$> const(PV "foo") s ->c
# j <@> leave KP ->d
# e <0> enter ->f
# f <;> nextstate(main 430 optree_samples.t:50) v ->g
# i <@> print sK ->j
# g <0> pushmark s ->h
# h <$> const(PV "bar") s ->i
EONT_EONT
checkOptree ( name => '-exec sub {if shift print then,else}',
bcopts => '-exec',
code => sub { if (shift) { print "then" }
else { print "else" }
},
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1 <;> nextstate(main 426 optree.t:16) v
# 2 <#> gv[*_] s
# 3 <1> rv2av[t2] sKRM/1
# 4 <1> shift sK/1
# 5 <|> cond_expr(other->6) K/1
# 6 <0> pushmark s
# 7 <$> const[PV "then"] s
# 8 <@> print sK
# goto 9
# a <0> enter
# b <;> nextstate(main 424 optree.t:17) v
# c <0> pushmark s
# d <$> const[PV "else"] s
# e <@> print sK
# f <@> leave KP
# 9 <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 436 optree_samples.t:123) v
# 2 <$> gv(*_) s
# 3 <1> rv2av[t1] sKRM/1
# 4 <1> shift sK/1
# 5 <|> cond_expr(other->6) K/1
# 6 <0> pushmark s
# 7 <$> const(PV "then") s
# 8 <@> print sK
# goto 9
# a <0> enter
# b <;> nextstate(main 434 optree_samples.t:124) v
# c <0> pushmark s
# d <$> const(PV "else") s
# e <@> print sK
# f <@> leave KP
# 9 <1> leavesub[1 ref] K/REFC,1
EONT_EONT
checkOptree ( name => '-exec (see above, with my $a = shift)',
bcopts => '-exec',
code => sub { my $a = shift;
if ($a) { print "foo" }
else { print "bar" }
},
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1 <;> nextstate(main 423 optree.t:16) v
# 2 <#> gv[*_] s
# 3 <1> rv2av[t3] sKRM/1
# 4 <1> shift sK/1
# 5 <0> padsv[$a:423,427] sRM*/LVINTRO
# 6 <2> sassign vKS/2
# 7 <;> nextstate(main 427 optree.t:17) v
# 8 <0> padsv[$a:423,427] s
# 9 <|> cond_expr(other->a) K/1
# a <0> pushmark s
# b <$> const[PV "foo"] s
# c <@> print sK
# goto d
# e <0> enter
# f <;> nextstate(main 425 optree.t:18) v
# g <0> pushmark s
# h <$> const[PV "bar"] s
# i <@> print sK
# j <@> leave KP
# d <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 437 optree_samples.t:112) v
# 2 <$> gv(*_) s
# 3 <1> rv2av[t2] sKRM/1
# 4 <1> shift sK/1
# 5 <0> padsv[$a:437,441] sRM*/LVINTRO
# 6 <2> sassign vKS/2
# 7 <;> nextstate(main 441 optree_samples.t:113) v
# 8 <0> padsv[$a:437,441] s
# 9 <|> cond_expr(other->a) K/1
# a <0> pushmark s
# b <$> const(PV "foo") s
# c <@> print sK
# goto d
# e <0> enter
# f <;> nextstate(main 439 optree_samples.t:114) v
# g <0> pushmark s
# h <$> const(PV "bar") s
# i <@> print sK
# j <@> leave KP
# d <1> leavesub[1 ref] K/REFC,1
EONT_EONT
checkOptree ( name => '-exec sub { print (shift) ? "foo" : "bar" }',
code => sub { print (shift) ? "foo" : "bar" },
bcopts => '-exec',
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1 <;> nextstate(main 428 optree.t:31) v
# 2 <0> pushmark s
# 3 <#> gv[*_] s
# 4 <1> rv2av[t2] sKRM/1
# 5 <1> shift sK/1
# 6 <@> print sK
# 7 <|> cond_expr(other->8) K/1
# 8 <$> const[PV "foo"] s
# goto 9
# a <$> const[PV "bar"] s
# 9 <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 442 optree_samples.t:144) v
# 2 <0> pushmark s
# 3 <$> gv(*_) s
# 4 <1> rv2av[t1] sKRM/1
# 5 <1> shift sK/1
# 6 <@> print sK
# 7 <|> cond_expr(other->8) K/1
# 8 <$> const(PV "foo") s
# goto 9
# a <$> const(PV "bar") s
# 9 <1> leavesub[1 ref] K/REFC,1
EONT_EONT
pass ("FOREACH");
checkOptree ( name => '-exec sub { foreach (1..10) {print "foo $_"} }',
code => sub { foreach (1..10) {print "foo $_"} },
bcopts => '-exec',
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1 <;> nextstate(main 443 optree.t:158) v
# 2 <0> pushmark s
# 3 <$> const[IV 1] s
# 4 <$> const[IV 10] s
# 5 <#> gv[*_] s
# 6 <{> enteriter(next->d last->g redo->7) lKS
# e <0> iter s
# f <|> and(other->7) K/1
# 7 <;> nextstate(main 442 optree.t:158) v
# 8 <0> pushmark s
# 9 <$> const[PV "foo "] s
# a <#> gvsv[*_] s
# b <2> concat[t4] sK/2
# c <@> print vK
# d <0> unstack s
# goto e
# g <2> leaveloop K/2
# h <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 444 optree_samples.t:182) v
# 2 <0> pushmark s
# 3 <$> const(IV 1) s
# 4 <$> const(IV 10) s
# 5 <$> gv(*_) s
# 6 <{> enteriter(next->d last->g redo->7) lKS
# e <0> iter s
# f <|> and(other->7) K/1
# 7 <;> nextstate(main 443 optree_samples.t:182) v
# 8 <0> pushmark s
# 9 <$> const(PV "foo ") s
# a <$> gvsv(*_) s
# b <2> concat[t3] sK/2
# c <@> print vK
# d <0> unstack s
# goto e
# g <2> leaveloop K/2
# h <1> leavesub[1 ref] K/REFC,1
EONT_EONT
checkOptree ( name => '-basic sub { print "foo $_" foreach (1..10) }',
code => sub { print "foo $_" foreach (1..10) },
bcopts => '-basic',
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# h <1> leavesub[1 ref] K/REFC,1 ->(end)
# - <@> lineseq KP ->h
# 1 <;> nextstate(main 445 optree.t:167) v ->2
# 2 <;> nextstate(main 445 optree.t:167) v ->3
# g <2> leaveloop K/2 ->h
# 7 <{> enteriter(next->d last->g redo->8) lKS ->e
# - <0> ex-pushmark s ->3
# - <1> ex-list lK ->6
# 3 <0> pushmark s ->4
# 4 <$> const[IV 1] s ->5
# 5 <$> const[IV 10] s ->6
# 6 <#> gv[*_] s ->7
# - <1> null K/1 ->g
# f <|> and(other->8) K/1 ->g
# e <0> iter s ->f
# - <@> lineseq sK ->-
# c <@> print vK ->d
# 8 <0> pushmark s ->9
# - <1> ex-stringify sK/1 ->c
# - <0> ex-pushmark s ->9
# b <2> concat[t2] sK/2 ->c
# 9 <$> const[PV "foo "] s ->a
# - <1> ex-rv2sv sK/1 ->b
# a <#> gvsv[*_] s ->b
# d <0> unstack s ->e
EOT_EOT
# h <1> leavesub[1 ref] K/REFC,1 ->(end)
# - <@> lineseq KP ->h
# 1 <;> nextstate(main 446 optree_samples.t:192) v ->2
# 2 <;> nextstate(main 446 optree_samples.t:192) v ->3
# g <2> leaveloop K/2 ->h
# 7 <{> enteriter(next->d last->g redo->8) lKS ->e
# - <0> ex-pushmark s ->3
# - <1> ex-list lK ->6
# 3 <0> pushmark s ->4
# 4 <$> const(IV 1) s ->5
# 5 <$> const(IV 10) s ->6
# 6 <$> gv(*_) s ->7
# - <1> null K/1 ->g
# f <|> and(other->8) K/1 ->g
# e <0> iter s ->f
# - <@> lineseq sK ->-
# c <@> print vK ->d
# 8 <0> pushmark s ->9
# - <1> ex-stringify sK/1 ->c
# - <0> ex-pushmark s ->9
# b <2> concat[t1] sK/2 ->c
# 9 <$> const(PV "foo ") s ->a
# - <1> ex-rv2sv sK/1 ->b
# a <$> gvsv(*_) s ->b
# d <0> unstack s ->e
EONT_EONT
checkOptree ( name => '-exec -e foreach (1..10) {print qq{foo $_}}',
prog => 'foreach (1..10) {print qq{foo $_}}',
bcopts => '-exec',
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1 <0> enter
# 2 <;> nextstate(main 2 -e:1) v
# 3 <0> pushmark s
# 4 <$> const[IV 1] s
# 5 <$> const[IV 10] s
# 6 <#> gv[*_] s
# 7 <{> enteriter(next->e last->h redo->8) lKS
# f <0> iter s
# g <|> and(other->8) vK/1
# 8 <;> nextstate(main 1 -e:1) v
# 9 <0> pushmark s
# a <$> const[PV "foo "] s
# b <#> gvsv[*_] s
# c <2> concat[t4] sK/2
# d <@> print vK
# e <0> unstack v
# goto f
# h <2> leaveloop vK/2
# i <@> leave[1 ref] vKP/REFC
EOT_EOT
# 1 <0> enter
# 2 <;> nextstate(main 2 -e:1) v
# 3 <0> pushmark s
# 4 <$> const(IV 1) s
# 5 <$> const(IV 10) s
# 6 <$> gv(*_) s
# 7 <{> enteriter(next->e last->h redo->8) lKS
# f <0> iter s
# g <|> and(other->8) vK/1
# 8 <;> nextstate(main 1 -e:1) v
# 9 <0> pushmark s
# a <$> const(PV "foo ") s
# b <$> gvsv(*_) s
# c <2> concat[t3] sK/2
# d <@> print vK
# e <0> unstack v
# goto f
# h <2> leaveloop vK/2
# i <@> leave[1 ref] vKP/REFC
EONT_EONT
checkOptree ( name => '-exec sub { print "foo $_" foreach (1..10) }',
code => sub { print "foo $_" foreach (1..10) },
bcopts => '-exec',
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1 <;> nextstate(main 445 optree.t:167) v
# 2 <;> nextstate(main 445 optree.t:167) v
# 3 <0> pushmark s
# 4 <$> const[IV 1] s
# 5 <$> const[IV 10] s
# 6 <#> gv[*_] s
# 7 <{> enteriter(next->d last->g redo->8) lKS
# e <0> iter s
# f <|> and(other->8) K/1
# 8 <0> pushmark s
# 9 <$> const[PV "foo "] s
# a <#> gvsv[*_] s
# b <2> concat[t2] sK/2
# c <@> print vK
# d <0> unstack s
# goto e
# g <2> leaveloop K/2
# h <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 447 optree_samples.t:252) v
# 2 <;> nextstate(main 447 optree_samples.t:252) v
# 3 <0> pushmark s
# 4 <$> const(IV 1) s
# 5 <$> const(IV 10) s
# 6 <$> gv(*_) s
# 7 <{> enteriter(next->d last->g redo->8) lKS
# e <0> iter s
# f <|> and(other->8) K/1
# 8 <0> pushmark s
# 9 <$> const(PV "foo ") s
# a <$> gvsv(*_) s
# b <2> concat[t1] sK/2
# c <@> print vK
# d <0> unstack s
# goto e
# g <2> leaveloop K/2
# h <1> leavesub[1 ref] K/REFC,1
EONT_EONT
pass("GREP: SAMPLES FROM PERLDOC -F GREP");
checkOptree ( name => '@foo = grep(!/^\#/, @bar)',
code => '@foo = grep(!/^\#/, @bar)',
bcopts => '-exec',
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1 <;> nextstate(main 496 (eval 20):1) v
# 2 <0> pushmark s
# 3 <0> pushmark s
# 4 <#> gv[*bar] s
# 5 <1> rv2av[t4] lKM/1
# 6 <@> grepstart lK
# 7 <|> grepwhile(other->8)[t5] lK
# 8 </> match(/"^#"/) s/RTIME
# 9 <1> not sK/1
# goto 7
# a <0> pushmark s
# b <#> gv[*foo] s
# c <1> rv2av[t2] lKRM*/1
# d <2> aassign[t6] KS/COMMON
# e <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 496 (eval 20):1) v
# 2 <0> pushmark s
# 3 <0> pushmark s
# 4 <$> gv(*bar) s
# 5 <1> rv2av[t2] lKM/1
# 6 <@> grepstart lK
# 7 <|> grepwhile(other->8)[t3] lK
# 8 </> match(/"^\\#"/) s/RTIME
# 9 <1> not sK/1
# goto 7
# a <0> pushmark s
# b <$> gv(*foo) s
# c <1> rv2av[t1] lKRM*/1
# d <2> aassign[t4] KS/COMMON
# e <1> leavesub[1 ref] K/REFC,1
EONT_EONT
pass("MAP: SAMPLES FROM PERLDOC -F MAP");
checkOptree ( name => '%h = map { getkey($_) => $_ } @a',
code => '%h = map { getkey($_) => $_ } @a',
bcopts => '-exec',
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1 <;> nextstate(main 501 (eval 22):1) v
# 2 <0> pushmark s
# 3 <0> pushmark s
# 4 <#> gv[*a] s
# 5 <1> rv2av[t8] lKM/1
# 6 <@> mapstart lK*
# 7 <|> mapwhile(other->8)[t9] lK
# 8 <0> enter l
# 9 <;> nextstate(main 500 (eval 22):1) v
# a <0> pushmark s
# b <0> pushmark s
# c <#> gvsv[*_] s
# d <#> gv[*getkey] s/EARLYCV
# e <1> entersub[t5] lKS/TARG,1
# f <#> gvsv[*_] s
# g <@> list lK
# h <@> leave lKP
# goto 7
# i <0> pushmark s
# j <#> gv[*h] s
# k <1> rv2hv[t2] lKRM*/1
# l <2> aassign[t10] KS/COMMON
# m <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 501 (eval 22):1) v
# 2 <0> pushmark s
# 3 <0> pushmark s
# 4 <$> gv(*a) s
# 5 <1> rv2av[t3] lKM/1
# 6 <@> mapstart lK*
# 7 <|> mapwhile(other->8)[t4] lK
# 8 <0> enter l
# 9 <;> nextstate(main 500 (eval 22):1) v
# a <0> pushmark s
# b <0> pushmark s
# c <$> gvsv(*_) s
# d <$> gv(*getkey) s/EARLYCV
# e <1> entersub[t2] lKS/TARG,1
# f <$> gvsv(*_) s
# g <@> list lK
# h <@> leave lKP
# goto 7
# i <0> pushmark s
# j <$> gv(*h) s
# k <1> rv2hv[t1] lKRM*/1
# l <2> aassign[t5] KS/COMMON
# m <1> leavesub[1 ref] K/REFC,1
EONT_EONT
checkOptree ( name => '%h=(); for $_(@a){$h{getkey($_)} = $_}',
code => '%h=(); for $_(@a){$h{getkey($_)} = $_}',
bcopts => '-exec',
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1 <;> nextstate(main 505 (eval 24):1) v
# 2 <0> pushmark s
# 3 <0> pushmark s
# 4 <#> gv[*h] s
# 5 <1> rv2hv[t2] lKRM*/1
# 6 <2> aassign[t3] vKS
# 7 <;> nextstate(main 506 (eval 24):1) v
# 8 <0> pushmark sM
# 9 <#> gv[*a] s
# a <1> rv2av[t6] sKRM/1
# b <#> gv[*_] s
# c <1> rv2gv sKRM/1
# d <{> enteriter(next->o last->r redo->e) lKS
# p <0> iter s
# q <|> and(other->e) K/1
# e <;> nextstate(main 505 (eval 24):1) v
# f <#> gvsv[*_] s
# g <#> gv[*h] s
# h <1> rv2hv sKR/1
# i <0> pushmark s
# j <#> gvsv[*_] s
# k <#> gv[*getkey] s/EARLYCV
# l <1> entersub[t10] sKS/TARG,1
# m <2> helem sKRM*/2
# n <2> sassign vKS/2
# o <0> unstack s
# goto p
# r <2> leaveloop K/2
# s <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 505 (eval 24):1) v
# 2 <0> pushmark s
# 3 <0> pushmark s
# 4 <$> gv(*h) s
# 5 <1> rv2hv[t1] lKRM*/1
# 6 <2> aassign[t2] vKS
# 7 <;> nextstate(main 506 (eval 24):1) v
# 8 <0> pushmark sM
# 9 <$> gv(*a) s
# a <1> rv2av[t3] sKRM/1
# b <$> gv(*_) s
# c <1> rv2gv sKRM/1
# d <{> enteriter(next->o last->r redo->e) lKS
# p <0> iter s
# q <|> and(other->e) K/1
# e <;> nextstate(main 505 (eval 24):1) v
# f <$> gvsv(*_) s
# g <$> gv(*h) s
# h <1> rv2hv sKR/1
# i <0> pushmark s
# j <$> gvsv(*_) s
# k <$> gv(*getkey) s/EARLYCV
# l <1> entersub[t4] sKS/TARG,1
# m <2> helem sKRM*/2
# n <2> sassign vKS/2
# o <0> unstack s
# goto p
# r <2> leaveloop K/2
# s <1> leavesub[1 ref] K/REFC,1
EONT_EONT
checkOptree ( name => 'map $_+42, 10..20',
code => 'map $_+42, 10..20',
bcopts => '-exec',
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1 <;> nextstate(main 497 (eval 20):1) v
# 2 <0> pushmark s
# 3 <$> const[AV ] s
# 4 <1> rv2av lKPM/1
# 5 <@> mapstart K
# 6 <|> mapwhile(other->7)[t5] K
# 7 <#> gvsv[*_] s
# 8 <$> const[IV 42] s
# 9 <2> add[t2] sK/2
# goto 6
# a <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 511 (eval 26):1) v
# 2 <0> pushmark s
# 3 <$> const(AV ) s
# 4 <1> rv2av lKPM/1
# 5 <@> mapstart K
# 6 <|> mapwhile(other->7)[t4] K
# 7 <$> gvsv(*_) s
# 8 <$> const(IV 42) s
# 9 <2> add[t1] sK/2
# goto 6
# a <1> leavesub[1 ref] K/REFC,1
EONT_EONT
pass("CONSTANTS");
checkOptree ( name => '-e use constant j => qq{junk}; print j',
prog => 'use constant j => qq{junk}; print j',
bcopts => '-exec',
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1 <0> enter
# 2 <;> nextstate(main 71 -e:1) v
# 3 <0> pushmark s
# 4 <$> const[PV "junk"] s
# 5 <@> print vK
# 6 <@> leave[1 ref] vKP/REFC
EOT_EOT
# 1 <0> enter
# 2 <;> nextstate(main 71 -e:1) v
# 3 <0> pushmark s
# 4 <$> const(PV "junk") s
# 5 <@> print vK
# 6 <@> leave[1 ref] vKP/REFC
EONT_EONT
} # skip
__END__
#######################################################################
checkOptree ( name => '-exec sub a { print (shift) ? "foo" : "bar" }',
code => sub { print (shift) ? "foo" : "bar" },
bcopts => '-exec',
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
insert threaded reference here
EOT_EOT
insert non-threaded reference here
EONT_EONT
--- NEW FILE: b.t ---
#!./perl
BEGIN {
if ($ENV{PERL_CORE}){
chdir('t') if -d 't';
if ($^O eq 'MacOS') {
@INC = qw(: ::lib ::macos:lib);
} else {
@INC = '.';
push @INC, '../lib';
}
} else {
unshift @INC, 't';
}
require Config;
if (($Config::Config{'extensions'} !~ /\bB\b/) ){
print "1..0 # Skip -- Perl configured without B module\n";
exit 0;
}
}
$| = 1;
use warnings;
use strict;
use Test::More tests => 41;
BEGIN { use_ok( 'B' ); }
package Testing::Symtable;
use vars qw($This @That %wibble $moo %moo);
my $not_a_sym = 'moo';
sub moo { 42 }
sub car { 23 }
package Testing::Symtable::Foo;
sub yarrow { "Hock" }
package Testing::Symtable::Bar;
sub hock { "yarrow" }
package main;
use vars qw(%Subs);
local %Subs = ();
B::walksymtable(\%Testing::Symtable::, 'find_syms', sub { $_[0] =~ /Foo/ },
'Testing::Symtable::');
sub B::GV::find_syms {
my($symbol) = @_;
$main::Subs{$symbol->STASH->NAME . '::' . $symbol->NAME}++;
}
my @syms = map { 'Testing::Symtable::'.$_ } qw(This That wibble moo car
BEGIN);
push @syms, "Testing::Symtable::Foo::yarrow";
# Make sure we hit all the expected symbols.
ok( join('', sort @syms) eq join('', sort keys %Subs), 'all symbols found' );
# Make sure we only hit them each once.
ok( (!grep $_ != 1, values %Subs), '...and found once' );
# Tests for MAGIC / MOREMAGIC
ok( B::svref_2object(\$.)->MAGIC->TYPE eq "\0", '$. has \0 magic' );
{
my $e = '';
local $SIG{__DIE__} = sub { $e = $_[0] };
# Used to dump core, bug #16828
eval { B::svref_2object(\$.)->MAGIC->MOREMAGIC->TYPE; };
like( $e, qr/Can't call method "TYPE" on an undefined value/,
'$. has no more magic' );
}
my $iv = 1;
my $iv_ref = B::svref_2object(\$iv);
is(ref $iv_ref, "B::IV", "Test B:IV return from svref_2object");
is($iv_ref->REFCNT, 1, "Test B::IV->REFCNT");
# Flag tests are needed still
#diag $iv_ref->FLAGS();
my $iv_ret = $iv_ref->object_2svref();
is(ref $iv_ret, "SCALAR", "Test object_2svref() return is SCALAR");
is($$iv_ret, $iv, "Test object_2svref()");
is($iv_ref->int_value, $iv, "Test int_value()");
is($iv_ref->IV, $iv, "Test IV()");
is($iv_ref->IVX(), $iv, "Test IVX()");
is($iv_ref->UVX(), $iv, "Test UVX()");
my $pv = "Foo";
my $pv_ref = B::svref_2object(\$pv);
is(ref $pv_ref, "B::PV", "Test B::PV return from svref_2object");
is($pv_ref->REFCNT, 1, "Test B::PV->REFCNT");
# Flag tests are needed still
#diag $pv_ref->FLAGS();
my $pv_ret = $pv_ref->object_2svref();
is(ref $pv_ret, "SCALAR", "Test object_2svref() return is SCALAR");
is($$pv_ret, $pv, "Test object_2svref()");
is($pv_ref->PV(), $pv, "Test PV()");
eval { is($pv_ref->RV(), $pv, "Test RV()"); };
ok($@, "Test RV()");
is($pv_ref->PVX(), $pv, "Test PVX()");
my $nv = 1.1;
my $nv_ref = B::svref_2object(\$nv);
is(ref $nv_ref, "B::NV", "Test B::NV return from svref_2object");
is($nv_ref->REFCNT, 1, "Test B::NV->REFCNT");
# Flag tests are needed still
#diag $nv_ref->FLAGS();
my $nv_ret = $nv_ref->object_2svref();
is(ref $nv_ret, "SCALAR", "Test object_2svref() return is SCALAR");
is($$nv_ret, $nv, "Test object_2svref()");
is($nv_ref->NV, $nv, "Test NV()");
is($nv_ref->NVX(), $nv, "Test NVX()");
my $null = undef;
my $null_ref = B::svref_2object(\$null);
is(ref $null_ref, "B::NULL", "Test B::NULL return from svref_2object");
is($null_ref->REFCNT, 1, "Test B::NULL->REFCNT");
# Flag tests are needed still
#diag $null_ref->FLAGS();
my $null_ret = $nv_ref->object_2svref();
is(ref $null_ret, "SCALAR", "Test object_2svref() return is SCALAR");
is($$null_ret, $nv, "Test object_2svref()");
my $cv = sub{ 1; };
my $cv_ref = B::svref_2object(\$cv);
is($cv_ref->REFCNT, 1, "Test B::RV->REFCNT");
is(ref $cv_ref, "B::RV", "Test B::RV return from svref_2object - code");
my $cv_ret = $cv_ref->object_2svref();
is(ref $cv_ret, "REF", "Test object_2svref() return is REF");
is($$cv_ret, $cv, "Test object_2svref()");
my $av = [];
my $av_ref = B::svref_2object(\$av);
is(ref $av_ref, "B::RV", "Test B::RV return from svref_2object - array");
my $hv = [];
my $hv_ref = B::svref_2object(\$hv);
is(ref $hv_ref, "B::RV", "Test B::RV return from svref_2object - hash");
local *gv = *STDOUT;
my $gv_ref = B::svref_2object(\*gv);
is(ref $gv_ref, "B::GV", "Test B::GV return from svref_2object");
ok(! $gv_ref->is_empty(), "Test is_empty()");
is($gv_ref->NAME(), "gv", "Test NAME()");
is($gv_ref->SAFENAME(), "gv", "Test SAFENAME()");
like($gv_ref->FILE(), qr/b\.t$/, "Testing FILE()");
--- NEW FILE: optree_concise.t ---
#!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;
}
# require 'test.pl'; # now done by OptreeCheck
}
# import checkOptree(), and %gOpts (containing test state)
use OptreeCheck; # ALSO DOES @ARGV HANDLING !!!!!!
use Config;
my $tests = 23;
plan tests => $tests;
SKIP: {
skip "no perlio in this build", $tests unless $Config::Config{useperlio};
$SIG{__WARN__} = sub {
my $err = shift;
$err =~ m/Subroutine re::(un)?install redefined/ and return;
};
#################################
pass("CANONICAL B::Concise EXAMPLE");
checkOptree ( name => 'canonical example w -basic',
bcopts => '-basic',
code => sub{$a=$b+42},
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 7 <1> leavesub[1 ref] K/REFC,1 ->(end)
# - <@> lineseq KP ->7
# 1 <;> nextstate(foo bar) v ->2
# 6 <2> sassign sKS/2 ->7
# 4 <2> add[t3] sK/2 ->5
# - <1> ex-rv2sv sK/1 ->3
# 2 <#> gvsv[*b] s ->3
# 3 <$> const[IV 42] s ->4
# - <1> ex-rv2sv sKRM*/1 ->6
# 5 <#> gvsv[*a] s ->6
EOT_EOT
# 7 <1> leavesub[1 ref] K/REFC,1 ->(end)
# - <@> lineseq KP ->7
# 1 <;> nextstate(main 60 optree_concise.t:122) v ->2
# 6 <2> sassign sKS/2 ->7
# 4 <2> add[t1] sK/2 ->5
# - <1> ex-rv2sv sK/1 ->3
# 2 <$> gvsv(*b) s ->3
# 3 <$> const(IV 42) s ->4
# - <1> ex-rv2sv sKRM*/1 ->6
# 5 <$> gvsv(*a) s ->6
EONT_EONT
checkOptree ( name => 'canonical example w -exec',
bcopts => '-exec',
code => sub{$a=$b+42},
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1 <;> nextstate(main 61 optree_concise.t:139) v
# 2 <#> gvsv[*b] s
# 3 <$> const[IV 42] s
# 4 <2> add[t3] sK/2
# 5 <#> gvsv[*a] s
# 6 <2> sassign sKS/2
# 7 <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 61 optree_concise.t:139) v
# 2 <$> gvsv(*b) s
# 3 <$> const(IV 42) s
# 4 <2> add[t1] sK/2
# 5 <$> gvsv(*a) s
# 6 <2> sassign sKS/2
# 7 <1> leavesub[1 ref] K/REFC,1
EONT_EONT
#################################
pass("B::Concise OPTION TESTS");
checkOptree ( name => '-base3 sticky-exec',
bcopts => '-base3',
code => sub{$a=$b+42},
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
1 <;> dbstate(main 24 optree_concise.t:132) v
2 <#> gvsv[*b] s
10 <$> const[IV 42] s
11 <2> add[t3] sK/2
12 <#> gvsv[*a] s
20 <2> sassign sKS/2
21 <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 62 optree_concise.t:161) v
# 2 <$> gvsv(*b) s
# 10 <$> const(IV 42) s
# 11 <2> add[t1] sK/2
# 12 <$> gvsv(*a) s
# 20 <2> sassign sKS/2
# 21 <1> leavesub[1 ref] K/REFC,1
EONT_EONT
checkOptree ( name => 'sticky-base3, -basic over sticky-exec',
bcopts => '-basic',
code => sub{$a=$b+42},
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
21 <1> leavesub[1 ref] K/REFC,1 ->(end)
- <@> lineseq KP ->21
1 <;> nextstate(main 32 optree_concise.t:164) v ->2
20 <2> sassign sKS/2 ->21
11 <2> add[t3] sK/2 ->12
- <1> ex-rv2sv sK/1 ->10
2 <#> gvsv[*b] s ->10
10 <$> const[IV 42] s ->11
- <1> ex-rv2sv sKRM*/1 ->20
12 <#> gvsv[*a] s ->20
EOT_EOT
# 21 <1> leavesub[1 ref] K/REFC,1 ->(end)
# - <@> lineseq KP ->21
# 1 <;> nextstate(main 63 optree_concise.t:186) v ->2
# 20 <2> sassign sKS/2 ->21
# 11 <2> add[t1] sK/2 ->12
# - <1> ex-rv2sv sK/1 ->10
# 2 <$> gvsv(*b) s ->10
# 10 <$> const(IV 42) s ->11
# - <1> ex-rv2sv sKRM*/1 ->20
# 12 <$> gvsv(*a) s ->20
EONT_EONT
checkOptree ( name => '-base4',
bcopts => [qw/ -basic -base4 /],
code => sub{$a=$b+42},
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
13 <1> leavesub[1 ref] K/REFC,1 ->(end)
- <@> lineseq KP ->13
1 <;> nextstate(main 26 optree_concise.t:145) v ->2
12 <2> sassign sKS/2 ->13
10 <2> add[t3] sK/2 ->11
- <1> ex-rv2sv sK/1 ->3
2 <#> gvsv[*b] s ->3
3 <$> const[IV 42] s ->10
- <1> ex-rv2sv sKRM*/1 ->12
11 <#> gvsv[*a] s ->12
EOT_EOT
# 13 <1> leavesub[1 ref] K/REFC,1 ->(end)
# - <@> lineseq KP ->13
# 1 <;> nextstate(main 64 optree_concise.t:193) v ->2
# 12 <2> sassign sKS/2 ->13
# 10 <2> add[t1] sK/2 ->11
# - <1> ex-rv2sv sK/1 ->3
# 2 <$> gvsv(*b) s ->3
# 3 <$> const(IV 42) s ->10
# - <1> ex-rv2sv sKRM*/1 ->12
# 11 <$> gvsv(*a) s ->12
EONT_EONT
checkOptree ( name => "restore -base36 default",
bcopts => [qw/ -basic -base36 /],
code => sub{$a},
crossfail => 1,
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
3 <1> leavesub[1 ref] K/REFC,1 ->(end)
- <@> lineseq KP ->3
1 <;> nextstate(main 27 optree_concise.t:161) v ->2
- <1> ex-rv2sv sK/1 ->-
2 <#> gvsv[*a] s ->3
EOT_EOT
# 3 <1> leavesub[1 ref] K/REFC,1 ->(end)
# - <@> lineseq KP ->3
# 1 <;> nextstate(main 65 optree_concise.t:210) v ->2
# - <1> ex-rv2sv sK/1 ->-
# 2 <$> gvsv(*a) s ->3
EONT_EONT
checkOptree ( name => "terse basic",
bcopts => [qw/ -basic -terse /],
code => sub{$a},
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
UNOP (0x82b0918) leavesub [1]
LISTOP (0x82b08d8) lineseq
COP (0x82b0880) nextstate
UNOP (0x82b0860) null [15]
PADOP (0x82b0840) gvsv GV (0x82a818c) *a
EOT_EOT
# UNOP (0x8282310) leavesub [1]
# LISTOP (0x82822f0) lineseq
# COP (0x82822b8) nextstate
# UNOP (0x812fc20) null [15]
# SVOP (0x812fc00) gvsv GV (0x814692c) *a
EONT_EONT
checkOptree ( name => "sticky-terse exec",
bcopts => [qw/ -exec /],
code => sub{$a},
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
COP (0x82b0d70) nextstate
PADOP (0x82b0d30) gvsv GV (0x82a818c) *a
UNOP (0x82b0e08) leavesub [1]
EOT_EOT
# COP (0x82828e0) nextstate
# SVOP (0x82828a0) gvsv GV (0x814692c) *a
# UNOP (0x8282938) leavesub [1]
EONT_EONT
pass("OPTIONS IN CMDLINE MODE");
checkOptree ( name => 'cmdline invoke -basic works',
prog => 'sort @a',
errs => [ 'Useless use of sort in void context at -e line 1.',
'Name "main::a" used only once: possible typo at -e line 1.',
],
#bcopts => '-basic', # default
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 7 <@> leave[1 ref] vKP/REFC ->(end)
# 1 <0> enter ->2
# 2 <;> nextstate(main 1 -e:1) v ->3
# 6 <@> sort vK ->7
# 3 <0> pushmark s ->4
# 5 <1> rv2av[t2] lK/1 ->6
# 4 <#> gv[*a] s ->5
EOT_EOT
# 7 <@> leave[1 ref] vKP/REFC ->(end)
# 1 <0> enter ->2
# 2 <;> nextstate(main 1 -e:1) v ->3
# 6 <@> sort vK ->7
# 3 <0> pushmark s ->4
# 5 <1> rv2av[t1] lK/1 ->6
# 4 <$> gv(*a) s ->5
EONT_EONT
checkOptree ( name => 'cmdline invoke -exec works',
prog => 'sort @a',
errs => [ 'Useless use of sort in void context at -e line 1.',
'Name "main::a" used only once: possible typo at -e line 1.',
],
bcopts => '-exec',
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
1 <0> enter
2 <;> nextstate(main 1 -e:1) v
3 <0> pushmark s
4 <#> gv[*a] s
5 <1> rv2av[t2] lK/1
6 <@> sort vK
7 <@> leave[1 ref] vKP/REFC
EOT_EOT
# 1 <0> enter
# 2 <;> nextstate(main 1 -e:1) v
# 3 <0> pushmark s
# 4 <$> gv(*a) s
# 5 <1> rv2av[t1] lK/1
# 6 <@> sort vK
# 7 <@> leave[1 ref] vKP/REFC
EONT_EONT
;
checkOptree
( name => 'cmdline self-strict compile err using prog',
prog => 'use strict; sort @a',
bcopts => [qw/ -basic -concise -exec /],
errs => 'Global symbol "@a" requires explicit package name at -e line 1.',
expect => 'nextstate',
expect_nt => 'nextstate',
noanchors => 1, # allow simple expectations to work
);
checkOptree
( name => 'cmdline self-strict compile err using code',
code => 'use strict; sort @a',
bcopts => [qw/ -basic -concise -exec /],
errs => 'Global symbol "@a" requires explicit package name at .*? line 1.',
note => 'this test relys on a kludge which copies $@ to rendering when empty',
expect => 'Global symbol',
expect_nt => 'Global symbol',
noanchors => 1, # allow simple expectations to work
);
checkOptree
( name => 'cmdline -basic -concise -exec works',
prog => 'our @a; sort @a',
bcopts => [qw/ -basic -concise -exec /],
errs => ['Useless use of sort in void context at -e line 1.'],
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1 <0> enter
# 2 <;> nextstate(main 1 -e:1) v
# 3 <#> gv[*a] s
# 4 <1> rv2av[t3] vK/OURINTR,1
# 5 <;> nextstate(main 2 -e:1) v
# 6 <0> pushmark s
# 7 <#> gv[*a] s
# 8 <1> rv2av[t5] lK/1
# 9 <@> sort vK
# a <@> leave[1 ref] vKP/REFC
EOT_EOT
# 1 <0> enter
# 2 <;> nextstate(main 1 -e:1) v
# 3 <$> gv(*a) s
# 4 <1> rv2av[t2] vK/OURINTR,1
# 5 <;> nextstate(main 2 -e:1) v
# 6 <0> pushmark s
# 7 <$> gv(*a) s
# 8 <1> rv2av[t3] lK/1
# 9 <@> sort vK
# a <@> leave[1 ref] vKP/REFC
EONT_EONT
#################################
pass("B::Concise STYLE/CALLBACK TESTS");
use B::Concise qw( walk_output add_style set_style_standard add_callback );
# new relative style, added by set_up_relative_test()
@stylespec =
( "#hyphseq2 (*( (x( ;)x))*)<#classsym> "
. "#exname#arg(?([#targarglife])?)~#flags(?(/#privateb)?)(x(;~->#next)x) "
. "(x(;~=> #extra)x)\n" # new 'variable' used here
, " (*( )*) goto #seq\n"
, "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"
#. "(x(;~=> #extra)x)\n" # new 'variable' used here
);
sub set_up_relative_test {
# add a new style, and a callback which adds an 'extra' property
add_style ( "relative" => @stylespec );
#set_style_standard ( "relative" );
add_callback
( sub {
my ($h, $op, $format, $level, $style) = @_;
# callback marks up const ops
$h->{arg} .= ' CALLBACK' if $h->{name} eq 'const';
$h->{extra} = '';
if ($lastnext and $$lastnext != $$op) {
$h->{goto} = ($h->{seq} eq '-')
? 'unresolved' : $h->{seq};
}
# 2 style specific behaviors
if ($style eq 'relative') {
$h->{extra} = 'RELATIVE';
$h->{arg} .= ' RELATIVE' if $h->{name} eq 'leavesub';
}
elsif ($style eq 'scope') {
# supress printout entirely
$$format="" unless grep { $h->{name} eq $_ } @scopeops;
}
});
}
#################################
set_up_relative_test();
pass("set_up_relative_test, new callback installed");
checkOptree ( name => 'callback used, independent of style',
bcopts => [qw/ -concise -exec /],
code => sub{$a=$b+42},
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
1 <;> nextstate(main 76 optree_concise.t:337) v
2 <#> gvsv[*b] s
3 <$> const[IV 42] CALLBACK s
4 <2> add[t3] sK/2
5 <#> gvsv[*a] s
6 <2> sassign sKS/2
7 <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 455 optree_concise.t:328) v
# 2 <$> gvsv(*b) s
# 3 <$> const(IV 42) CALLBACK s
# 4 <2> add[t1] sK/2
# 5 <$> gvsv(*a) s
# 6 <2> sassign sKS/2
# 7 <1> leavesub[1 ref] K/REFC,1
EONT_EONT
checkOptree ( name => "new 'relative' style, -exec mode",
bcopts => [qw/ -basic -relative /],
code => sub{$a=$b+42},
crossfail => 1,
#retry => 1,
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
7 <1> leavesub RELATIVE[1 ref] K ->(end) => RELATIVE
- <@> lineseq KP ->7 => RELATIVE
1 <;> nextstate(main 49 optree_concise.t:309) v ->2 => RELATIVE
6 <2> sassign sKS ->7 => RELATIVE
4 <2> add[t3] sK ->5 => RELATIVE
- <1> ex-rv2sv sK ->3 => RELATIVE
2 <#> gvsv[*b] s ->3 => RELATIVE
3 <$> const[IV 42] CALLBACK s ->4 => RELATIVE
- <1> ex-rv2sv sKRM* ->6 => RELATIVE
5 <#> gvsv[*a] s ->6 => RELATIVE
EOT_EOT
# 7 <1> leavesub RELATIVE[1 ref] K ->(end) => RELATIVE
# - <@> lineseq KP ->7 => RELATIVE
# 1 <;> nextstate(main 77 optree_concise.t:353) v ->2 => RELATIVE
# 6 <2> sassign sKS ->7 => RELATIVE
# 4 <2> add[t1] sK ->5 => RELATIVE
# - <1> ex-rv2sv sK ->3 => RELATIVE
# 2 <$> gvsv(*b) s ->3 => RELATIVE
# 3 <$> const(IV 42) CALLBACK s ->4 => RELATIVE
# - <1> ex-rv2sv sKRM* ->6 => RELATIVE
# 5 <$> gvsv(*a) s ->6 => RELATIVE
EONT_EONT
checkOptree ( name => "both -exec -relative",
bcopts => [qw/ -exec -relative /],
code => sub{$a=$b+42},
crossfail => 1,
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
1 <;> nextstate(main 50 optree_concise.t:326) v
2 <#> gvsv[*b] s
3 <$> const[IV 42] CALLBACK s
4 <2> add[t3] sK
5 <#> gvsv[*a] s
6 <2> sassign sKS
7 <1> leavesub RELATIVE[1 ref] K
EOT_EOT
# 1 <;> nextstate(main 78 optree_concise.t:371) v
# 2 <$> gvsv(*b) s
# 3 <$> const(IV 42) CALLBACK s
# 4 <2> add[t1] sK
# 5 <$> gvsv(*a) s
# 6 <2> sassign sKS
# 7 <1> leavesub RELATIVE[1 ref] K
EONT_EONT
#################################
@scopeops = qw( leavesub enter leave nextstate );
add_style
( 'scope' # concise copy
, "#hyphseq2 (*( (x( ;)x))*)<#classsym> "
. "#exname#arg(?([#targarglife])?)~#flags(?(/#private)?)(x(;~->#next)x) "
, " (*( )*) goto #seq\n"
, "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"
);
checkOptree ( name => "both -exec -scope",
bcopts => [qw/ -exec -scope /],
code => sub{$a=$b+42},
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
1 <;> nextstate(main 50 optree_concise.t:337) v
7 <1> leavesub[1 ref] K/REFC,1
EOT_EOT
1 <;> nextstate(main 75 optree_concise.t:396) v
7 <1> leavesub[1 ref] K/REFC,1
EONT_EONT
checkOptree ( name => "both -basic -scope",
bcopts => [qw/ -basic -scope /],
code => sub{$a=$b+42},
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
7 <1> leavesub[1 ref] K/REFC,1 ->(end)
1 <;> nextstate(main 51 optree_concise.t:347) v ->2
EOT_EOT
7 <1> leavesub[1 ref] K/REFC,1 ->(end)
1 <;> nextstate(main 76 optree_concise.t:407) v ->2
EONT_EONT
} #skip
--- NEW FILE: f_map ---
#!perl
# examples shamelessly snatched from perldoc -f map
# translates a list of numbers to the corresponding characters.
@chars = map(chr, @nums);
%hash = map { getkey($_) => $_ } @array;
{
%hash = ();
foreach $_ (@array) {
$hash{getkey($_)} = $_;
}
}
#%hash = map { "\L$_", 1 } @array; # perl guesses EXPR. wrong
%hash = map { +"\L$_", 1 } @array; # perl guesses BLOCK. right
%hash = map { ("\L$_", 1) } @array; # this also works
%hash = map { lc($_), 1 } @array; # as does this.
%hash = map +( lc($_), 1 ), @array; # this is EXPR and works!
%hash = map ( lc($_), 1 ), @array; # evaluates to (1, @array)
@hashes = map +{ lc($_), 1 }, @array # EXPR, so needs , at end
--- NEW FILE: asmdata.t ---
#!./perl -Tw
BEGIN {
if ($ENV{PERL_CORE}){
chdir('t') if -d 't';
@INC = ('.', '../lib');
} else {
unshift @INC, 't';
}
require Config;
if (($Config::Config{'extensions'} !~ /\bB\b/) ){
print "1..0 # Skip -- Perl configured without B module\n";
exit 0;
}
}
use Test::More tests => 13;
use_ok('B::Asmdata', qw(%insn_data @insn_name @optype @specialsv_name));
# check we got something.
isnt( keys %insn_data, 0, '%insn_data exported and populated' );
isnt( @insn_name, 0, ' @insn_name' );
isnt( @optype, 0, ' @optype' );
isnt( @specialsv_name, 0, ' @specialsv_name' );
# pick an op that's not likely to go away in the future
my @data = values %insn_data;
is( (grep { ref eq 'ARRAY' } @data), @data, '%insn_data contains arrays' );
# pick one at random to test with.
my $opname = (keys %insn_data)[rand @data];
my $data = $insn_data{$opname};
like( $data->[0], qr/^\d+$/, ' op number' );
is( ref $data->[1], 'CODE', ' PUT code ref' );
ok( !ref $data->[2], ' GET method' );
is( $insn_name[$data->[0]], $opname, '@insn_name maps correctly' );
# I'm going to assume that op types will all be named /OP$/.
# If this changes in the future, change this test.
is( grep(/OP$/, @optype), @optype, '@optype is all /OP$/' );
# comment in bytecode.pl says "Nullsv *must come first so that the
# condition ($$sv == 0) can continue to be used to test (sv == Nullsv)."
is( $specialsv_name[0], 'Nullsv', 'Nullsv come first in @special_sv_name' );
# other than that, we can't really say much more about @specialsv_name
# than it has to contain strings (on the off chance &PL_sv_undef gets
# flubbed)
is( grep(!ref, @specialsv_name), @specialsv_name, ' contains all strings' );
--- NEW FILE: f_sort ---
#!perl
#examples poached from perldoc -f sort
# sort lexically
@articles = sort @files;
# same thing, but with explicit sort routine
@articles = sort {$a cmp $b} @files;
# now case-insensitively
@articles = sort {uc($a) cmp uc($b)} @files;
# same thing in reversed order
@articles = sort {$b cmp $a} @files;
# sort numerically ascending
@articles = sort {$a <=> $b} @files;
# sort numerically descending
@articles = sort {$b <=> $a} @files;
# this sorts the %age hash by value instead of key
# using an in-line function
@eldest = sort { $age{$b} <=> $age{$a} } keys %age;
# sort using explicit subroutine name
sub byage {
$age{$a} <=> $age{$b}; # presuming numeric
}
@sortedclass = sort byage @class;
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
# 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 ];
# same thing, but without any temps
@new = map { $_->[0] }
sort { $b->[1] <=> $a->[1]
|| $a->[2] cmp $b->[2]
} map { [$_, /=(\d+)/, uc($_)] } @old;
# 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;
# repeat, condensed. $main::a and $b are unaffected
sub other::backwards ($$) { $_[1] cmp $_[0]; }
@new = sort other::backwards @old;
# guarantee stability, regardless of algorithm
use sort 'stable';
@new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old;
# 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;
# you should have a good reason to do this!
@articles = sort {$FooPack::b <=> $FooPack::a} @files;
# fancy
@result = sort { $a <=> $b } grep { $_ == $_ } @input;
# void return context sort
sort { $a <=> $b } @input;
# more void context, propagating ?
sort { $a <=> $b } grep { $_ == $_ } @input;
# scalar return context sort
$s = sort { $a <=> $b } @input;
$s = sort { $a <=> $b } grep { $_ == $_ } @input;
--- NEW FILE: lint.t ---
#!./perl -w
BEGIN {
if ($ENV{PERL_CORE}){
chdir('t') if -d 't';
@INC = ('.', '../lib');
} 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;
}
require 'test.pl';
}
plan tests => 15; # adjust also number of skipped tests !
# Runs a separate perl interpreter with the appropriate lint options
# turned on
sub runlint ($$$;$) {
my ($opts,$prog,$result,$testname) = @_;
my $res = runperl(
switches => [ "-MO=Lint,$opts" ],
prog => $prog,
stderr => 1,
);
$res =~ s/-e syntax OK\n$//;
is( $res, $result, $testname || $opts );
}
runlint 'context', '$foo = @bar', <<'RESULT';
Implicit scalar context for array in scalar assignment at -e line 1
RESULT
runlint 'context', '$foo = length @bar', <<'RESULT';
Implicit scalar context for array in length at -e line 1
RESULT
runlint 'implicit-read', '/foo/', <<'RESULT';
Implicit match on $_ at -e line 1
RESULT
runlint 'implicit-write', 's/foo/bar/', <<'RESULT';
Implicit substitution on $_ at -e line 1
RESULT
SKIP : {
use Config;
skip("Doesn't work with threaded perls",11)
if $Config{useithreads} || ($] < 5.009 && $Config{use5005threads});
runlint 'implicit-read', '1 for @ARGV', <<'RESULT', 'implicit-read in foreach';
Implicit use of $_ in foreach at -e line 1
RESULT
runlint 'dollar-underscore', '$_ = 1', <<'RESULT';
Use of $_ at -e line 1
RESULT
runlint 'dollar-underscore', 'print', <<'RESULT', 'dollar-underscore in print';
Use of $_ at -e line 1
RESULT
runlint 'private-names', 'sub A::_f{};A::_f()', <<'RESULT';
Illegal reference to private name _f at -e line 1
RESULT
runlint 'private-names', '$A::_x', <<'RESULT';
Illegal reference to private name _x at -e line 1
RESULT
runlint 'private-names', 'sub A::_f{};A->_f()', <<'RESULT',
Illegal reference to private method name _f at -e line 1
RESULT
'private-names (method)';
runlint 'undefined-subs', 'foo()', <<'RESULT';
Undefined subroutine foo called at -e line 1
RESULT
runlint 'regexp-variables', 'print $&', <<'RESULT';
Use of regexp variable $& at -e line 1
RESULT
runlint 'regexp-variables', 's/./$&/', <<'RESULT';
Use of regexp variable $& at -e line 1
RESULT
runlint 'bare-subs', 'sub bare(){1};$x=bare', '';
runlint 'bare-subs', 'sub bare(){1}; $x=[bare=>0]; $x=$y{bare}', <<'RESULT';
Bare sub name 'bare' interpreted as string at -e line 1
Bare sub name 'bare' interpreted as string at -e line 1
RESULT
}
--- NEW FILE: stash.t ---
#!./perl
BEGIN {
if ($ENV{PERL_CORE}){
chdir('t') if -d 't';
if ($^O eq 'MacOS') {
@INC = qw(: ::lib ::macos:lib);
} else {
@INC = '.';
push @INC, '../lib';
}
} else {
unshift @INC, 't';
}
require Config;
if (($Config::Config{'extensions'} !~ /\bB\b/) ){
print "1..0 # Skip -- Perl configured without B module\n";
exit 0;
}
}
$| = 1;
use warnings;
use strict;
use Config;
print "1..1\n";
my $test = 1;
sub ok { print "ok $test\n"; $test++ }
my $got;
my $Is_VMS = $^O eq 'VMS';
my $Is_MacOS = $^O eq 'MacOS';
my $path = join " ", map { qq["-I$_"] } @INC;
$path = '"-I../lib" "-Iperl_root:[lib]"' if $Is_VMS; # gets too long otherwise
my $redir = $Is_MacOS ? "" : "2>&1";
chomp($got = `$^X $path "-MB::Stash" "-Mwarnings" -e1`);
$got =~ s/-u//g;
print "# got = $got\n";
my @got = map { s/^\S+ //; $_ }
sort { $a cmp $b }
map { lc($_) . " " . $_ }
split /,/, $got;
print "# (after sorting)\n";
print "# got = @got\n";
@got = grep { ! /^(PerlIO|open)(?:::\w+)?$/ } @got;
print "# (after perlio censorings)\n";
print "# got = @got\n";
@got = grep { ! /^Win32$/ } @got if $^O eq 'MSWin32';
@got = grep { ! /^NetWare$/ } @got if $^O eq 'NetWare';
@got = grep { ! /^(Cwd|File|File::Copy|OS2)$/ } @got if $^O eq 'os2';
@got = grep { ! /^(Cwd|Cygwin)$/ } @got if $^O eq 'cygwin';
if ($Is_VMS) {
@got = grep { ! /^File(?:::Copy)?$/ } @got;
@got = grep { ! /^VMS(?:::Filespec)?$/ } @got;
@got = grep { ! /^vmsish$/ } @got;
# Socket is optional/compiler version dependent
@got = grep { ! /^Socket$/ } @got;
}
print "# (after platform censorings)\n";
print "# got = @got\n";
$got = "@got";
my $expected = "attributes Carp Carp::Heavy DB Internals main Regexp utf8 version warnings";
if ($] < 5.009) {
$expected =~ s/version //;
$expected =~ s/DB/DB Exporter Exporter::Heavy/;
}
{
no strict 'vars';
use vars '$OS2::is_aout';
}
if ((($Config{static_ext} eq ' ') || ($Config{static_ext} eq ''))
&& !($^O eq 'os2' and $OS2::is_aout)
) {
print "# got [$got]\n# vs.\n# expected [$expected]\nnot " if $got ne $expected;
ok;
} else {
print "ok $test # skipped: one or more static extensions\n"; $test++;
}
--- NEW FILE: optree_varinit.t ---
#!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;
}
# require 'test.pl'; # now done by OptreeCheck
}
use OptreeCheck;
use Config;
plan tests => 22;
SKIP: {
skip "no perlio in this build", 22 unless $Config::Config{useperlio};
pass("OPTIMIZER TESTS - VAR INITIALIZATION");
checkOptree ( name => 'sub {my $a}',
bcopts => '-exec',
code => sub {my $a},
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1 <;> nextstate(main 45 optree.t:23) v
# 2 <0> padsv[$a:45,46] M/LVINTRO
# 3 <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 45 optree.t:23) v
# 2 <0> padsv[$a:45,46] M/LVINTRO
# 3 <1> leavesub[1 ref] K/REFC,1
EONT_EONT
checkOptree ( name => '-exec sub {my $a}',
bcopts => '-exec',
code => sub {my $a},
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1 <;> nextstate(main 49 optree.t:52) v
# 2 <0> padsv[$a:49,50] M/LVINTRO
# 3 <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 49 optree.t:45) v
# 2 <0> padsv[$a:49,50] M/LVINTRO
# 3 <1> leavesub[1 ref] K/REFC,1
EONT_EONT
checkOptree ( name => 'sub {our $a}',
bcopts => '-exec',
code => sub {our $a},
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
1 <;> nextstate(main 21 optree.t:47) v
2 <#> gvsv[*a] s/OURINTR
3 <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 51 optree.t:56) v
# 2 <$> gvsv(*a) s/OURINTR
# 3 <1> leavesub[1 ref] K/REFC,1
EONT_EONT
checkOptree ( name => 'sub {local $a}',
bcopts => '-exec',
code => sub {local $a},
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
1 <;> nextstate(main 23 optree.t:57) v
2 <#> gvsv[*a] s/LVINTRO
3 <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 53 optree.t:67) v
# 2 <$> gvsv(*a) s/LVINTRO
# 3 <1> leavesub[1 ref] K/REFC,1
EONT_EONT
checkOptree ( name => 'my $a',
prog => 'my $a',
bcopts => '-basic',
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 4 <@> leave[1 ref] vKP/REFC ->(end)
# 1 <0> enter ->2
# 2 <;> nextstate(main 1 -e:1) v ->3
# 3 <0> padsv[$a:1,2] vM/LVINTRO ->4
EOT_EOT
# 4 <@> leave[1 ref] vKP/REFC ->(end)
# 1 <0> enter ->2
# 2 <;> nextstate(main 1 -e:1) v ->3
# 3 <0> padsv[$a:1,2] vM/LVINTRO ->4
EONT_EONT
checkOptree ( name => 'our $a',
prog => 'our $a',
bcopts => '-basic',
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
4 <@> leave[1 ref] vKP/REFC ->(end)
1 <0> enter ->2
2 <;> nextstate(main 1 -e:1) v ->3
- <1> ex-rv2sv vK/17 ->4
3 <#> gvsv[*a] s/OURINTR ->4
EOT_EOT
# 4 <@> leave[1 ref] vKP/REFC ->(end)
# 1 <0> enter ->2
# 2 <;> nextstate(main 1 -e:1) v ->3
# - <1> ex-rv2sv vK/17 ->4
# 3 <$> gvsv(*a) s/OURINTR ->4
EONT_EONT
checkOptree ( name => 'local $a',
prog => 'local $a',
errs => ['Name "main::a" used only once: possible typo at -e line 1.'],
bcopts => '-basic',
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
4 <@> leave[1 ref] vKP/REFC ->(end)
1 <0> enter ->2
2 <;> nextstate(main 1 -e:1) v ->3
- <1> ex-rv2sv vKM/129 ->4
3 <#> gvsv[*a] s/LVINTRO ->4
EOT_EOT
# 4 <@> leave[1 ref] vKP/REFC ->(end)
# 1 <0> enter ->2
# 2 <;> nextstate(main 1 -e:1) v ->3
# - <1> ex-rv2sv vKM/129 ->4
# 3 <$> gvsv(*a) s/LVINTRO ->4
EONT_EONT
pass("MY, OUR, LOCAL, BOTH SUB AND MAIN, = undef");
checkOptree ( name => 'sub {my $a=undef}',
code => sub {my $a=undef},
bcopts => '-basic',
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
5 <1> leavesub[1 ref] K/REFC,1 ->(end)
- <@> lineseq KP ->5
1 <;> nextstate(main 641 optree_varinit.t:130) v ->2
4 <2> sassign sKS/2 ->5
2 <0> undef s ->3
3 <0> padsv[$a:641,642] sRM*/LVINTRO ->4
EOT_EOT
# 5 <1> leavesub[1 ref] K/REFC,1 ->(end)
# - <@> lineseq KP ->5
# 1 <;> nextstate(main 641 optree_varinit.t:130) v ->2
# 4 <2> sassign sKS/2 ->5
# 2 <0> undef s ->3
# 3 <0> padsv[$a:641,642] sRM*/LVINTRO ->4
EONT_EONT
checkOptree ( name => 'sub {our $a=undef}',
code => sub {our $a=undef},
note => 'the global must be reset',
bcopts => '-basic',
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
5 <1> leavesub[1 ref] K/REFC,1 ->(end)
- <@> lineseq KP ->5
1 <;> nextstate(main 26 optree.t:109) v ->2
4 <2> sassign sKS/2 ->5
2 <0> undef s ->3
- <1> ex-rv2sv sKRM*/17 ->4
3 <#> gvsv[*a] s/OURINTR ->4
EOT_EOT
# 5 <1> leavesub[1 ref] K/REFC,1 ->(end)
# - <@> lineseq KP ->5
# 1 <;> nextstate(main 446 optree_varinit.t:137) v ->2
# 4 <2> sassign sKS/2 ->5
# 2 <0> undef s ->3
# - <1> ex-rv2sv sKRM*/17 ->4
# 3 <$> gvsv(*a) s/OURINTR ->4
EONT_EONT
checkOptree ( name => 'sub {local $a=undef}',
code => sub {local $a=undef},
note => 'local not used enough to bother',
bcopts => '-basic',
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
5 <1> leavesub[1 ref] K/REFC,1 ->(end)
- <@> lineseq KP ->5
1 <;> nextstate(main 28 optree.t:122) v ->2
4 <2> sassign sKS/2 ->5
2 <0> undef s ->3
- <1> ex-rv2sv sKRM*/129 ->4
3 <#> gvsv[*a] s/LVINTRO ->4
EOT_EOT
# 5 <1> leavesub[1 ref] K/REFC,1 ->(end)
# - <@> lineseq KP ->5
# 1 <;> nextstate(main 58 optree.t:141) v ->2
# 4 <2> sassign sKS/2 ->5
# 2 <0> undef s ->3
# - <1> ex-rv2sv sKRM*/129 ->4
# 3 <$> gvsv(*a) s/LVINTRO ->4
EONT_EONT
checkOptree ( name => 'my $a=undef',
prog => 'my $a=undef',
bcopts => '-basic',
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
6 <@> leave[1 ref] vKP/REFC ->(end)
1 <0> enter ->2
2 <;> nextstate(main 1 -e:1) v ->3
5 <2> sassign vKS/2 ->6
3 <0> undef s ->4
4 <0> padsv[$a:1,2] sRM*/LVINTRO ->5
EOT_EOT
# 6 <@> leave[1 ref] vKP/REFC ->(end)
# 1 <0> enter ->2
# 2 <;> nextstate(main 1 -e:1) v ->3
# 5 <2> sassign vKS/2 ->6
# 3 <0> undef s ->4
# 4 <0> padsv[$a:1,2] sRM*/LVINTRO ->5
EONT_EONT
checkOptree ( name => 'our $a=undef',
prog => 'our $a=undef',
note => 'global must be reassigned',
bcopts => '-basic',
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
6 <@> leave[1 ref] vKP/REFC ->(end)
1 <0> enter ->2
2 <;> nextstate(main 1 -e:1) v ->3
5 <2> sassign vKS/2 ->6
3 <0> undef s ->4
- <1> ex-rv2sv sKRM*/17 ->5
4 <#> gvsv[*a] s/OURINTR ->5
EOT_EOT
# 6 <@> leave[1 ref] vKP/REFC ->(end)
# 1 <0> enter ->2
# 2 <;> nextstate(main 1 -e:1) v ->3
# 5 <2> sassign vKS/2 ->6
# 3 <0> undef s ->4
# - <1> ex-rv2sv sKRM*/17 ->5
# 4 <$> gvsv(*a) s/OURINTR ->5
EONT_EONT
checkOptree ( name => 'local $a=undef',
prog => 'local $a=undef',
errs => ['Name "main::a" used only once: possible typo at -e line 1.'],
note => 'locals are rare, probly not worth doing',
bcopts => '-basic',
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
6 <@> leave[1 ref] vKP/REFC ->(end)
1 <0> enter ->2
2 <;> nextstate(main 1 -e:1) v ->3
5 <2> sassign vKS/2 ->6
3 <0> undef s ->4
- <1> ex-rv2sv sKRM*/129 ->5
4 <#> gvsv[*a] s/LVINTRO ->5
EOT_EOT
# 6 <@> leave[1 ref] vKP/REFC ->(end)
# 1 <0> enter ->2
# 2 <;> nextstate(main 1 -e:1) v ->3
# 5 <2> sassign vKS/2 ->6
# 3 <0> undef s ->4
# - <1> ex-rv2sv sKRM*/129 ->5
# 4 <$> gvsv(*a) s/LVINTRO ->5
EONT_EONT
checkOptree ( name => 'sub {my $a=()}',
code => sub {my $a=()},
bcopts => '-exec',
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
1 <;> nextstate(main -439 optree.t:105) v
2 <0> stub sP
3 <0> padsv[$a:-439,-438] sRM*/LVINTRO
4 <2> sassign sKS/2
5 <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 438 optree_varinit.t:247) v
# 2 <0> stub sP
# 3 <0> padsv[$a:438,439] sRM*/LVINTRO
# 4 <2> sassign sKS/2
# 5 <1> leavesub[1 ref] K/REFC,1
EONT_EONT
checkOptree ( name => 'sub {our $a=()}',
code => sub {our $a=()},
#todo => 'probly not worth doing',
bcopts => '-exec',
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
1 <;> nextstate(main 31 optree.t:177) v
2 <0> stub sP
3 <#> gvsv[*a] s/OURINTR
4 <2> sassign sKS/2
5 <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 440 optree_varinit.t:262) v
# 2 <0> stub sP
# 3 <$> gvsv(*a) s/OURINTR
# 4 <2> sassign sKS/2
# 5 <1> leavesub[1 ref] K/REFC,1
EONT_EONT
checkOptree ( name => 'sub {local $a=()}',
code => sub {local $a=()},
#todo => 'probly not worth doing',
bcopts => '-exec',
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
1 <;> nextstate(main 33 optree.t:190) v
2 <0> stub sP
3 <#> gvsv[*a] s/LVINTRO
4 <2> sassign sKS/2
5 <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 63 optree.t:225) v
# 2 <0> stub sP
# 3 <$> gvsv(*a) s/LVINTRO
# 4 <2> sassign sKS/2
# 5 <1> leavesub[1 ref] K/REFC,1
EONT_EONT
checkOptree ( name => 'my $a=()',
prog => 'my $a=()',
bcopts => '-exec',
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
1 <0> enter
2 <;> nextstate(main 1 -e:1) v
3 <0> stub sP
4 <0> padsv[$a:1,2] sRM*/LVINTRO
5 <2> sassign vKS/2
6 <@> leave[1 ref] vKP/REFC
EOT_EOT
# 1 <0> enter
# 2 <;> nextstate(main 1 -e:1) v
# 3 <0> stub sP
# 4 <0> padsv[$a:1,2] sRM*/LVINTRO
# 5 <2> sassign vKS/2
# 6 <@> leave[1 ref] vKP/REFC
EONT_EONT
checkOptree ( name => 'our $a=()',
prog => 'our $a=()',
#todo => 'probly not worth doing',
bcopts => '-exec',
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
1 <0> enter
2 <;> nextstate(main 1 -e:1) v
3 <0> stub sP
4 <#> gvsv[*a] s/OURINTR
5 <2> sassign vKS/2
6 <@> leave[1 ref] vKP/REFC
EOT_EOT
# 1 <0> enter
# 2 <;> nextstate(main 1 -e:1) v
# 3 <0> stub sP
# 4 <$> gvsv(*a) s/OURINTR
# 5 <2> sassign vKS/2
# 6 <@> leave[1 ref] vKP/REFC
EONT_EONT
checkOptree ( name => 'local $a=()',
prog => 'local $a=()',
errs => ['Name "main::a" used only once: possible typo at -e line 1.'],
#todo => 'probly not worth doing',
bcopts => '-exec',
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
1 <0> enter
2 <;> nextstate(main 1 -e:1) v
3 <0> stub sP
4 <#> gvsv[*a] s/LVINTRO
5 <2> sassign vKS/2
6 <@> leave[1 ref] vKP/REFC
EOT_EOT
# 1 <0> enter
# 2 <;> nextstate(main 1 -e:1) v
# 3 <0> stub sP
# 4 <$> gvsv(*a) s/LVINTRO
# 5 <2> sassign vKS/2
# 6 <@> leave[1 ref] vKP/REFC
EONT_EONT
checkOptree ( name => 'my ($a,$b)=()',
prog => 'my ($a,$b)=()',
#todo => 'probly not worth doing',
bcopts => '-exec',
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1 <0> enter
# 2 <;> nextstate(main 1 -e:1) v
# 3 <0> pushmark s
# 4 <0> pushmark sRM*/128
# 5 <0> padsv[$a:1,2] lRM*/LVINTRO
# 6 <0> padsv[$b:1,2] lRM*/LVINTRO
# 7 <2> aassign[t3] vKS
# 8 <@> leave[1 ref] vKP/REFC
EOT_EOT
# 1 <0> enter
# 2 <;> nextstate(main 1 -e:1) v
# 3 <0> pushmark s
# 4 <0> pushmark sRM*/128
# 5 <0> padsv[$a:1,2] lRM*/LVINTRO
# 6 <0> padsv[$b:1,2] lRM*/LVINTRO
# 7 <2> aassign[t3] vKS
# 8 <@> leave[1 ref] vKP/REFC
EONT_EONT
} #skip
__END__
--- NEW FILE: OptreeCheck.pm ---
package OptreeCheck;
use base 'Exporter';
require "test.pl";
our $VERSION = '0.01';
# now export checkOptree, and those test.pl functions used by tests
our @EXPORT = qw( checkOptree plan skip skip_all pass is like unlike
require_ok runperl );
=head1 NAME
OptreeCheck - check optrees as rendered by B::Concise
=head1 SYNOPSIS
OptreeCheck supports 'golden-sample' regression testing of perl's
parser, optimizer, bytecode generator, via a single function:
[...1029 lines suppressed...]
./perl -Ilib ext/B/t/OptreeCheck.pm -w ext/B/t/f_map
./perl -Ilib ext/B/t/OptreeCheck.pm -w ext/B/t/f_sort
gentest reads the sample code, runs each to generate a reference
rendering, folds this rendering into an optreeCheck() statement,
and prints it to stdout.
3. run the output file as above, redirect to files, then rerun on
same build (for sanity check), and on thread-opposite build. With
editor in 1 window, and cmd in other, it's fairly easy to cut-paste
the gots into the expects, easier than running step 2 on both
builds then trying to sdiff them together.
=head1 CAVEATS
This code is purely for testing core. While checkOptree feels flexible
enough to be stable, the whole selftest framework is subject to change
w/o notice.
=cut
--- NEW FILE: o.t ---
#!./perl -w
BEGIN {
if ($ENV{PERL_CORE}){
chdir('t') if -d 't';
@INC = ('.', 'lib', '../lib');
} 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;
}
require 'test.pl';
}
use strict;
use Config;
use File::Spec;
use File::Path;
my $path = File::Spec->catdir( 'lib', 'B' );
unless (-d $path) {
mkpath( $path ) or skip_all( 'Cannot create fake module path' );
}
my $file = File::Spec->catfile( $path, 'success.pm' );
local *OUT;
open(OUT, '>', $file) or skip_all( 'Cannot write fake backend module');
print OUT while <DATA>;
close *OUT;
plan( 9 ); # And someone's responsible.
# use() makes it difficult to avoid O::import()
require_ok( 'O' );
my @args = ('-Ilib', '-MO=success,foo,bar', '-e', '1' );
my @lines = get_lines( @args );
is( $lines[0], 'Compiling!', 'Output should not be saved without -q switch' );
is( $lines[1], '(foo) <bar>', 'O.pm should call backend compile() method' );
is( $lines[2], '[]', 'Nothing should be in $O::BEGIN_output without -q' );
is( $lines[3], '-e syntax OK', 'O.pm should not munge perl output without -qq');
$args[1] = '-MO=-q,success,foo,bar';
@lines = get_lines( @args );
isnt( $lines[1], 'Compiling!', 'Output should not be printed with -q switch' );
SKIP: {
skip( '-q redirection does not work without PerlIO', 2)
unless $Config{useperlio};
is( $lines[1], "[Compiling!", '... but should be in $O::BEGIN_output' );
$args[1] = '-MO=-qq,success,foo,bar';
@lines = get_lines( @args );
is( scalar @lines, 3, '-qq should suppress even the syntax OK message' );
}
$args[1] = '-MO=success,fail';
@lines = get_lines( @args );
like( $lines[1], qr/fail at .eval/,
'O.pm should die if backend compile() does not return a subref' );
sub get_lines {
split(/[\r\n]+/, runperl( args => [ @_ ], stderr => 1 ));
}
END {
1 while unlink($file);
rmdir($path); # not "1 while" since there might be more in there
}
__END__
package B::success;
$| = 1;
print "Compiling!\n";
sub compile {
return 'fail' if ($_[0] eq 'fail');
print "($_[0]) <$_[1]>\n";
return sub { print "[$O::BEGIN_output]\n" };
}
1;
--- NEW FILE: xref.t ---
#!./perl
BEGIN {
if ($ENV{PERL_CORE}){
chdir('t') if -d 't';
@INC = ('.', '../lib');
} else {
unshift @INC, 't';
}
require Config;
if (($Config::Config{'extensions'} !~ /\bB\b/) ){
print "1..0 # Skip -- Perl configured without B module\n";
exit 0;
}
}
use strict;
use warnings;
no warnings 'once';
use Test::More tests => 14;
# line 50
use_ok( 'B::Xref' );
my $file = 'xreftest.out';
open SAVEOUT, ">&STDOUT" or diag $!;
close STDOUT;
# line 100
our $compilesub = B::Xref::compile("-o$file");
ok( ref $compilesub eq 'CODE', "compile() returns a coderef ($compilesub)" );
$compilesub->(); # Compile this test script
close STDOUT;
open STDOUT, ">&SAVEOUT" or diag $!;
# Now parse the output
# line 200
my ($curfile, $cursub, $curpack) = ('') x 3;
our %xreftable = ();
open XREF, $file or die "# Can't open $file: $!\n";
while (<XREF>) {
chomp;
if (/^File (.*)/) {
$curfile = $1;
} elsif (/^ Subroutine (.*)/) {
$cursub = $1;
} elsif (/^ Package (.*)/) {
$curpack = $1;
} elsif ($curpack eq '?' && /^ (".*") +(.*)/
or /^ (\S+)\s+(.*)/) {
$xreftable{$curfile}{$cursub}{$curpack}{$1} = $2;
}
}
close XREF;
my $thisfile = __FILE__;
ok(
defined $xreftable{$thisfile}{'(main)'}{main}{'$compilesub'},
'$compilesub present in main program'
);
like(
$xreftable{$thisfile}{'(main)'}{main}{'$compilesub'},
qr/\bi100\b/,
'$compilesub introduced at line 100'
);
like(
$xreftable{$thisfile}{'(main)'}{main}{'$compilesub'},
qr/&102\b/,
'$compilesub coderef called at line 102'
);
ok(
defined $xreftable{$thisfile}{'(main)'}{'(lexical)'}{'$curfile'},
'$curfile present in main program'
);
like(
$xreftable{$thisfile}{'(main)'}{'(lexical)'}{'$curfile'},
qr/\bi200\b/,
'$curfile introduced at line 200'
);
ok(
defined $xreftable{$thisfile}{'(main)'}{main}{'%xreftable'},
'$xreftable present in main program'
);
ok(
defined $xreftable{$thisfile}{'Testing::Xref::foo'}{main}{'%xreftable'},
'$xreftable used in subroutine bar'
);
is(
$xreftable{$thisfile}{'(main)'}{main}{'&use_ok'}, '&50',
'use_ok called at line 50'
);
is(
$xreftable{$thisfile}{'(definitions)'}{'Testing::Xref'}{'&foo'}, 's1001',
'subroutine foo defined at line 1001'
);
is(
$xreftable{$thisfile}{'(definitions)'}{'Testing::Xref'}{'&bar'}, 's1002',
'subroutine bar defined at line 1002'
);
is(
$xreftable{$thisfile}{'Testing::Xref::bar'}{'Testing::Xref'}{'&foo'},
'&1002', 'subroutine foo called at line 1002 by bar'
);
is(
$xreftable{$thisfile}{'Testing::Xref::foo'}{'Testing::Xref'}{'*FOO'},
'1001', 'glob FOO used in subroutine foo'
);
END {
1 while unlink $file;
}
# End of tests.
# Now some stuff to feed B::Xref
# line 1000
package Testing::Xref;
sub foo { print FOO %::xreftable; }
sub bar { print FOO foo; }
--- NEW FILE: optree_check.t ---
#!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;
}
# require 'test.pl'; # now done by OptreeCheck
}
use OptreeCheck;
=head1 OptreeCheck selftest harness
This file is primarily to test services of OptreeCheck itself, ie
checkOptree(). %gOpts provides test-state info, it is 'exported' into
main::
doing use OptreeCheck runs import(), which processes @ARGV to process
cmdline args in 'standard' way across all clients of OptreeCheck.
=cut
my $tests = 5 + 15 + 16 * $gOpts{selftest}; # pass()s + $#tests
plan tests => $tests;
SKIP: {
skip "no perlio in this build", $tests
unless $Config::Config{useperlio};
pass("REGEX TEST HARNESS SELFTEST");
checkOptree ( name => "bare minimum opcode search",
bcopts => '-exec',
code => sub {my $a},
noanchors => 1, # unanchored match
expect => 'leavesub',
expect_nt => 'leavesub');
checkOptree ( name => "found print opcode",
bcopts => '-exec',
code => sub {print 1},
noanchors => 1, # unanchored match
expect => 'print',
expect_nt => 'leavesub');
checkOptree ( name => 'test skip itself',
skip => 'this is skip-reason',
bcopts => '-exec',
code => sub {print 1},
expect => 'dont-care, skipping',
expect_nt => 'this insures failure');
# This test 'unexpectedly succeeds', but that is "expected". Theres
# no good way to expect a successful todo, and inducing a failure
# causes the harness to print verbose errors, which is NOT helpful.
checkOptree ( name => 'test todo itself. suppressed, remove skip to test',
todo => "suppress todo test for now",
skip => 1,
bcopts => '-exec',
code => sub {print 1},
noanchors => 1, # unanchored match
expect => 'print',
expect_nt => 'print') if 0;
checkOptree ( name => 'impossible match, remove skip to see failure',
todo => "see! it breaks!",
skip => 'skip the failure',
code => sub {print 1},
expect => 'look out ! Boy Wonder',
expect_nt => 'holy near earth asteroid Batman !');
pass ("TEST FATAL ERRS");
if (1) {
# test for fatal errors. Im unsettled on fail vs die.
# calling fail isnt good enough by itself.
$@='';
eval {
checkOptree ( name => 'test against empty expectations',
bcopts => '-exec',
code => sub {print 1},
expect => '',
expect_nt => '');
};
like($@, /no '\w+' golden-sample found/, "empty expectations prevented");
$@='';
eval {
checkOptree ( name => 'prevent whitespace only expectations',
bcopts => '-exec',
code => sub {my $a},
#skip => 1,
expect_nt => "\n",
expect => "\n");
};
like($@, /no '\w+' golden-sample found/,
"just whitespace expectations prevented");
}
pass ("TEST -e \$srcCode");
checkOptree ( name => 'empty code or prog',
skip => 'or fails',
todo => "your excuse here ;-)",
code => '',
prog => '',
);
checkOptree
( name => "self strict, catch err",
prog => 'use strict; bogus',
errs => 'Bareword "bogus" not allowed while "strict subs" in use at -e line 1.',
expect => "nextstate", # simple expectations
expect_nt => "nextstate",
noanchors => 1, # allow them to work
);
checkOptree ( name => "sort lK - flag specific search",
prog => 'our (@a, at b); @b = sort @a',
noanchors => 1,
expect => '<@> sort lK ',
expect_nt => '<@> sort lK ');
checkOptree ( name => "sort vK - flag specific search",
prog => 'sort our @a',
errs => 'Useless use of sort in void context at -e line 1.',
noanchors => 1,
expect => '<@> sort vK',
expect_nt => '<@> sort vK');
checkOptree ( name => "'code' => 'sort our \@a'",
code => 'sort our @a',
noanchors => 1,
expect => '<@> sort K',
expect_nt => '<@> sort K');
pass ("REFTEXT FIXUP TESTS");
checkOptree ( name => 'fixup nextstate (in reftext)',
bcopts => '-exec',
code => sub {my $a},
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1 <;> nextstate( NOTE THAT THIS CAN BE ANYTHING ) v
# 2 <0> padsv[$a:54,55] M/LVINTRO
# 3 <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 54 optree_concise.t:84) v
# 2 <0> padsv[$a:54,55] M/LVINTRO
# 3 <1> leavesub[1 ref] K/REFC,1
EONT_EONT
checkOptree ( name => 'fixup opcode args',
bcopts => '-exec',
#fail => 1, # uncomment to see real padsv args: [$a:491,492]
code => sub {my $a},
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1 <;> nextstate(main 56 optree_concise.t:96) v
# 2 <0> padsv[$a:56,57] M/LVINTRO
# 3 <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 56 optree_concise.t:96) v
# 2 <0> padsv[$a:56,57] M/LVINTRO
# 3 <1> leavesub[1 ref] K/REFC,1
EONT_EONT
#################################
pass("CANONICAL B::Concise EXAMPLE");
checkOptree ( name => 'canonical example w -basic',
bcopts => '-basic',
code => sub{$a=$b+42},
crossfail => 1,
debug => 1,
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 7 <1> leavesub[1 ref] K/REFC,1 ->(end)
# - <@> lineseq KP ->7
# 1 <;> nextstate(main 380 optree_selftest.t:139) v ->2
# 6 <2> sassign sKS/2 ->7
# 4 <2> add[t3] sK/2 ->5
# - <1> ex-rv2sv sK/1 ->3
# 2 <#> gvsv[*b] s ->3
# 3 <$> const[IV 42] s ->4
# - <1> ex-rv2sv sKRM*/1 ->6
# 5 <#> gvsv[*a] s ->6
EOT_EOT
# 7 <1> leavesub[1 ref] K/REFC,1 ->(end)
# - <@> lineseq KP ->7
# 1 <;> nextstate(main 60 optree_concise.t:122) v ->2
# 6 <2> sassign sKS/2 ->7
# 4 <2> add[t1] sK/2 ->5
# - <1> ex-rv2sv sK/1 ->3
# 2 <$> gvsv(*b) s ->3
# 3 <$> const(IV 42) s ->4
# - <1> ex-rv2sv sKRM*/1 ->6
# 5 <$> gvsv(*a) s ->6
EONT_EONT
checkOptree ( code => '$a=$b+42',
bcopts => '-exec',
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1 <;> nextstate(main 61 optree_concise.t:139) v
# 2 <#> gvsv[*b] s
# 3 <$> const[IV 42] s
# 4 <2> add[t3] sK/2
# 5 <#> gvsv[*a] s
# 6 <2> sassign sKS/2
# 7 <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 61 optree_concise.t:139) v
# 2 <$> gvsv(*b) s
# 3 <$> const(IV 42) s
# 4 <2> add[t1] sK/2
# 5 <$> gvsv(*a) s
# 6 <2> sassign sKS/2
# 7 <1> leavesub[1 ref] K/REFC,1
EONT_EONT
} # skip
__END__
--- NEW FILE: terse.t ---
#!./perl
BEGIN {
if ($ENV{PERL_CORE}){
chdir('t') if -d 't';
@INC = ('.', '../lib');
} else {
unshift @INC, 't';
}
require Config;
if (($Config::Config{'extensions'} !~ /\bB\b/) ){
print "1..0 # Skip -- Perl configured without B module\n";
exit 0;
}
}
use Test::More tests => 16;
use_ok( 'B::Terse' );
# indent should return a string indented four spaces times the argument
is( B::Terse::indent(2), ' ' x 8, 'indent with an argument' );
is( B::Terse::indent(), '', 'indent with no argument' );
# this should fail without a reference
eval { B::Terse::terse('scalar') };
like( $@, qr/not a reference/, 'terse() fed bad parameters' );
# now point it at a sub and see what happens
sub foo {}
my $sub;
eval{ $sub = B::Terse::compile('', 'foo') };
is( $@, '', 'compile()' );
ok( defined &$sub, 'valid subref back from compile()' );
# and point it at a real sub and hope the returned ops look alright
my $out = tie *STDOUT, 'TieOut';
$sub = B::Terse::compile('', 'bar');
$sub->();
# now build some regexes that should match the dumped ops
my ($hex, $op) = ('\(0x[a-f0-9]+\)', '\s+\w+');
my %ops = map { $_ => qr/$_ $hex$op/ }
qw ( OP COP LOOP PMOP UNOP BINOP LOGOP LISTOP PVOP );
# split up the output lines into individual ops (terse is, well, terse!)
# use an array here so $_ is modifiable
my @lines = split(/\n+/, $out->read);
foreach (@lines) {
next unless /\S/;
s/^\s+//;
if (/^([A-Z]+)\s+/) {
my $op = $1;
next unless exists $ops{$op};
like( $_, $ops{$op}, "$op " );
s/$ops{$op}//;
delete $ops{$op};
redo if $_;
}
}
warn "# didn't find " . join(' ', keys %ops) if keys %ops;
# XXX:
# this tries to get at all tersified optypes in B::Terse
# if you can think of a way to produce AV, NULL, PADOP, or SPECIAL,
# add it to the regex above too. (PADOPs are currently only produced
# under ithreads, though).
#
use vars qw( $a $b );
sub bar {
# OP SVOP COP IV here or in sub definition
my @bar = (1, 2, 3);
# got a GV here
my $foo = $a + $b;
# NV here
$a = 1.234;
# this is awful, but it gives a PMOP
our @ary = split('', $foo);
# PVOP, LOOP
LOOP: for (1 .. 10) {
last LOOP if $_ % 2;
}
# make a PV
$foo = "a string";
# make an OP_SUBSTCONT
$foo =~ s/(a)/$1/;
}
# Schwern's example of finding an RV
my $path = join " ", map { qq["-I$_"] } @INC;
$path = '-I::lib -MMac::err=unix' if $^O eq 'MacOS';
my $redir = $^O eq 'MacOS' ? '' : "2>&1";
my $items = qx{$^X $path "-MO=Terse" -le "print \\42" $redir};
like( $items, qr/RV $hex \\42/, 'RV' );
package TieOut;
sub TIEHANDLE {
bless( \(my $out), $_[0] );
}
sub PRINT {
my $self = shift;
$$self .= join('', @_);
}
sub PRINTF {
my $self = shift;
$$self .= sprintf(@_);
}
sub read {
my $self = shift;
return substr($$self, 0, length($$self), '');
}
--- NEW FILE: showlex.t ---
#!./perl
BEGIN {
if ($ENV{PERL_CORE}){
chdir('t') if -d 't';
if ($^O eq 'MacOS') {
@INC = qw(: ::lib ::macos:lib);
} else {
@INC = '.';
push @INC, '../lib';
}
} 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;
}
require 'test.pl';
}
$| = 1;
use warnings;
use strict;
use Config;
use B::Showlex ();
plan tests => 15;
my $verbose = @ARGV; # set if ANY ARGS
my $a;
my $Is_VMS = $^O eq 'VMS';
my $Is_MacOS = $^O eq 'MacOS';
my $path = join " ", map { qq["-I$_"] } @INC;
$path = '"-I../lib" "-Iperl_root:[lib]"' if $Is_VMS; # gets too long otherwise
my $redir = $Is_MacOS ? "" : "2>&1";
my $is_thread = $Config{use5005threads} && $Config{use5005threads} eq 'define';
if ($is_thread) {
ok "# use5005threads: test skipped\n";
} else {
$a = `$^X $path "-MO=Showlex" -e "my \@one" $redir`;
like ($a, qr/sv_undef.*PVNV.*\@one.*sv_undef.*AV/s,
"canonical usage works");
}
# v1.01 tests
my ($na,$nb,$nc); # holds regex-strs
my ($out, $newlex); # output, option-flag
sub padrep {
my ($varname,$newlex) = @_;
return ($newlex)
? 'PVNV \(0x[0-9a-fA-F]+\) "\\'.$varname.'" = '
: "PVNV \\\(0x[0-9a-fA-F]+\\\) \\$varname\n";
}
for $newlex ('', '-newlex') {
$out = runperl ( switches => ["-MO=Showlex,$newlex"],
prog => 'my ($a,$b)', stderr => 1 );
$na = padrep('$a',$newlex);
$nb = padrep('$b',$newlex);
like ($out, qr/1: $na/ms, 'found $a in "my ($a,$b)"');
like ($out, qr/2: $nb/ms, 'found $b in "my ($a,$b)"');
print $out if $verbose;
SKIP: {
skip "no perlio in this build", 5
unless $Config::Config{useperlio};
our $buf = 'arb startval';
my $ak = B::Showlex::walk_output (\$buf);
my $walker = B::Showlex::compile( $newlex, sub{my($foo,$bar)} );
$walker->();
$na = padrep('$foo',$newlex);
$nb = padrep('$bar',$newlex);
like ($buf, qr/1: $na/ms, 'found $foo in "sub { my ($foo,$bar) }"');
like ($buf, qr/2: $nb/ms, 'found $bar in "sub { my ($foo,$bar) }"');
print $buf if $verbose;
$ak = B::Showlex::walk_output (\$buf);
my $src = 'sub { my ($scalar, at arr,%hash) }';
my $sub = eval $src;
$walker = B::Showlex::compile($sub);
$walker->();
$na = padrep('$scalar',$newlex);
$nb = padrep('@arr',$newlex);
$nc = padrep('%hash',$newlex);
like ($buf, qr/1: $na/ms, 'found $scalar in "'. $src .'"');
like ($buf, qr/2: $nb/ms, 'found @arr in "'. $src .'"');
like ($buf, qr/3: $nc/ms, 'found %hash in "'. $src .'"');
print $buf if $verbose;
# fibonacci function under test
my $asub = sub {
my ($self,%props)=@_;
my $total;
{ # inner block vars
my (@fib)=(1,2);
for (my $i=2; $i<10; $i++) {
$fib[$i] = $fib[$i-2] + $fib[$i-1];
}
for my $i(0..10) {
$total += $i;
}
}
};
$walker = B::Showlex::compile($asub, $newlex, -nosp);
$walker->();
print $buf if $verbose;
$walker = B::Concise::compile($asub, '-exec');
$walker->();
}
}
--- NEW FILE: f_sort.t ---
#!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
# 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
# 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
# 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
# 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
# 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
# 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
# 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
# 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
# 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
# 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
# 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
# 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
# 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
# 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
# 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
# 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
@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 sKRM/1
# i <1> srefgen sK/1
# j <@> leave lKP
# goto 9
# k <@> sort lKMS*
# l <@> mapstart lK*
# m <|> mapwhile(other->n)[t26] lK
# n <#> gv[*_] s
# o <1> rv2sv sKM/DREFAV,1
# p <1> rv2av[t4] sKR/1
# q <$> const[IV 0] s
# r <2> aelem sK/2
# - <@> scope lK
# goto m
# s <0> pushmark s
# t <#> gv[*new] s
# u <1> rv2av[t2] lKRM*/1
# v <2> aassign[t27] KS/COMMON
# w <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 sKRM/1
# i <1> srefgen sK/1
# j <@> leave lKP
# goto 9
# k <@> sort lKMS*
# l <@> mapstart lK*
# m <|> mapwhile(other->n)[t12] lK
# n <$> gv(*_) s
# o <1> rv2sv sKM/DREFAV,1
# p <1> rv2av[t2] sKR/1
# q <$> const(IV 0) s
# r <2> aelem sK/2
# - <@> scope lK
# goto m
# s <0> pushmark s
# t <$> gv(*new) s
# u <1> rv2av[t1] lKRM*/1
# v <2> aassign[t13] KS/COMMON
# w <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
# 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
# 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
# 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
# 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
checkOptree(note => q{},
bcopts => q{-exec},
code => q{use sort 'stable'; @new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old; },
expect => <<'EOT_EOT', expect_nt => <<'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*
# 7 <0> pushmark s
# 8 <#> gv[*new] s
# 9 <1> rv2av[t2] lKRM*/1
# a <2> aassign[t14] KS
# 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
# b <1> leavesub[1 ref] K/REFC,1
EONT_EONT
=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
# 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
# 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
# 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
# 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
--- NEW FILE: concise-xs.t ---
#!./perl
# 2 purpose file: 1-test 2-demonstrate (via args, -v -a options)
=head1 SYNOPSIS
To verify that B::Concise properly reports whether functions are XS or
perl, we test against 2 (currently) core packages which have lots of
XS functions: B and Digest::MD5. They're listed in %$testpkgs, along
with a list of functions that are (or are not) XS. For brevity, you
can specify the shorter list; if they're non-xs routines, start list
with a '!'. Data::Dumper is also tested, partly to prove the non-!
usage.
We demand-load each package, scan its stash for function names, and
mark them as XS/not-XS according to the list given for each package.
Then we test B::Concise's report on each.
=head1 OPTIONS AND ARGUMENTS
C<-v> and C<-V> trigger 2 levels of verbosity.
C<-a> uses Module::CoreList to run all core packages through the test, which
gives some interesting results.
C<-c> causes the expected XS/non-XS results to be marked with
corrections, which are then reported at program END, in a
Data::Dumper statement
C<< -r <file> >> reads a file, as written by C<-c>, and adjusts the expected
results accordingly. The file is 'required', so @INC settings apply.
If module-names are given as args, those packages are run through the
test harness; this is handy for collecting further items to test, and
may be useful otherwise (ie just to see).
=head1 EXAMPLES
All following examples avoid using PERL_CORE=1, since that changes @INC
=over 4
=item ./perl -Ilib -wS ext/B/t/concise-xs.t -c Storable
Tests Storable.pm for XS/non-XS routines, writes findings (along with
test results) to stdout. You could edit results to produce a test
file, as in next example
=item ./perl -Ilib -wS ext/B/t/concise-xs.t -r ./storable
Loads file, and uses it to set expectations, and run tests
=item ./perl -Ilib -wS ext/B/t/concise-xs.t -avc > ../foo-avc 2> ../foo-avc2
Gets module list from Module::Corelist, and runs them all through the
test. Since -c is used, this generates corrections, which are saved
in a file, which is edited down to produce ../all-xs
=item ./perl -Ilib -wS ext/B/t/concise-xs.t -cr ../all-xs > ../foo 2> ../foo2
This runs the tests specified in the file created in previous example.
-c is used again, and stdout verifies that all the expected results
given by -r ../all-xs are now seen.
Looking at ../foo2, you'll see 34 occurrences of the following error:
# err: Can't use an undefined value as a SCALAR reference at
# lib/B/Concise.pm line 634, <DATA> line 1.
=back
=cut
BEGIN {
if ($ENV{PERL_CORE}) {
chdir('t') if -d 't';
@INC = ('.', '../lib');
} 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;
}
unless ($Config::Config{useperlio}) {
print "1..0 # Skip -- Perl configured without perlio\n";
exit 0;
}
}
use Getopt::Std;
use Carp;
# One 5.009-only test to go when no 6; is integrated (25344)
use Test::More tests => ( 1 * !!$Config::Config{useithreads}
+ 1 * ($] > 5.009)
+ 778);
require_ok("B::Concise");
my $testpkgs = {
Digest::MD5 => [qw/ ! import /],
B => [qw/ ! class clearsym compile_stats debug objsym parents
peekop savesym timing_info walkoptree_exec
walkoptree_slow walksymtable /],
Data::Dumper => [qw/ bootstrap Dumpxs /],
B::Deparse => [qw/ ASSIGN CVf_ASSERTION CVf_LOCKED CVf_LVALUE
CVf_METHOD LIST_CONTEXT OP_CONST OP_LIST OP_RV2SV
OP_STRINGIFY OPf_KIDS OPf_MOD OPf_REF OPf_SPECIAL
OPf_STACKED OPf_WANT OPf_WANT_LIST OPf_WANT_SCALAR
OPf_WANT_VOID OPpCONST_ARYBASE OPpCONST_BARE
OPpENTERSUB_AMPER OPpEXISTS_SUB OPpITER_REVERSED
OPpLVAL_INTRO OPpOUR_INTRO OPpSLICE OPpSORT_DESCEND
OPpSORT_INPLACE OPpSORT_INTEGER OPpSORT_NUMERIC
OPpSORT_REVERSE OPpTARGET_MY OPpTRANS_COMPLEMENT
OPpTRANS_DELETE OPpTRANS_SQUASH PMf_CONTINUE
PMf_EVAL PMf_EXTENDED PMf_FOLD PMf_GLOBAL PMf_KEEP
PMf_MULTILINE PMf_ONCE PMf_SINGLELINE PMf_SKIPWHITE
POSTFIX SVf_FAKE SVf_IOK SVf_NOK SVf_POK SVf_ROK
SVpad_OUR SVs_RMG SVs_SMG SWAP_CHILDREN main_cv
main_root main_start opnumber perlstring
svref_2object /],
};
############
B::Concise::compile('-nobanner'); # set a silent default
getopts('vaVcr:', \my %opts) or
die <<EODIE;
usage: PERL_CORE=1 ./perl ext/B/t/concise-xs.t [-av] [module-list]
tests ability to discern XS funcs using Digest::MD5 package
-v : runs verbosely
-V : more verbosity
-a : runs all modules in CoreList
-c : writes test corrections as a Data::Dumper expression
-r <file> : reads file of tests, as written by -c
<args> : additional modules are loaded and tested
(will report failures, since no XS funcs are known aprior)
EODIE
;
if (%opts) {
require Data::Dumper;
Data::Dumper->import('Dumper');
$Data::Dumper::Sortkeys = 1;
}
my @argpkgs = @ARGV;
my %report;
if ($opts{r}) {
my $refpkgs = require "$opts{r}";
$testpkgs->{$_} = $refpkgs->{$_} foreach keys %$refpkgs;
}
unless ($opts{a}) {
unless (@argpkgs) {
foreach $pkg (sort keys %$testpkgs) {
test_pkg($pkg, $testpkgs->{$pkg});
}
} else {
foreach $pkg (@argpkgs) {
test_pkg($pkg, $testpkgs->{$pkg});
}
}
} else {
corecheck();
}
############
sub test_pkg {
my ($pkg_name, $xslist) = @_;
require_ok($pkg_name);
unless (ref $xslist eq 'ARRAY') {
warn "no XS/non-XS function list given, assuming empty XS list";
$xslist = [''];
}
my $assumeXS = 0; # assume list enumerates XS funcs, not perl ones
$assumeXS = 1 if $xslist->[0] and $xslist->[0] eq '!';
# build %stash: keys are func-names, vals: 1 if XS, 0 if not
my (%stash) = map
( ($_ => $assumeXS)
=> ( grep exists &{"$pkg_name\::$_"} # grab CODE symbols
=> grep !/__ANON__/ # but not anon subs
=> keys %{$pkg_name.'::'} # from symbol table
));
# now invert according to supplied list
$stash{$_} = int ! $assumeXS foreach @$xslist;
# and cleanup cruft (easier than preventing)
delete @stash{'!',''};
if ($opts{v}) {
diag("xslist: " => Dumper($xslist));
diag("$pkg_name stash: " => Dumper(\%stash));
}
my $err;
foreach $func_name (reverse sort keys %stash) {
my $res = checkXS("${pkg_name}::$func_name", $stash{$func_name});
if (!$res) {
$stash{$func_name} ^= 1;
print "$func_name ";
$err++;
}
}
$report{$pkg_name} = \%stash if $opts{c} and $err || $opts{v};
}
sub checkXS {
my ($func_name, $wantXS) = @_;
my ($buf, $err) = render($func_name);
if ($wantXS) {
like($buf, qr/\Q$func_name is XS code/,
"XS code:\t $func_name");
} else {
unlike($buf, qr/\Q$func_name is XS code/,
"perl code:\t $func_name");
}
#returns like or unlike, whichever was called
}
sub render {
my ($func_name) = @_;
B::Concise::reset_sequence();
B::Concise::walk_output(\my $buf);
my $walker = B::Concise::compile($func_name);
eval { $walker->() };
diag("err: $@ $buf") if $@;
diag("verbose: $buf") if $opts{V};
return ($buf, $@);
}
sub corecheck {
eval { require Module::CoreList };
if ($@) {
warn "Module::CoreList not available on $]\n";
return;
}
my $mods = $Module::CoreList::version{'5.009002'};
$mods = [ sort keys %$mods ];
print Dumper($mods);
foreach my $pkgnm (@$mods) {
test_pkg($pkgnm);
}
}
END {
if ($opts{c}) {
# print "Corrections: ", Dumper(\%report);
print "# Tested Package Subroutines, 1's are XS, 0's are perl\n";
print "\$VAR1 = {\n";
foreach my $pkg (sort keys %report) {
my (@xs, @perl);
my $stash = $report{$pkg};
@xs = sort grep $stash->{$_} == 1, keys %$stash;
@perl = sort grep $stash->{$_} == 0, keys %$stash;
my @list = (@xs > @perl) ? ( '!', @perl) : @xs;
print "\t$pkg => [qw/ @list /],\n";
}
print "};\n";
}
}
__END__
--- NEW FILE: concise.t ---
#!./perl
BEGIN {
if ($ENV{PERL_CORE}){
chdir('t') if -d 't';
@INC = ('.', '../lib');
} 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;
}
require 'test.pl'; # we use runperl from 'test.pl', so can't use Test::More
sub diag { print "# @_\n" } # but this is still handy
}
plan tests => 149;
require_ok("B::Concise");
$out = runperl(switches => ["-MO=Concise"], prog => '$a', stderr => 1);
# If either of the next two tests fail, it probably means you need to
# fix the section labeled 'fragile kludge' in Concise.pm
($op_base) = ($out =~ /^(\d+)\s*<0>\s*enter/m);
is($op_base, 1, "Smallest OP sequence number");
($op_base_p1, $cop_base)
= ($out =~ /^(\d+)\s*<;>\s*nextstate\(main (-?\d+) /m);
is($op_base_p1, 2, "Second-smallest OP sequence number");
is($cop_base, 1, "Smallest COP sequence number");
# test that with -exec B::Concise navigates past logops (bug #18175)
$out = runperl(
switches => ["-MO=Concise,-exec"],
prog => q{$a=$b && print q/foo/},
stderr => 1,
);
#diag($out);
like($out, qr/print/, "'-exec' option output has print opcode");
######## API tests v.60
use Config; # used for perlio check
B::Concise->import(qw( set_style set_style_standard add_callback
add_style walk_output reset_sequence ));
## walk_output argument checking
# test that walk_output rejects non-HANDLE args
foreach my $foo ("string", [], {}) {
eval { walk_output($foo) };
isnt ($@, '', "walk_output() rejects arg '$foo'");
$@=''; # clear the fail for next test
}
# test accessor mode when arg undefd or 0
foreach my $foo (undef, 0) {
my $handle = walk_output($foo);
is ($handle, \*STDOUT, "walk_output set to STDOUT (default)");
}
{ # any object that can print should be ok for walk_output
package Hugo;
sub new { my $foo = bless {} };
sub print { CORE::print @_ }
}
my $foo = new Hugo; # suggested this API fix
eval { walk_output($foo) };
is ($@, '', "walk_output() accepts obj that can print");
# test that walk_output accepts a HANDLE arg
SKIP: {
skip("no perlio in this build", 4)
unless $Config::Config{useperlio};
foreach my $foo (\*STDOUT, \*STDERR) {
eval { walk_output($foo) };
is ($@, '', "walk_output() accepts STD* " . ref $foo);
}
# now test a ref to scalar
eval { walk_output(\my $junk) };
is ($@, '', "walk_output() accepts ref-to-sprintf target");
$junk = "non-empty";
eval { walk_output(\$junk) };
is ($@, '', "walk_output() accepts ref-to-non-empty-scalar");
}
## add_style
my @stylespec;
$@='';
eval { add_style ('junk_B' => @stylespec) };
like ($@, 'expecting 3 style-format args',
"add_style rejects insufficient args");
@stylespec = (0,0,0); # right length, invalid values
$@='';
eval { add_style ('junk' => @stylespec) };
is ($@, '', "add_style accepts: stylename => 3-arg-array");
$@='';
eval { add_style (junk => @stylespec) };
like ($@, qr/style 'junk' already exists, choose a new name/,
"add_style correctly disallows re-adding same style-name" );
# test new arg-checks on set_style
$@='';
eval { set_style (@stylespec) };
is ($@, '', "set_style accepts 3 style-format args");
@stylespec = (); # bad style
eval { set_style (@stylespec) };
like ($@, qr/expecting 3 style-format args/,
"set_style rejects bad style-format args");
#### for content with doc'd options
our($a, $b);
my $func = sub{ $a = $b+42 }; # canonical example asub
sub render {
walk_output(\my $out);
eval { B::Concise::compile(@_)->() };
# diag "rendering $@\n";
return ($out, $@) if wantarray;
return $out;
}
SKIP: {
# tests output to GLOB, using perlio feature directly
skip "no perlio on this build", 127
unless $Config::Config{useperlio};
set_style_standard('concise'); # MUST CALL before output needed
@options = qw(
-basic -exec -tree -compact -loose -vt -ascii
-base10 -bigendian -littleendian
);
foreach $opt (@options) {
($out) = render($opt, $func);
isnt($out, '', "got output with option $opt");
}
## test output control via walk_output
my $treegen = B::Concise::compile('-basic', $func); # reused
{ # test output into a package global string (sprintf-ish)
our $thing;
walk_output(\$thing);
$treegen->();
ok($thing, "walk_output to our SCALAR, output seen");
}
# test walkoutput acceptance of a scalar-bound IO handle
open (my $fh, '>', \my $buf);
walk_output($fh);
$treegen->();
ok($buf, "walk_output to GLOB, output seen");
## test B::Concise::compile error checking
# call compile on non-CODE ref items
if (0) {
# pending STASH splaying
foreach my $ref ([], {}) {
my $typ = ref $ref;
walk_output(\my $out);
eval { B::Concise::compile('-basic', $ref)->() };
like ($@, qr/^err: not a coderef: $typ/,
"compile detects $typ-ref where expecting subref");
is($out,'', "no output when errd"); # announcement prints
}
}
# test against a bogus autovivified subref.
# in debugger, it should look like:
# 1 CODE(0x84840cc)
# -> &CODE(0x84840cc) in ???
my ($res,$err);
TODO: {
#local $TODO = "\tdoes this handling make sense ?";
sub declared_only;
($res,$err) = render('-basic', \&declared_only);
like ($res, qr/coderef CODE\(0x[0-9a-fA-F]+\) has no START/,
"'sub decl_only' seen as having no START");
sub defd_empty {};
($res,$err) = render('-basic', \&defd_empty);
is(scalar split(/\n/, $res), 3,
"'sub defd_empty {}' seen as 3 liner");
is(1, $res =~ /leavesub/ && $res =~ /nextstate/,
"'sub defd_empty {}' seen as 2 ops: leavesub,nextstate");
($res,$err) = render('-basic', \¬_even_declared);
like ($res, qr/coderef CODE\(0x[0-9a-fA-F]+\) has no START/,
"'\¬_even_declared' seen as having no START");
{
package Bar;
our $AUTOLOAD = 'garbage';
sub AUTOLOAD { print "# in AUTOLOAD body: $AUTOLOAD\n" }
}
($res,$err) = render('-basic', Bar::auto_func);
like ($res, qr/unknown function \(Bar::auto_func\)/,
"Bar::auto_func seen as unknown function");
($res,$err) = render('-basic', \&Bar::auto_func);
like ($res, qr/coderef CODE\(0x[0-9a-fA-F]+\) has no START/,
"'\&Bar::auto_func' seen as having no START");
($res,$err) = render('-basic', \&Bar::AUTOLOAD);
like ($res, qr/in AUTOLOAD body: /, "found body of Bar::AUTOLOAD");
}
($res,$err) = render('-basic', Foo::bar);
like ($res, qr/unknown function \(Foo::bar\)/,
"BC::compile detects fn-name as unknown function");
# v.62 tests
pass ("TEST POST-COMPILE OPTION-HANDLING IN WALKER SUBROUTINE");
my $sample;
my $walker = B::Concise::compile('-basic', $func);
walk_output(\$sample);
$walker->('-exec');
like($sample, qr/goto/m, "post-compile -exec");
walk_output(\$sample);
$walker->('-basic');
unlike($sample, qr/goto/m, "post-compile -basic");
# bang at it combinatorically
my %combos;
my @modes = qw( -basic -exec );
my @styles = qw( -concise -debug -linenoise -terse );
# prep samples
for $style (@styles) {
for $mode (@modes) {
walk_output(\$sample);
reset_sequence();
$walker->($style, $mode);
$combos{"$style$mode"} = $sample;
}
}
# crosscheck that samples are all text-different
@list = sort keys %combos;
for $i (0..$#list) {
for $j ($i+1..$#list) {
isnt ($combos{$list[$i]}, $combos{$list[$j]},
"combos for $list[$i] and $list[$j] are different, as expected");
}
}
# add samples with styles in different order
for $mode (@modes) {
for $style (@styles) {
reset_sequence();
walk_output(\$sample);
$walker->($mode, $style);
$combos{"$mode$style"} = $sample;
}
}
# test commutativity of flags, ie that AB == BA
for $mode (@modes) {
for $style (@styles) {
is ( $combos{"$style$mode"},
$combos{"$mode$style"},
"results for $style$mode vs $mode$style are the same" );
}
}
my %save = %combos;
%combos = (); # outputs for $mode=any($order) and any($style)
# add more samples with switching modes & sticky styles
for $style (@styles) {
walk_output(\$sample);
reset_sequence();
$walker->($style);
for $mode (@modes) {
walk_output(\$sample);
reset_sequence();
$walker->($mode);
$combos{"$style/$mode"} = $sample;
}
}
# crosscheck that samples are all text-different
@nm = sort keys %combos;
for $i (0..$#nm) {
for $j ($i+1..$#nm) {
isnt ($combos{$nm[$i]}, $combos{$nm[$j]},
"results for $nm[$i] and $nm[$j] are different, as expected");
}
}
# add samples with switching styles & sticky modes
for $mode (@modes) {
walk_output(\$sample);
reset_sequence();
$walker->($mode);
for $style (@styles) {
walk_output(\$sample);
reset_sequence();
$walker->($style);
$combos{"$mode/$style"} = $sample;
}
}
# test commutativity of flags, ie that AB == BA
for $mode (@modes) {
for $style (@styles) {
is ( $combos{"$style/$mode"},
$combos{"$mode/$style"},
"results for $style/$mode vs $mode/$style are the same" );
}
}
#now do double crosschecks: commutativity across stick / nostick
%combos = (%combos, %save);
# test commutativity of flags, ie that AB == BA
for $mode (@modes) {
for $style (@styles) {
is ( $combos{"$style$mode"},
$combos{"$style/$mode"},
"$style$mode VS $style/$mode are the same" );
is ( $combos{"$mode$style"},
$combos{"$mode/$style"},
"$mode$style VS $mode/$style are the same" );
is ( $combos{"$style$mode"},
$combos{"$mode/$style"},
"$style$mode VS $mode/$style are the same" );
is ( $combos{"$mode$style"},
$combos{"$style/$mode"},
"$mode$style VS $style/$mode are the same" );
}
}
}
# test proper NULLING of pointer, derefd by CvSTART, when a coderef is
# undefd. W/o this, the pointer can dangle into freed and reused
# optree mem, which no longer points to opcodes.
# Using B::Concise to render Config::AUTOLOAD's optree at BEGIN-time
# triggers this obscure bug, cuz AUTOLOAD has a bootstrap version,
# which is used at load-time then undeffed. It is normally
# re-vivified later, but not in time for this (BEGIN/CHECK)-time
# rendering.
$out = runperl ( switches => ["-MO=Concise,Config::AUTOLOAD"],
prog => 'use Config; BEGIN { $Config{awk} }',
stderr => 1 );
like($out, qr/Config::AUTOLOAD exists in stash, but has no START/,
"coderef properly undefined");
$out = runperl ( switches => ["-MO=Concise,Config::AUTOLOAD"],
prog => 'use Config; CHECK { $Config{awk} }',
stderr => 1 );
like($out, qr/Config::AUTOLOAD exists in stash, but has no START/,
"coderef properly undefined");
__END__
--- NEW FILE: debug.t ---
#!./perl
BEGIN {
if ($ENV{PERL_CORE}){
chdir('t') if -d 't';
if ($^O eq 'MacOS') {
@INC = qw(: ::lib ::macos:lib);
} else {
@INC = '.';
push @INC, '../lib';
}
} else {
unshift @INC, 't';
}
require Config;
if (($Config::Config{'extensions'} !~ /\bB\b/) ){
print "1..0 # Skip -- Perl configured without B module\n";
exit 0;
}
}
$| = 1;
use warnings;
use strict;
use Config;
print "1..3\n";
my $test = 1;
sub ok { print "ok $test\n"; $test++ }
my $a;
my $Is_VMS = $^O eq 'VMS';
my $Is_MacOS = $^O eq 'MacOS';
my $path = join " ", map { qq["-I$_"] } @INC;
my $redir = $Is_MacOS ? "" : "2>&1";
$a = `$^X $path "-MO=Debug" -e 1 $redir`;
print "not " unless $a =~
/\bLISTOP\b.*\bOP\b.*\bCOP\b.*\bOP\b/s;
ok;
$a = `$^X $path "-MO=Terse" -e 1 $redir`;
print "not " unless $a =~
/\bLISTOP\b.*leave.*\n OP\b.*enter.*\n COP\b.*nextstate.*\n OP\b.*null/s;
ok;
$a = `$^X $path "-MO=Terse" -ane "s/foo/bar/" $redir`;
$a =~ s/\(0x[^)]+\)//g;
$a =~ s/\[[^\]]+\]//g;
$a =~ s/-e syntax OK//;
$a =~ s/[^a-z ]+//g;
$a =~ s/\s+/ /g;
$a =~ s/\b(s|foo|bar|ullsv)\b\s?//g;
$a =~ s/^\s+//;
$a =~ s/\s+$//;
my $is_thread = $Config{use5005threads} && $Config{use5005threads} eq 'define';
if ($is_thread) {
$b=<<EOF;
leave enter nextstate label leaveloop enterloop null and defined null
threadsv readline gv lineseq nextstate aassign null pushmark split pushre
threadsv const null pushmark rvav gv nextstate subst const unstack
EOF
} else {
$b=<<EOF;
leave enter nextstate label leaveloop enterloop null and defined null
null gvsv readline gv lineseq nextstate aassign null pushmark split pushre
null gvsv const null pushmark rvav gv nextstate subst const unstack
EOF
}
$b=~s/\n/ /g;$b=~s/\s+/ /g;
$b =~ s/\s+$//;
print "# [$a]\n# vs\n# [$b]\nnot " if $a ne $b;
ok;
--- NEW FILE: optree_sort.t ---
#!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;
}
# require 'test.pl'; # now done by OptreeCheck
}
use OptreeCheck;
use Config;
plan tests => 11;
SKIP: {
skip "no perlio in this build", 11 unless $Config::Config{useperlio};
pass("SORT OPTIMIZATION");
checkOptree ( name => 'sub {sort @a}',
code => sub {sort @a},
bcopts => '-exec',
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1 <;> nextstate(main 424 optree_sort.t:14) v
# 2 <0> pushmark s
# 3 <#> gv[*a] s
# 4 <1> rv2av[t2] lK/1
# 5 <@> sort K
# 6 <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 424 optree_sort.t:14) v
# 2 <0> pushmark s
# 3 <$> gv(*a) s
# 4 <1> rv2av[t1] lK/1
# 5 <@> sort K
# 6 <1> leavesub[1 ref] K/REFC,1
EONT_EONT
checkOptree ( name => 'sort @a',
prog => 'sort @a',
errs => [ 'Useless use of sort in void context at -e line 1.',
'Name "main::a" used only once: possible typo at -e line 1.',
],
bcopts => '-exec',
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
1 <0> enter
2 <;> nextstate(main 1 -e:1) v
3 <0> pushmark s
4 <#> gv[*a] s
5 <1> rv2av[t2] lK/1
6 <@> sort vK
7 <@> leave[1 ref] vKP/REFC
EOT_EOT
# 1 <0> enter
# 2 <;> nextstate(main 1 -e:1) v
# 3 <0> pushmark s
# 4 <$> gv(*a) s
# 5 <1> rv2av[t1] lK/1
# 6 <@> sort vK
# 7 <@> leave[1 ref] vKP/REFC
EONT_EONT
checkOptree ( name => 'sub {@a = sort @a}',
code => sub {@a = sort @a},
bcopts => '-exec',
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
1 <;> nextstate(main -438 optree.t:244) v
2 <0> pushmark s
3 <0> pushmark s
4 <#> gv[*a] s
5 <1> rv2av[t4] lK/1
6 <@> sort lK
7 <0> pushmark s
8 <#> gv[*a] 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 65 optree.t:311) v
# 2 <0> pushmark s
# 3 <0> pushmark s
# 4 <$> gv(*a) s
# 5 <1> rv2av[t2] lK/1
# 6 <@> sort lK
# 7 <0> pushmark s
# 8 <$> gv(*a) s
# 9 <1> rv2av[t1] lKRM*/1
# a <2> aassign[t3] KS/COMMON
# b <1> leavesub[1 ref] K/REFC,1
EONT_EONT
checkOptree ( name => '@a = sort @a',
prog => '@a = sort @a',
bcopts => '-exec',
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
1 <0> enter
2 <;> nextstate(main 1 -e:1) v
3 <0> pushmark s
4 <0> pushmark s
5 <#> gv[*a] s
6 <1> rv2av[t4] lKRM*/1
7 <@> sort lK/INPLACE
8 <@> leave[1 ref] vKP/REFC
EOT_EOT
# 1 <0> enter
# 2 <;> nextstate(main 1 -e:1) v
# 3 <0> pushmark s
# 4 <0> pushmark s
# 5 <$> gv(*a) s
# 6 <1> rv2av[t2] lKRM*/1
# 7 <@> sort lK/INPLACE
# 8 <@> leave[1 ref] vKP/REFC
EONT_EONT
checkOptree ( name => 'sub {@a = sort @a; reverse @a}',
code => sub {@a = sort @a; reverse @a},
bcopts => '-exec',
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
1 <;> nextstate(main -438 optree.t:286) v
2 <0> pushmark s
3 <0> pushmark s
4 <#> gv[*a] s
5 <1> rv2av[t4] lKRM*/1
6 <@> sort lK/INPLACE
7 <;> nextstate(main -438 optree.t:288) v
8 <0> pushmark s
9 <#> gv[*a] s
a <1> rv2av[t7] lK/1
b <@> reverse[t8] K/1
c <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 66 optree.t:345) v
# 2 <0> pushmark s
# 3 <0> pushmark s
# 4 <$> gv(*a) s
# 5 <1> rv2av[t2] lKRM*/1
# 6 <@> sort lK/INPLACE
# 7 <;> nextstate(main 66 optree.t:346) v
# 8 <0> pushmark s
# 9 <$> gv(*a) s
# a <1> rv2av[t4] lK/1
# b <@> reverse[t5] K/1
# c <1> leavesub[1 ref] K/REFC,1
EONT_EONT
checkOptree ( name => '@a = sort @a; reverse @a',
prog => '@a = sort @a; reverse @a',
errs => ['Useless use of reverse in void context at -e line 1.'],
bcopts => '-exec',
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
1 <0> enter
2 <;> nextstate(main 1 -e:1) v
3 <0> pushmark s
4 <0> pushmark s
5 <#> gv[*a] s
6 <1> rv2av[t4] lKRM*/1
7 <@> sort lK/INPLACE
8 <;> nextstate(main 1 -e:1) v
9 <0> pushmark s
a <#> gv[*a] s
b <1> rv2av[t7] lK/1
c <@> reverse[t8] vK/1
d <@> leave[1 ref] vKP/REFC
EOT_EOT
# 1 <0> enter
# 2 <;> nextstate(main 1 -e:1) v
# 3 <0> pushmark s
# 4 <0> pushmark s
# 5 <$> gv(*a) s
# 6 <1> rv2av[t2] lKRM*/1
# 7 <@> sort lK/INPLACE
# 8 <;> nextstate(main 1 -e:1) v
# 9 <0> pushmark s
# a <$> gv(*a) s
# b <1> rv2av[t4] lK/1
# c <@> reverse[t5] vK/1
# d <@> leave[1 ref] vKP/REFC
EONT_EONT
checkOptree ( name => 'sub {my @a; @a = sort @a}',
code => sub {my @a; @a = sort @a},
bcopts => '-exec',
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
1 <;> nextstate(main -437 optree.t:254) v
2 <0> padav[@a:-437,-436] vM/LVINTRO
3 <;> nextstate(main -436 optree.t:256) v
4 <0> pushmark s
5 <0> pushmark s
6 <0> padav[@a:-437,-436] l
7 <@> sort lK
8 <0> pushmark s
9 <0> padav[@a:-437,-436] lRM*
a <2> aassign[t2] KS/COMMON
b <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 427 optree_sort.t:172) v
# 2 <0> padav[@a:427,428] vM/LVINTRO
# 3 <;> nextstate(main 428 optree_sort.t:173) v
# 4 <0> pushmark s
# 5 <0> pushmark s
# 6 <0> padav[@a:427,428] l
# 7 <@> sort lK
# 8 <0> pushmark s
# 9 <0> padav[@a:427,428] lRM*
# a <2> aassign[t2] KS/COMMON
# b <1> leavesub[1 ref] K/REFC,1
EONT_EONT
checkOptree ( name => 'my @a; @a = sort @a',
prog => 'my @a; @a = sort @a',
bcopts => '-exec',
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
1 <0> enter
2 <;> nextstate(main 1 -e:1) v
3 <0> padav[@a:1,2] vM/LVINTRO
4 <;> nextstate(main 2 -e:1) v
5 <0> pushmark s
6 <0> pushmark s
7 <0> padav[@a:1,2] lRM*
8 <@> sort lK/INPLACE
9 <@> leave[1 ref] vKP/REFC
EOT_EOT
# 1 <0> enter
# 2 <;> nextstate(main 1 -e:1) v
# 3 <0> padav[@a:1,2] vM/LVINTRO
# 4 <;> nextstate(main 2 -e:1) v
# 5 <0> pushmark s
# 6 <0> pushmark s
# 7 <0> padav[@a:1,2] lRM*
# 8 <@> sort lK/INPLACE
# 9 <@> leave[1 ref] vKP/REFC
EONT_EONT
checkOptree ( name => 'sub {my @a; @a = sort @a; push @a, 1}',
code => sub {my @a; @a = sort @a; push @a, 1},
bcopts => '-exec',
debug => 0,
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
1 <;> nextstate(main -437 optree.t:325) v
2 <0> padav[@a:-437,-436] vM/LVINTRO
3 <;> nextstate(main -436 optree.t:325) v
4 <0> pushmark s
5 <0> pushmark s
6 <0> padav[@a:-437,-436] lRM*
7 <@> sort lK/INPLACE
8 <;> nextstate(main -436 optree.t:325) v
9 <0> pushmark s
a <0> padav[@a:-437,-436] lRM
b <$> const[IV 1] s
c <@> push[t3] sK/2
d <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 429 optree_sort.t:219) v
# 2 <0> padav[@a:429,430] vM/LVINTRO
# 3 <;> nextstate(main 430 optree_sort.t:220) v
# 4 <0> pushmark s
# 5 <0> pushmark s
# 6 <0> padav[@a:429,430] lRM*
# 7 <@> sort lK/INPLACE
# 8 <;> nextstate(main 430 optree_sort.t:220) v
# 9 <0> pushmark s
# a <0> padav[@a:429,430] lRM
# b <$> const(IV 1) s
# c <@> push[t3] sK/2
# d <1> leavesub[1 ref] K/REFC,1
EONT_EONT
checkOptree ( name => 'sub {my @a; @a = sort @a; 1}',
code => sub {my @a; @a = sort @a; 1},
bcopts => '-exec',
debug => 0,
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
1 <;> nextstate(main -437 optree.t:325) v
2 <0> padav[@a:-437,-436] vM/LVINTRO
3 <;> nextstate(main -436 optree.t:325) v
4 <0> pushmark s
5 <0> pushmark s
6 <0> padav[@a:-437,-436] lRM*
7 <@> sort lK/INPLACE
8 <;> nextstate(main -436 optree.t:346) v
9 <$> const[IV 1] s
a <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 431 optree_sort.t:250) v
# 2 <0> padav[@a:431,432] vM/LVINTRO
# 3 <;> nextstate(main 432 optree_sort.t:251) v
# 4 <0> pushmark s
# 5 <0> pushmark s
# 6 <0> padav[@a:431,432] lRM*
# 7 <@> sort lK/INPLACE
# 8 <;> nextstate(main 432 optree_sort.t:251) v
# 9 <$> const(IV 1) s
# a <1> leavesub[1 ref] K/REFC,1
EONT_EONT
} #skip
__END__
--- NEW FILE: bblock.t ---
#!./perl -Tw
BEGIN {
if ($ENV{PERL_CORE}){
chdir('t') if -d 't';
@INC = ('.', '../lib');
} else {
unshift @INC, 't';
}
require Config;
if (($Config::Config{'extensions'} !~ /\bB\b/) ){
print "1..0 # Skip -- Perl configured without B module\n";
exit 0;
}
}
use Test::More tests => 1;
use_ok('B::Bblock', qw(find_leaders));
# Someone who understands what this module does, please fill this out.
More information about the dslinux-commit
mailing list