ext/B/t/stash.t See if B::Stash works
ext/B/t/terse.t See if B::Terse works
ext/B/t/xref.t See if B::Xref works
+ext/B/t/OptreeCheck.pm optree comparison tool
+ext/B/t/optree_check.t test OptreeCheck apparatus
+ext/B/t/optree_samples.t various basic codes: if for while
+ext/B/t/optree_concise.t more B::Concise tests
+ext/B/t/optree_sort.t inplace sort optimization regression
+ext/B/t/optree_varinit.t my,our,local var init optimization
ext/B/typemap Compiler backend interface types
ext/ByteLoader/bytecode.h Bytecode header for bytecode loader
ext/ByteLoader/ByteLoader.pm Bytecode loader Perl module
use Exporter (); # use #5
-our $VERSION = "0.60";
+our $VERSION = "0.61";
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(set_style set_style_standard add_callback
concise_subref concise_cv concise_main
$ENV{B_CONCISE_TREE_FORMAT}],
);
-my($format, $gotofmt, $treefmt);
+# Renderings, ie how Concise prints, is controlled by these vars
+# primary:
+our $stylename; # selects current style from %style
+my $order = "basic"; # how optree is walked & printed: basic, exec, tree
+
+# rendering mechanics:
+# these 'formats' are the line-rendering templates
+# they're updated from %style when $stylename changes
+my ($format, $gotofmt, $treefmt);
+
+# lesser players:
+my $base = 36; # how <sequence#> is displayed
+my $big_endian = 1; # more <sequence#> display
+my $tree_style = 0; # tree-order details
+my $banner = 1; # print banner before optree is traversed
+
+# another factor:
+our @callbacks; # allow external management
+
+set_style_standard("concise");
+
my $curcv;
my $cop_seq_base;
-my @callbacks;
-my $stylename;
sub set_style {
($format, $gotofmt, $treefmt) = @_;
+ #warn "set_style: deprecated, use set_style_standard instead\n"; # someday
die "expecting 3 style-format args\n" unless @_ == 3;
}
if exists $style{$newstyle};
die "expecting 3 style-format args\n" unless @args == 3;
$style{$newstyle} = [@args];
+ $stylename = $newstyle; # update rendering state
}
sub set_style_standard {
- ($stylename) = @_;
+ ($stylename) = @_; # update rendering state
die "err: style '$stylename' unknown\n" unless exists $style{$stylename};
set_style(@{$style{$stylename}});
}
[" ", map("$start_sym$_$end_sym", "qq", "wq", "tq", "x ", "mq", "q"), 1],
[" ", map("$start_sym$_$end_sym", "q", "w", "t", "x", "m"), "", 0],
);
-my $tree_style = 0;
-
-my $base = 36;
-my $big_endian = 1;
-
-my $order = "basic";
-
-set_style_standard("concise");
sub compile {
my @options = grep(/^-/, @_);
$big_endian = 1;
} elsif ($o eq "-littleendian") {
$big_endian = 0;
- } elsif (exists $style{substr($o, 1)}) {
+ } elsif ($o eq "-banner") {
+ $banner = 0;
+ }
+ elsif (exists $style{substr($o, 1)}) {
$stylename = substr($o, 1);
- set_style(@{$style{$stylename}});
+ set_style_standard($stylename);
} else {
warn "Option $o unrecognized";
}
# convert function names to subrefs
my $objref;
if (ref $objname) {
- print $walkHandle "B::Concise::compile($objname)\n";
+ print $walkHandle "B::Concise::compile($objname)\n"
+ if $banner;
$objref = $objname;
} else {
$objname = "main::" . $objname unless $objname =~ /::/;
}
my %labels;
-my $lastnext;
+my $lastnext; # remembers op-chain, used to insert gotos
my %opclass = ('OP' => "0", 'UNOP' => "1", 'BINOP' => "2", 'LOGOP' => "|",
'LISTOP' => "@", 'PMOP' => "/", 'SVOP' => "\$", 'GVOP' => "*",
}
}
-sub fmt_line {
+sub fmt_line { # generate text-line for op.
my($hr, $text, $level) = @_;
- return '' if $hr->{SKIP}; # another way to suppress lines of output
+ return '' if $hr->{SKIP}; # suppress line if a callback said so
$text =~ s/\(\?\(([^\#]*?)\#(\w+)([^\#]*?)\)\?\)/
$hr->{$2} ? $1.$hr->{$2}.$3 : ""/eg;
$text =~ s/\(x\((.*?);(.*?)\)x\)/$order eq "exec" ? $1 : $2/egs;
$text =~ s/\(\*\(([^;]*?)\)\*\)/$1 x $level/egs;
$text =~ s/\(\*\((.*?);(.*?)\)\*\)/$1 x ($level - 1) . $2 x ($level>0)/egs;
- $text =~ s/#([a-zA-Z]+)(\d+)/sprintf("%-$2s", $hr->{$1})/eg;
- $text =~ s/#([a-zA-Z]+)/$hr->{$1}/eg;
+ $text =~ s/\#([a-zA-Z]+)(\d+)/sprintf("%-$2s", $hr->{$1})/eg;
+
+ $text =~ s/\#([a-zA-Z]+)/$hr->{$1}/eg; # populate data into template
$text =~ s/[ \t]*~+[ \t]*/ /g;
chomp $text;
return "$text\n" if $text ne "";
sub B::OP::concise {
my($op, $level) = @_;
if ($order eq "exec" and $lastnext and $$lastnext != $$op) {
+ # insert a 'goto' line
my $h = {"seq" => seq($lastnext), "class" => class($lastnext),
"addr" => sprintf("%#x", $$lastnext)};
print $walkHandle fmt_line($h, $gotofmt, $level+1);
$curcv = main_cv unless $curcv;
if ($order eq "exec" and $lastnext and $$lastnext != $$op) {
+ # insert a 'goto'
my $h = {"seq" => seq($lastnext), "class" => class($lastnext),
"addr" => sprintf("%#x", $$lastnext)};
print fmt_line($h, $style{"terse"}[1], $level+1);
=head1 EXAMPLE
-Here's is a short example of output, using the default formatting
-conventions :
+Here's is a short example of output (aka 'rendering'), using the
+default formatting conventions :
% perl -MO=Concise -e '$a = $b + 42'
8 <@> leave[1 ref] vKP/REFC ->(end)
- <1> ex-rv2sv sKRM*/1 ->7
6 <$> gvsv(*a) s ->7
-Each line corresponds to an operator. Null ops appear as C<ex-opname>,
+Each line corresponds to an opcode. Null ops appear as C<ex-opname>,
where I<opname> is the op that has been optimized away by perl.
The number on the first row indicates the op's sequence number. It's
C<CHECK>, C<INIT>, or C<END> will cause all of the corresponding
special blocks to be printed.
+Options affect how things are rendered (ie printed). They're presented
+here by their visual effect, 1st being strongest. They're grouped
+according to how they interrelate; within each group the options are
+mutually exclusive (unless otherwise stated).
+
+=head2 Options for Opcode Ordering
+
+These options control the 'vertical display' of opcodes. The display
+'order' is also called 'mode' elsewhere in this document.
+
=over 4
=item B<-basic>
it isn't suitable for large programs (unless you have a very wide
terminal).
+=back
+
+=head2 Options for Line-Style
+
+These options select the line-style (or just style) used to render
+each opcode, and dictates what info is actually printed into each line.
+
+=over 4
+
+=item B<-concise>
+
+Use the author's favorite set of formatting conventions. This is the
+default, of course.
+
+=item B<-terse>
+
+Use formatting conventions that emulate the output of B<B::Terse>. The
+basic mode is almost indistinguishable from the real B<B::Terse>, and the
+exec mode looks very similar, but is in a more logical order and lacks
+curly brackets. B<B::Terse> doesn't have a tree mode, so the tree mode
+is only vaguely reminiscent of B<B::Terse>.
+
+=item B<-linenoise>
+
+Use formatting conventions in which the name of each OP, rather than being
+written out in full, is represented by a one- or two-character abbreviation.
+This is mainly a joke.
+
+=item B<-debug>
+
+Use formatting conventions reminiscent of B<B::Debug>; these aren't
+very concise at all.
+
+=item B<-env>
+
+Use formatting conventions read from the environment variables
+C<B_CONCISE_FORMAT>, C<B_CONCISE_GOTO_FORMAT>, and C<B_CONCISE_TREE_FORMAT>.
+
+=back
+
+=head2 Options for tree-specific formatting
+
+=over 4
+
=item B<-compact>
Use a tree format in which the minimum amount of space is used for the
terminal (or the horizontal scrolling mode of less(1)) and are suitable
for text documentation or email. This is the default.
-=item B<-main>
+=back
-Include the main program in the output, even if subroutines were also
-specified.
+These are pairwise exclusive, i.e. compact or loose, vt or ascii.
+
+=head2 Options controlling sequence numbering
+
+=over 4
=item B<-base>I<n>
=item B<-littleendian>
-Print seqence numbers with the least significant digit first.
-
-=item B<-concise>
+Print seqence numbers with the least significant digit first. This is
+obviously mutually exclusive with bigendian.
-Use the author's favorite set of formatting conventions. This is the
-default, of course.
+=back
-=item B<-terse>
+=head2 Other options
-Use formatting conventions that emulate the output of B<B::Terse>. The
-basic mode is almost indistinguishable from the real B<B::Terse>, and the
-exec mode looks very similar, but is in a more logical order and lacks
-curly brackets. B<B::Terse> doesn't have a tree mode, so the tree mode
-is only vaguely reminiscient of B<B::Terse>.
+=over 4
-=item B<-linenoise>
+=item B<-main>
-Use formatting conventions in which the name of each OP, rather than being
-written out in full, is represented by a one- or two-character abbreviation.
-This is mainly a joke.
+Include the main program in the output, even if subroutines were also
+specified. This is the only option that is not sticky (see below)
-=item B<-debug>
+=item B<-banner>
-Use formatting conventions reminiscient of B<B::Debug>; these aren't
-very concise at all.
+B::Concise::compile normally prints a banner line identifying the
+function name, or in case of a subref, a generic message including
+(unfortunately) the stringified coderef. This option suppresses the
+printing of the banner.
-=item B<-env>
+=back
-Use formatting conventions read from the environment variables
-C<B_CONCISE_FORMAT>, C<B_CONCISE_GOTO_FORMAT>, and C<B_CONCISE_TREE_FORMAT>.
+=head2 Option Stickiness
-=back
+If you invoke Concise more than once in a program, you should know that
+the options are 'sticky'. This means that the options you provide in
+the first call will be remembered for the 2nd call, unless you
+re-specify or change them.
=head1 FORMATTING SPECIFICATIONS
-For each general style ('concise', 'terse', 'linenoise', etc.) there are
-three specifications: one of how OPs should appear in the basic or exec
-modes, one of how 'goto' lines should appear (these occur in the exec
-mode only), and one of how nodes should appear in tree mode. Each has the
-same format, described below. Any text that doesn't match a special
-pattern is copied verbatim.
+For each line-style ('concise', 'terse', 'linenoise', etc.) there are
+3 format-specs which control how OPs are rendered.
+
+The first is the 'default' format, which is used in both basic and exec
+modes to print all opcodes. The 2nd, goto-format, is used in exec
+mode when branches are encountered. They're not real opcodes, and are
+inserted to look like a closing curly brace. The tree-format is tree
+specific.
+
+When a line is rendered, the correct format string is scanned for the
+following items, and data is substituted in, or other manipulations,
+like basic indenting. Any text that doesn't match a special pattern
+(the items below) is copied verbatim. (Yes, it's a set of s///g steps.)
=over 4
=head1 Using B::Concise outside of the O framework
-You can use B<B::Concise>, and call compile() directly, thereby
-avoiding the compile-only operation of O. For example, you could use
-the debugger to step through B::Concise::compile() itself.
+You can use B<B::Concise>, and call compile() directly, and
+repeatedly. By doing so, you can avoid the compile-time only
+operation of 'perl -MO=Concise ..'. For example, you can use the
+debugger to step through B::Concise::compile() itself.
When doing so, you can alter Concise output by providing new output
styles, and optionally by adding callback routines which populate new
variables that may be rendered as part of those styles. For all
following sections, please review L</FORMATTING SPECIFICATIONS>.
-=head2 example: Altering Concise Output
+=head2 Example: Altering Concise Renderings
use B::Concise qw(set_style add_callback);
set_style($your_format, $your_gotofmt, $your_treefmt);
=head2 set_style()
-B<set_style> accepts 3 arguments, and updates the three components of an
-output style (basic-exec, goto, tree). It has one minor drawback though:
-it doesn't register the style under a new name, thus you may prefer to use
-add_style() and/or set_style_standard() instead.
+B<set_style> accepts 3 arguments, and updates the three format-specs
+comprising a line-style (basic-exec, goto, tree). It has one minor
+drawback though; it doesn't register the style under a new name. This
+can become an issue if you render more than once and switch styles.
+Thus you may prefer to use add_style() and/or set_style_standard()
+instead.
+
+=head2 set_style_standard($name)
+
+This restores one of the standard line-styles: C<terse>, C<concise>,
+C<linenoise>, C<debug>, C<env>, into effect. It also accepts style
+names previously defined with add_style().
=head2 add_style()
an error to re-add a style; call set_style_standard() to switch between
several styles.
-=head2 set_style_standard($name)
-
-This restores one of the standard styles: C<terse>, C<concise>,
-C<linenoise>, C<debug>, C<env>, into effect. It also accepts style
-names previously defined with add_style().
-
=head2 add_callback()
If your newly minted styles refer to any #variables, you'll need to
references to scalars, but it is unlikely that they will need to be
changed or even used.
-=head2 running B::Concise::compile()
+=head2 Running B::Concise::compile()
B<compile> accepts options as described above in L</OPTIONS>, and
arguments, which are either coderefs, or subroutine names.
another open filehandle, or into a string passed as a ref.
walk_output(\my $buf);
- B::Concise::compile('-concise','funcName', \&aSubRef)->();
- print "Concise Results: $buf\n";
+ my $walker = B::Concise::compile('-concise','funcName', \&aSubRef);
+ print "Concise Banner for Functions: $buf\n";
+ $walker->();
+ print "Concise Rendering(s)?: $buf\n";
-For each subroutine visited, the opcode info is preceded by a single
-line containing either the subroutine name or the stringified coderef.
+For each subroutine visited by Concise, the $buf will contain a
+banner naming the function or coderef about to be traversed.
+Once $walker is invoked, it prints the actual renderings for each.
To switch back to one of the standard styles like C<concise> or
C<terse>, call C<set_style_standard>, or pass the style name into
resolved with a die($message). Use an eval if you wish to catch these
errors and continue processing.
-In particular, B<compile> will die as follows if you've asked for a
-non-existent function-name, a non-existent coderef, or a non-CODE
-reference.
+In particular, B<compile> will die if you've asked for a non-existent
+function-name, a non-existent coderef, or a non-CODE reference.
=head1 AUTHOR
--- /dev/null
+# OptreeCheck.pm
+# package-less .pm file allows 'use OptreeCheck';
+# otherwise, it's like "require './test.pl'"
+
+=head1 NAME
+
+OptreeCheck - check optrees
+
+=head1 SYNOPSIS
+
+OptreeCheck supports regression testing of perl's parser, optimizer,
+bytecode generator, via a single function: checkOptree(%args).
+
+ checkOptree(name => "your title here",
+ bcopts => '-exec', # $opt or \@opts, passed to BC::compile
+ code => sub {my $a}, # must be CODE ref
+ # prog => 'sort @a', # run in subprocess, aka -MO=Concise
+ # skip => 1, # skips test
+ # todo => 'excuse', # anticipated failures
+ # fail => 1 # fails (by redirecting result)
+ # debug => 1, # turns on regex debug for match test !!
+ # retry => 1 # retry with debug on test failure
+ 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
+
+=head1 checkOptree(%in) Overview
+
+Runs code or prog through B::Concise, and captures its rendering.
+
+Calls mkCheckRex() to produce a regex which will match the expected
+rendering, and fail when it doesn't match.
+
+Also calls like($out,/$regex/,$name), and thereby plugs into the test.pl
+framework.
+
+=head1 checkOptree(%Args) API
+
+Accepts %Args, with following requirements and actions:
+
+expect and expect_nt required, not empty, not whitespace. Its a fatal
+error, because false positives are BAD.
+
+Either code or prog must be present.
+
+prog is some source code, and is passed through via runperl, to B::Concise
+like this: (bcopts are fixed up for cmdline)
+
+ './perl -w -MO=Concise,$bcopts_massaged -e $src'
+
+code is a subref, or $src, like above. If it's not a subref, it's
+treated like source, and wrapped as a subroutine, and passed to
+B::Concise::compile():
+
+ $subref = eval "sub{$src}";
+
+I suppose I should also explain these more, but..
+
+ # prog => 'sort @a', # run in subprocess, aka -MO=Concise
+ # skip => 1, # skips test
+ # todo => 'excuse', # anticipated failures
+ # fail => 1 # fails (by redirecting result)
+ # debug => 1, # turns on regex debug for match test !!
+ # retry => 1 # retry with debug on test failure
+
+=head1 Usage Philosophy
+
+2 platforms --> 2 reftexts: You want an accurate test, independent of
+which platform youre on. This is obvious in retrospect, but ..
+
+I started this with 1 reftext, and tried to use it to construct regexs
+for both platforms. This is extra complexity, trying to build a
+single regex for both cases makes the regex more complicated, and
+harder to get 'right'.
+
+Having 2 references also allows various 'tests', really explorations
+currently. At the very least, having 2 samples side by side allows
+inspection and aids understanding of optrees.
+
+Cross-testing (expect_nt on threaded, expect on non-threaded) exposes
+differences in B::Concise output, so mkCheckRex has code to do some
+cross-test manipulations. This area needs more work.
+
+=head1 Test Modes
+
+One consequence of a single-function API is difficulty controlling
+test-mode. Ive chosen for now to use a package hash, %gOpts, to store
+test-state. These properties alter checkOptree() function, either
+short-circuiting to selftest, or running a loop that runs the testcase
+2^N times, varying conditions each time. (current N is 2 only).
+
+So Test-mode is controlled with cmdline args, also called options below.
+Run with 'help' to see the test-state, and how to change it.
+
+=head2 selftest
+
+This argument invokes runSelftest(), which tests a regex against the
+reference renderings that they're made from. Failure of a regex match
+its 'mold' is a strong indicator that mkCheckRex is buggy.
+
+That said, selftest mode currently runs a cross-test too, they're not
+completely orthogonal yet. See below.
+
+=head2 testmode=cross
+
+Cross-testing is purposely creating a T-NT mismatch, looking at the
+fallout, and tweaking the regex to deal with it. Thus tests lead to
+'provably' complete understanding of the differences.
+
+The tweaking appears contrary to the 2-refs philosophy, but the tweaks
+will be made in conversion-specific code, which (will) handles T->NT
+and NT->T separately. The tweaking is incomplete.
+
+A reasonable 1st step is to add tags to indicate when TonNT or NTonT
+is known to fail. This needs an option to force failure, so the
+test.pl reporting mechanics show results to aid the user.
+
+=head2 testmode=native
+
+This is normal mode. Other valid values are: native, cross, both.
+
+=head2 checkOptree Notes
+
+Accepts test code, renders its optree using B::Concise, and matches that
+rendering against a regex built from one of 2 reference-renderings %in data.
+
+The regex is built by mkCheckRex(\%in), which scrubs %in data to
+remove match-irrelevancies, such as (args) and [args]. For example,
+it strips leading '# ', making it easy to cut-paste new tests into
+your test-file, run it, and cut-paste actual results into place. You
+then retest and reedit until all 'errors' are gone. (now make sure you
+haven't 'enshrined' a bug).
+
+name: The test name. May be augmented by a label, which is built from
+important params, and which helps keep names in sync with whats being
+tested.
+
+=cut
+
+use Config;
+use Carp;
+use B::Concise qw(walk_output);
+use Data::Dumper;
+$Data::Dumper::Sortkeys = 1;
+
+BEGIN {
+ $SIG{__WARN__} = sub {
+ my $err = shift;
+ $err =~ m/Subroutine re::(un)?install redefined/ and return;
+ };
+}
+
+# but wait - more skullduggery !
+sub OptreeCheck::import { &getCmdLine; } # process @ARGV
+
+# %gOpts params comprise a global test-state. Initial values here are
+# HELP strings, they MUST BE REPLACED by runtime values before use, as
+# is done by getCmdLine(), via import
+
+our %gOpts = # values are replaced at runtime !!
+ (
+ # scalar values are help string
+ rextract => 'writes src-code todo same Optree matching',
+ vbasic => 'prints $str and $rex',
+ retry => 'retry failures after turning on re debug',
+ retrydbg => 'retry failures after turning on re debug',
+ selftest => 'self-tests mkCheckRex vs the reference rendering',
+ selfdbg => 'redo failing selftests with re debug',
+ xtest => 'extended thread/non-thread testing',
+ fail => 'force all test to fail, print to stdout',
+ dump => 'dump cmdline arg prcessing',
+ rexpedant => 'try tighter regex, still buggy',
+ help => 0, # 1 ends in die
+
+ # array values are one-of selections, with 1st value as default
+ # tbc: 1st value is help, 2nd is default
+ testmode => [qw/ native cross both /],
+ );
+
+
+our $threaded = 1 if $Config::Config{usethreads};
+our $platform = ($threaded) ? "threaded" : "plain";
+our $thrstat = ($threaded) ? "threaded" : "nonthreaded";
+
+our ($MatchRetry,$MatchRetryDebug); # let mylike be generic
+# test.pl-ish hack
+*MatchRetry = \$gOpts{retry}; # but alias it into %gOpts
+*MatchRetryDebug = \$gOpts{retrydbg}; # but alias it into %gOpts
+
+our %modes = (
+ both => [ 'expect', 'expect_nt'],
+ native => [ ($threaded) ? 'expect' : 'expect_nt'],
+ cross => [ !($threaded) ? 'expect' : 'expect_nt'],
+ expect => [ 'expect' ],
+ expect_nt => [ 'expect_nt' ],
+ );
+
+our %msgs # announce cross-testing.
+ = (
+ # cross-platform
+ 'expect_nt-threaded' => " (Non-threaded-ref on Threaded-build)",
+ 'expect-nonthreaded' => " (Threaded-ref on Non-threaded-build)",
+ # native - nothing to say
+ 'expect_nt-nonthreaded' => '',
+ 'expect-threaded' => '',
+ );
+
+#######
+sub getCmdLine { # import assistant
+ # offer help
+ print(qq{\n$0 accepts args to update these state-vars:
+ turn on a flag by typing its name,
+ select a value from list by typing name=val.\n },
+ Dumper \%gOpts)
+ if grep /help/, @ARGV;
+
+ # replace values for each key !! MUST MARK UP %gOpts
+ foreach my $opt (keys %gOpts) {
+
+ # scan ARGV for known params
+ if (ref $gOpts{$opt} eq 'ARRAY') {
+
+ # $opt is a One-Of construct
+ # replace with valid selection from the list
+
+ # uhh this WORKS. but it's inscrutable
+ # grep s/$opt=(\w+)/grep {$_ eq $1} @ARGV and $gOpts{$opt}=$1/e, @ARGV;
+ my $tval; # temp
+ if (grep s/$opt=(\w+)/$tval=$1/e, @ARGV) {
+ # check val before accepting
+ my @allowed = @{$gOpts{$opt}};
+ if (grep { $_ eq $tval } @allowed) {
+ $gOpts{$opt} = $tval;
+ }
+ else {die "invalid value: '$tval' for $opt\n"}
+ }
+
+ # take 1st val as default
+ $gOpts{$opt} = ${$gOpts{$opt}}[0]
+ if ref $gOpts{$opt} eq 'ARRAY';
+ }
+ else { # handle scalars
+
+ # if 'opt' is present, true
+ $gOpts{$opt} = (grep /$opt/, @ARGV) ? 1 : 0;
+
+ # override with 'foo' if 'opt=foo' appears
+ grep s/$opt=(.*)/$gOpts{$opt}=$1/e, @ARGV;
+ }
+ }
+ print("$0 heres current state:\n", Dumper \%gOpts)
+ if $gOpts{help} or $gOpts{dump};
+
+ exit if $gOpts{help};
+}
+
+##################################
+# API
+
+sub checkOptree {
+ my %in = @_;
+ my ($in, $res) = (\%in,0); # set up privates.
+
+ print "checkOptree args: ",Dumper \%in if $in{dump};
+ SKIP: {
+ skip($in{name}, 1) if $in{skip};
+ return runSelftest(\%in) if $gOpts{selftest};
+
+ my $rendering = getRendering(\%in); # get the actual output
+ fail("FORCED: $in{name}:\n$rendering") if $gOpts{fail}; # silly ?
+
+ # Test rendering against ..
+ foreach $want (@{$modes{$gOpts{testmode}}}) {
+
+ my $rex = mkCheckRex(\%in,$want);
+ my $cross = $msgs{"$want-$thrstat"};
+
+ # bad is anticipated failure on cross testing ONLY
+ my $bad = (0 or ( $cross && $in{crossfail})
+ or (!$cross && $in{fail})
+ or 0);
+
+ # couldn't bear to pass \%in to likeyn
+ $res = mylike ( # custom test mode stuff
+ [ !$bad,
+ $in{retry} || $gOpts{retry},
+ $in{debug} || $gOpts{retrydbg}
+ ],
+ # remaining is std API
+ $rendering, qr/$rex/ms, "$cross $in{name}")
+ || 0;
+ printhelp(\%in, $rendering, $rex);
+ }
+ }
+ $res;
+}
+
+#################
+# helpers
+
+sub label {
+ # may help get/keep test output consistent
+ my ($in) = @_;
+ $in->{label} = join(',', map {"$_=>$in->{$_}"}
+ qw( bcopts name prog code ));
+}
+
+sub testCombo {
+ # generate a set of test-cases from the options
+ my $in = @_;
+ my @cases;
+ foreach $want (@{$modes{$gOpts{testmode}}}) {
+
+ push @cases, [ %in,
+ ];
+ }
+ return @cases;
+}
+
+sub runSelftest {
+ # tests the test-cases offered (expect, expect_nt)
+ # needs Unification with above.
+ my ($in) = @_;
+ my $ok;
+ foreach $want (@{$modes{$gOpts{testmode}}}) {}
+
+ for my $provenance (qw/ expect expect_nt /) {
+ next unless $in->{$provenance};
+ my ($rex,$gospel) = mkCheckRex($in, $provenance);
+ return unless $gospel;
+
+ my $cross = $msgs{"$provenance-$thrstat"};
+ my $bad = (0 or ( $cross && $in->{crossfail})
+ or (!$cross && $in->{fail})
+ or 0);
+ # couldn't bear to pass \%in to likeyn
+ $res = mylike ( [ !$bad,
+ $in->{retry} || $gOpts{retry},
+ $in->{debug} || $gOpts{retrydbg}
+ ],
+ $rendering, qr/$rex/ms, "$cross $in{name}")
+ || 0;
+ }
+ $ok;
+}
+
+# use re;
+sub mylike {
+ # note dependence on unlike()
+ my ($control) = shift;
+ my ($yes,$retry,$debug) = @$control; # or dies
+ my ($got, $expected, $name, @mess) = @_; # pass thru mostly
+
+ die "unintended usage, expecting Regex". Dumper \@_
+ unless ref $_[1] eq 'Regexp';
+
+ # same as A ^ B, but B has side effects
+ my $ok = ( (!$yes and unlike($got, $expected, $name, @mess))
+ or ($yes and like($got, $expected, $name, @mess)));
+
+ if (not $ok and $retry) {
+ # redo, perhaps with use re debug
+ eval "use re 'debug'" if $debug;
+ $ok = (!$yes and unlike($got, $expected, "(RETRY) $name", @mess)
+ or $yes and like($got, $expected, "(RETRY) $name", @mess));
+
+ no re 'debug';
+ }
+ return $ok;
+}
+
+sub getRendering {
+ my ($in) = @_;
+ die "getRendering: code or prog is required\n"
+ unless $in->{code} or $in->{prog};
+
+ my @opts = get_bcopts($in);
+ my $rendering = ''; # suppress "Use of uninitialized value in open"
+
+ if ($in->{prog}) {
+ $rendering = runperl( switches => ['-w',join(',',"-MO=Concise",@opts)],
+ prog => $in->{prog}, stderr => 1,
+ ); #verbose => 1);
+ } else {
+ my $code = $in->{code};
+ unless (ref $code eq 'CODE') {
+ # treat as source, and wrap
+ $code = eval "sub { $code }";
+ die "$@ evaling code 'sub { $in->{code} }'\n"
+ unless ref $code eq 'CODE';
+ }
+ # set walk-output b4 compiling, which writes 'announce' line
+ walk_output(\$rendering);
+ if ($in->{fail}) {
+ fail("forced failure: stdout follows");
+ walk_output(\*STDOUT);
+ }
+ my $opwalker = B::Concise::compile(@opts, $code);
+ die "bad BC::compile retval" unless ref $opwalker eq 'CODE';
+
+ B::Concise::reset_sequence();
+ $opwalker->();
+ }
+ return $rendering;
+}
+
+sub get_bcopts {
+ # collect concise passthru-options if any
+ my ($in) = shift;
+ my @opts = ();
+ if ($in->{bcopts}) {
+ @opts = (ref $in->{bcopts} eq 'ARRAY')
+ ? @{$in->{bcopts}} : ($in->{bcopts});
+ }
+ return @opts;
+}
+
+# needless complexity due to 'too much info' from B::Concise v.60
+my $announce = 'B::Concise::compile\(CODE\(0x[0-9a-f]+\)\)';;
+
+sub mkCheckRex {
+ # converts expected text into Regexp which should match against
+ # unaltered version. also adjusts threaded => non-threaded
+ my ($in, $want) = @_;
+ eval "no re 'debug'";
+
+ my $str = $in->{expect} || $in->{expect_nt}; # standard bias
+ $str = $in->{$want} if $want; # stated pref
+
+ die "no reftext found for $want: $in->{name}" unless $str;
+ #fail("rex-str is empty, won't allow false positives") unless $str;
+
+ $str =~ s/^\# //mg; # ease cut-paste testcase authoring
+ my $reftxt = $str; # extra return val !!
+
+ unless ($gOpts{rexpedant}) {
+ # convert all (args) and [args] to temporary '____'
+ $str =~ s/(\(.*?\))/____/msg;
+ $str =~ s/(\[.*?\])/____/msg;
+
+ # escape remaining metachars. manual \Q (doesnt escape '+')
+ $str =~ s/([\[\]()*.\$\@\#])/\\$1/msg;
+ #$str =~ s/([*.\$\@\#])/\\$1/msg;
+
+ # now replace '____' with something that matches both.
+ # bracing style agnosticism is important here, it makes many
+ # threaded / non-threaded diffs irrelevant
+ $str =~ s/____/(\\[.*?\\]|\\(.*?\\))/msg; # capture in case..
+
+ # no mysterious failures in debugger
+ $str =~ s/(?:next|db)state/(?:next|db)state/msg;
+ }
+ else {
+ # precise/pedantic way - only wildcard nextate, leavesub
+
+ # escape some literals
+ $str =~ s/([*.\$\@\#])/\\$1/msg;
+
+ # nextstate. replace args, and work under debugger
+ $str =~ s/(?:next|db)state\(.*?\)/(?:next|db)state\\(.*?\\)/msg;
+
+ # leavesub refcount changes, dont care
+ $str =~ s/leavesub\[.*?\]/leavesub[.*?]/msg;
+
+ # wildcard-ify all [contents]
+ $str =~ s/\[.*?\]/[.*?]/msg; # add capture ?
+
+ # make [] literal now, keeping .* for contents
+ $str =~ s/([\[\]])/\\$1/msg;
+ }
+ # threaded <--> non-threaded transforms ??
+
+ if (not $Config::Config{usethreads}) {
+ # written for T->NT transform
+ # $str =~ s/<\\#>/<\\\$>/msg; # GV on pad, a threads thing ?
+ $str =~ s/PADOP/SVOP/msg; # fix terse output diffs
+ }
+ croak "no reftext found for $want: $in->{name}"
+ unless $str =~ /\w+/; # fail unless a real test
+
+ # $str = '.*' if 1; # sanity test
+ # $str .= 'FAIL' if 1; # sanity test
+
+ # tabs fixup
+ $str =~ s/\t/ +/msg; # not \s+
+
+ eval "use re 'debug'" if $debug;
+ my $qr = qr/$str/;
+ no re 'debug';
+
+ return ($qr, $reftxt) if wantarray;
+ return $qr;
+}
+
+sub printhelp {
+ my ($in, $rendering, $rex) = @_;
+ print "<$rendering>\nVS\n<$reftext>\n" if $gOpts{vbasic};
+
+ # save this output to afile, edit out 'ok's and 1..N
+ # then perl -d afile, and add re 'debug' to suit.
+ print("\$str = q{$rendering};\n".
+ "\$rex = qr{$reftext};\n".
+ "print \"\$str =~ m{\$rex}ms \";\n".
+ "\$str =~ m{\$rex}ms or print \"doh\\n\";\n\n")
+ if $in{rextract} or $gOpts{rextract};
+}
+
+1;
+
+__END__
+
+=head1 mkCheckRex
+
+mkCheckRex receives the full testcase object, and constructs a regex.
+1st, it selects a reftxt from either the expect or expect_nt items.
+
+Once selected, reftext massaged & convert into a Regex that accepts
+'good' concise renderings, with appropriate input variations, but is
+otherwize as strict as possible. For example, it should *not* match
+when opcode flags change, or when optimizations convert an op to an
+ex-op.
+
+=head2 match criteria
+
+Opcode arguments (text within braces) are disregarded for matching
+purposes. This loses some info in 'add[t5]', but greatly simplifys
+matching 'nextstate(main 22 (eval 10):1)'. Besides, we are testing
+for regressions, not for complete accuracy.
+
+The regex is unanchored, allowing success on simple expectations, such
+as one with a single 'print' opcode.
+
+=head2 complicating factors
+
+Note that %in may seem overly complicated, but it's needed to allow
+mkCheckRex to better support selftest,
+
+The emerging complexity is that mkCheckRex must choose which refdata
+to use as a template for the regex being constructed. This feels like
+selection mechanics being duplicated.
+
+=head1 FEATURES, BUGS, ENHANCEMENTS
+
+Hey, they're the same thing now, modulo heisen-phase-shifting, and the
+probe used to observe them.
+
+=head1 Test Data
+
+Test cases were recently doubled, by adding a 2nd ref-data property;
+expect and expect_nt carry renderings taken from threaded and
+non-threaded builds. This addition has several benefits:
+
+ 1. native reference data allows closer matching by regex.
+ 2. samples can be eyeballed to grok t-nt differences.
+ 3. data can help to validate mkCheckRex() operation.
+ 4. can develop code to smooth t-nt differences.
+ 5. can test with both native and cross+converted rexes
+
+Enhancements:
+
+Tests should specify both 'expect' and 'expect_nt', making the
+distinction now will allow a range of behaviors, in escalating
+thoroughness. This variable is called provenance, indicating where
+the reftext came from.
+
+build_only: tests which dont have the reference-sample of the
+right provenance will be skipped. NO GOOD.
+
+prefer_expect: This is implied standard, as all tests done thus far
+started here. One way t->nt conversions is done, based upon Config.
+
+activetest: do cross-testing when test-case has both, ie also test
+'expect_nt' references on threaded builds. This is aggressive, and is
+intended to seek out t<->nt differences. if mkCheckRex knows
+provenance and Config, it can do 2 way t<->nt conversions.
+
+activemapping: This builds upon activetest by controlling whether
+t<->nt conversions are done, and allows simpler verification that each
+conversion step is indeed necessary.
+
+pedantic: this fails if tests dont have both, whereas above doesn't care.
+
+=cut
require './test.pl';
}
-plan tests => 5;
+plan tests => 38;
require_ok("B::Concise");
stderr => 1,
);
-like($out, qr/print/, "-exec option with //=");
+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));
+
+## walk_output argument checking
+
+# test that walk_output accepts a HANDLE arg
+foreach my $foo (\*STDOUT, \*STDERR) {
+ eval { walk_output($foo) };
+ is ($@, '', "walk_output() accepts STD* " . ref $foo);
+}
+
+# test that walk_output rejects non-HANDLE args
+foreach my $foo (undef, 0, "string",[], {}) {
+ eval { walk_output($foo) };
+ isnt ($@, '', "walk_output() rejects arg '$foo'");
+ $@=''; # clear the fail for next test
+}
+
+{ # 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");
+
+# 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
+
+set_style_standard('concise'); # MUST CALL b4 output needed
+my $func = sub{ $a = $b+42 };
+
+@options = qw(
+ -basic -exec -tree -compact -loose -vt -ascii -main
+ -base10 -bigendian -littleendian
+ );
+foreach $opt (@options) {
+ walk_output(\my $out);
+ my $treegen = B::Concise::compile($opt, $func);
+ $treegen->();
+ #print "foo:$out\n";
+ 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 output to GLOB, using perlio feature directly
+ skip 1, "no perlio on this build" unless $Config{useperlio};
+ 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
+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 ???
+sub nosuchfunc;
+eval { B::Concise::compile('-basic', \&nosuchfunc)->() };
+like ($@, qr/^err: coderef has no START/,
+ "compile detects CODE-ref w/o actual code");
+
+foreach my $opt (qw( -concise -exec )) {
+ eval { B::Concise::compile($opt,'non_existent_function')->() };
+ like ($@, qr/unknown function \(main::non_existent_function\)/,
+ "'$opt' reports non-existent-function properly");
+}
--- /dev/null
+#!perl
+
+BEGIN {
+ chdir 't';
+ @INC = ('../lib', '../ext/B/t');
+ require './test.pl';
+}
+
+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
+
+##################
+ ;
+
+plan tests => 5 + 19 + 14 * $gOpts{selftest}; # fudged
+
+pass("REGEX TEST HARNESS SELFTEST");
+
+checkOptree ( name => "bare minimum opcode search",
+ bcopts => '-exec',
+ code => sub {my $a},
+ expect => 'leavesub',
+ expect_nt => 'leavesub');
+
+checkOptree ( name => "found print opcode",
+ bcopts => '-exec',
+ code => sub {print 1},
+ expect => 'print',
+ expect_nt => 'leavesub');
+
+checkOptree ( name => 'test skip itself',
+ skip => 1,
+ bcopts => '-exec',
+ code => sub {print 1},
+ expect => 'dont-care, skipping',
+ expect_nt => 'this insures failure');
+
+checkOptree ( name => 'test todo itself',
+ todo => "your excuse here ;-)",
+ bcopts => '-exec',
+ code => sub {print 1},
+ expect => 'print',
+ expect_nt => 'print');
+
+checkOptree ( name => 'impossible match, remove skip to see failure',
+ todo => "see! it breaks!",
+ skip => 1, # but skip it 1st
+ 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 => 'empty code or prog',
+ todo => "your excuse here ;-)",
+ code => '',
+ prog => '',
+ );
+ };
+ like($@, 'code or prog is required', 'empty code or prog prevented');
+
+ $@='';
+ eval {
+ checkOptree ( name => 'test against empty expectations',
+ bcopts => '-exec',
+ code => sub {print 1},
+ expect => '',
+ expect_nt => '');
+ };
+ like($@, 'no reftext found for', "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 reftext found for', "just whitespace expectations prevented");
+}
+
+pass ("TEST -e \$srcCode");
+
+checkOptree ( name => '-w errors seen',
+ prog => 'sort our @a',
+ expect => 'Useless use of sort in void context',
+ expect_nt => 'Useless use of sort in void context');
+
+checkOptree ( name => "self strict, catch err",
+ prog => 'use strict; bogus',
+ expect => 'strict subs',
+ expect_nt => 'strict subs');
+
+checkOptree ( name => "sort vK - flag specific search",
+ prog => 'sort our @a',
+ expect => '<@> sort vK ',
+ expect_nt => '<@> sort vK ');
+
+checkOptree ( name => "'prog' => 'sort our \@a'",
+ prog => 'sort our @a',
+ expect => '<@> sort vK',
+ expect_nt => '<@> sort vK');
+
+checkOptree ( name => "'code' => 'sort our \@a'",
+ code => 'sort our @a',
+ 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');
+# goto -
+# 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
+# goto -
+# 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 square-bracket args',
+ bcopts => '-exec',
+ todo => 'not done in rexpedant mode',
+ code => sub {my $a},
+ #skip => 1,
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# goto -
+# 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
+# goto -
+# 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
+
+checkOptree ( name => 'unneeded manual rex-ify by test author',
+ # args in 1,2 are manually edited, unnecessarily
+ bcopts => '-exec',
+ code => sub {my $a},
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# 1 <;> nextstate(.*?) v
+# 2 <0> padsv[.*?] M/LVINTRO
+# 3 <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# 1 <;> nextstate(main 57 optree_concise.t:108) v
+# 2 <0> padsv[$a:57,58] 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 ( name => 'canonical example w -exec',
+ bcopts => '-exec',
+ code => sub{$a=$b+42},
+ crossfail => 1,
+ retry => 1,
+ debug => 1,
+ xtestfail => 1,
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# goto -
+# 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
+# goto -
+# 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
+
+checkOptree ( name => 'tree reftext is messy cut-paste',
+ skip => 1);
+
+
+__END__
+
--- /dev/null
+#!perl
+
+BEGIN {
+ chdir 't';
+ @INC = ('../lib', '../ext/B/t');
+ require './test.pl';
+}
+
+# import checkOptree(), and %gOpts (containing test state)
+use OptreeCheck; # ALSO DOES @ARGV HANDLING !!!!!!
+
+plan tests => 24; # need to set based on testing state
+
+$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[\d+ refs?] K/REFC,1 ->(end)
+# - <@> lineseq KP ->7
+# 1 <;> nextstate(foo bar) v ->2
+# 6 <2> sassign sKS/2 ->7
+# 4 <2> add[t\d+] 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');
+# goto -
+# 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
+# goto -
+# 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
+
+checkOptree ( name => 'tree reftext is messy cut-paste',
+ skip => 1);
+
+
+#################################
+pass("B::Concise OPTION TESTS");
+
+checkOptree ( name => '-base3 sticky-exec',
+ bcopts => '-base3',
+ code => sub{$a=$b+42},
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+ goto -
+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[2 refs] K/REFC,1
+EOT_EOT
+# goto -
+# 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');
+ goto UNOP (0x82b0918)
+COP (0x82b0d70) nextstate
+PADOP (0x82b0d30) gvsv GV (0x82a818c) *a
+UNOP (0x82b0e08) leavesub [1]
+EOT_EOT
+# goto UNOP (0x8282310)
+# 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',
+ #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',
+ 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',
+ prog => 'use strict; sort @a',
+ bcopts => [qw/ -basic -concise -exec /],
+ expect => 'compilation errors',
+ expect_nt => 'compilation errors');
+
+checkOptree ( name => 'error at -e line 1',
+ prog => 'our @a; sort @a',
+ bcopts => [qw/ -basic -concise -exec /],
+ expect => 'at -e line 1',
+ expect_nt => 'at -e line 1');
+
+checkOptree ( name => 'cmdline -basic -concise -exec works',
+ prog => 'our @a; sort @a',
+ bcopts => [qw/ -basic -concise -exec /],
+ 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"
+ , "(?(<#speq>)?)#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} = '';
+
+ # 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');
+ goto -
+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');
+ goto -
+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');
+ goto -
+1 <;> nextstate(main 50 optree_concise.t:337) v
+7 <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+ goto -
+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
+
+
+__END__
+
--- /dev/null
+#!perl
+
+BEGIN {
+ chdir 't';
+ @INC = ('../lib', '../ext/B/t');
+ require './test.pl';
+}
+use OptreeCheck;
+
+plan tests => 13;
+
+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');
+# B::Concise::compile(CODE(0x81a77b4))
+# 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
+# 1 <;> nextstate(main 45 optree.t:23) v
+# 2 <0> padsv[$a:45,46] M/LVINTRO
+# 3 <1> leavesub[1 ref] K/REFC,1
+# 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');
+# B::Concise::compile(CODE(0x81a77b4))
+# 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 "foo $_"}',
+ prog => 'foreach (1..10) {print "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');
+# B::Concise::compile(CODE(0x8332b20))
+# goto -
+# 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
+
+checkOptree ( name => '-e use constant j => "junk"; print j',
+ prog => 'use constant j => "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
+
+__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
+
--- /dev/null
+#!perl
+
+BEGIN {
+ chdir 't';
+ @INC = ('../lib', '../ext/B/t');
+ require './test.pl';
+}
+use OptreeCheck;
+
+plan tests => 11;
+
+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[t1] 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',
+ 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');
+ goto -
+1 <;> nextstate(main -438 optree.t:244) 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[t2] lKRM*/1
+a <2> aassign[t\d+] 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');
+ goto -
+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',
+ 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');
+ goto -
+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[t\d+] 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');
+ goto -
+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');
+ goto -
+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
+
+
+__END__
+
--- /dev/null
+#!perl
+
+BEGIN {
+ chdir 't';
+ @INC = ('../lib', '../ext/B/t');
+ require './test.pl';
+}
+use OptreeCheck;
+
+plan tests => 22;
+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');
+# goto -
+# 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
+# goto -
+# 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');
+ goto -
+1 <;> nextstate(main 21 optree.t:47) v
+2 <#> gvsv[*a] s/OURINTR
+3 <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# goto -
+# 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');
+ goto -
+1 <;> nextstate(main 23 optree.t:57) v
+2 <#> gvsv[*a] s/LVINTRO
+3 <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# goto -
+# 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',
+ 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');
+3 <1> leavesub[1 ref] K/REFC,1 ->(end)
+- <@> lineseq KP ->3
+1 <;> nextstate(main 24 optree.t:99) v ->2
+2 <0> padsv[$a:24,25] sRM*/LVINTRO ->3
+EOT_EOT
+# 3 <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->3
+# 1 <;> nextstate(main 54 optree.t:149) v ->2
+# 2 <0> padsv[$a:54,55] sRM*/LVINTRO ->3
+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');
+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] vRM*/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] vRM*/LVINTRO ->4
+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',
+ 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=()},
+ todo => 'optimize',
+ bcopts => '-exec',
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+ goto -
+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');
+ goto -
+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
+# goto -
+# 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=()',
+ todo => 'optimize ? its one of the idioms',
+ 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=()',
+ #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
+
+__END__
+
}
# Note: this isn't quite as fancy as Test::More::like().
-sub like ($$@) {
- my ($got, $expected, $name, @mess) = @_;
+
+sub like ($$@) { like_yn (0,@_) }; # 0 for -
+sub unlike ($$@) { like_yn (1,@_) }; # 1 for un-
+
+sub like_yn ($$$@) {
+ my ($flip, $got, $expected, $name, @mess) = @_;
my $pass;
- if (ref $expected eq 'Regexp') {
- $pass = $got =~ $expected;
- unless ($pass) {
- unshift(@mess, "# got '$got'\n",
- "# expected /$expected/\n");
- }
- } else {
- $pass = $got =~ /$expected/;
- unless ($pass) {
- unshift(@mess, "# got '$got'\n",
- "# expected /$expected/\n");
- }
+ $pass = $got =~ /$expected/ if !$flip;
+ $pass = $got !~ /$expected/ if $flip;
+ unless ($pass) {
+ unshift(@mess, "# got '$got'\n",
+ "# expected /$expected/\n");
}
_ok($pass, _where(), $name, @mess);
}
projects / p5sagit/p5-mst-13.2.git / commitdiff