ext/B/t/optree_concise.t more B::Concise tests
ext/B/t/optree_samples.t various basic codes: if for while
ext/B/t/optree_sort.t inplace sort optimization regression
+ext/B/t/optree_specials.t BEGIN, END, etc code
ext/B/t/optree_varinit.t my,our,local var init optimization
+ext/B/t/f_map code from perldoc -f map
+ext/B/t/f_map.t converted to optreeCheck()s
+ext/B/t/f_sort optree test raw material
+ext/B/t/f_sort.t optree test raw material
ext/B/t/o.t See if O works
ext/B/t/showlex.t See if B::ShowLex works
ext/B/t/stash.t See if B::Stash works
use Exporter (); # use #5
-our $VERSION = "0.61";
+our $VERSION = "0.62";
our @ISA = qw(Exporter);
-our @EXPORT_OK = qw(set_style set_style_standard add_callback
- concise_subref concise_cv concise_main
- add_style walk_output);
+our @EXPORT_OK = qw( set_style set_style_standard add_callback
+ concise_subref concise_cv concise_main
+ add_style walk_output compile reset_sequence );
+our %EXPORT_TAGS =
+ ( io => [qw( walk_output compile reset_sequence )],
+ style => [qw( add_style set_style_standard )],
+ cb => [qw( add_callback )],
+ mech => [qw( concise_subref concise_cv concise_main )], );
# use #6
use B qw(class ppname main_start main_root main_cv cstring svref_2object
"#class pp_#name"],
"concise" =>
["#hyphseq2 (*( (x( ;)x))*)<#classsym> "
- . "#exname#arg(?([#targarglife])?)~#flags(?(/#private)?)(x(;~->#next)x)\n",
- " (*( )*) goto #seq\n",
+ . "#exname#arg(?([#targarglife])?)~#flags(?(/#private)?)(x(;~->#next)x)\n"
+ , " (*( )*) goto #seq\n",
"(?(<#seq>)?)#exname#arg(?([#targarglife])?)"],
"linenoise" =>
["(x(;(*( )*))x)#noise#arg(?([#targarg])?)(x( ;\n)x)",
my $big_endian = 1; # more <sequence#> display
my $tree_style = 0; # tree-order details
my $banner = 1; # print banner before optree is traversed
+my $do_main = 0; # force printing of main routine
-# another factor:
+# another factor: can affect all styles!
our @callbacks; # allow external management
set_style_standard("concise");
}
# output handle, used with all Concise-output printing
-our $walkHandle = \*STDOUT; # public for your convenience
+our $walkHandle; # public for your convenience
+BEGIN { $walkHandle = \*STDOUT }
sub walk_output { # updates $walkHandle
my $handle = shift;
+ return $walkHandle unless $handle; # allow use as accessor
+
if (ref $handle eq 'SCALAR') {
require Config;
die "no perlio in this build, can't call walk_output (\\\$scalar)\n"
# in 5.8+, open(FILEHANDLE,MODE,REFERENCE) writes to string
open my $tmp, '>', $handle; # but cant re-set existing STDOUT
$walkHandle = $tmp; # so use my $tmp as intermediate var
- return;
+ return $walkHandle;
}
- $walkHandle = $handle;
- my $iotype = ref $walkHandle;
+ my $iotype = ref $handle;
die "expecting argument/object that can print\n"
- unless $iotype eq 'GLOB' or $iotype and $walkHandle->can('print');
+ unless $iotype eq 'GLOB' or $iotype and $handle->can('print');
+ $walkHandle = $handle;
}
sub concise_subref {
my($order, $coderef) = @_;
my $codeobj = svref_2object($coderef);
- die "err: not a coderef: $coderef\n" unless ref $codeobj eq 'B::CV';#CODE';
+
+ return concise_stashref(@_)
+ unless ref $codeobj eq 'B::CV';
concise_cv_obj($order, $codeobj);
}
+sub concise_stashref {
+ my($order, $h) = @_;
+ foreach my $k (sort keys %$h) {
+ local *s = $h->{$k};
+ my $coderef = *s{CODE} or next;
+ reset_sequence();
+ print "FUNC: ", *s, "\n";
+ my $codeobj = svref_2object($coderef);
+ next unless ref $codeobj eq 'B::CV';
+ eval { concise_cv_obj($order, $codeobj) }
+ or warn "err $@ on $codeobj";
+ }
+}
+
# This should have been called concise_subref, but it was exported
# under this name in versions before 0.56
sub concise_cv { concise_subref(@_); }
[" ", map("$start_sym$_$end_sym", "q", "w", "t", "x", "m"), "", 0],
);
-sub compile {
+
+sub compileOpts {
+ # set rendering state from options and args
my @options = grep(/^-/, @_);
my @args = grep(!/^-/, @_);
- my $do_main = 0;
for my $o (@options) {
+ # mode/order
if ($o eq "-basic") {
$order = "basic";
} elsif ($o eq "-exec") {
$order = "exec";
} elsif ($o eq "-tree") {
$order = "tree";
- } elsif ($o eq "-compact") {
+ }
+ # tree-specific
+ elsif ($o eq "-compact") {
$tree_style |= 1;
} elsif ($o eq "-loose") {
$tree_style &= ~1;
$tree_style |= 2;
} elsif ($o eq "-ascii") {
$tree_style &= ~2;
- } elsif ($o eq "-main") {
- $do_main = 1;
- } elsif ($o =~ /^-base(\d+)$/) {
+ }
+ # sequence numbering
+ elsif ($o =~ /^-base(\d+)$/) {
$base = $1;
} elsif ($o eq "-bigendian") {
$big_endian = 1;
} elsif ($o eq "-littleendian") {
$big_endian = 0;
- } elsif ($o eq "-banner") {
+ }
+ elsif ($o eq "-nobanner") {
$banner = 0;
+ } elsif ($o eq "-banner") {
+ $banner = 1;
+ }
+ elsif ($o eq "-main") {
+ $do_main = 1;
+ } elsif ($o eq "-nomain") {
+ $do_main = 0;
}
+ # line-style options
elsif (exists $style{substr($o, 1)}) {
$stylename = substr($o, 1);
set_style_standard($stylename);
warn "Option $o unrecognized";
}
}
+ return (@args);
+}
+
+sub compile {
+ my (@args) = compileOpts(@_);
return sub {
- if (@args) {
- for my $objname (@args) {
- if ($objname eq "BEGIN") {
- concise_specials("BEGIN", $order,
- B::begin_av->isa("B::AV") ?
- B::begin_av->ARRAY : ());
- } elsif ($objname eq "INIT") {
- concise_specials("INIT", $order,
- B::init_av->isa("B::AV") ?
- B::init_av->ARRAY : ());
- } elsif ($objname eq "CHECK") {
- concise_specials("CHECK", $order,
- B::check_av->isa("B::AV") ?
- B::check_av->ARRAY : ());
- } elsif ($objname eq "END") {
- concise_specials("END", $order,
- B::end_av->isa("B::AV") ?
- B::end_av->ARRAY : ());
+ my @newargs = compileOpts(@_); # accept new rendering options
+ warn "disregarding non-options: @newargs\n" if @newargs;
+
+ for my $objname (@args) {
+
+ if ($objname eq "BEGIN") {
+ concise_specials("BEGIN", $order,
+ B::begin_av->isa("B::AV") ?
+ B::begin_av->ARRAY : ());
+ } elsif ($objname eq "INIT") {
+ concise_specials("INIT", $order,
+ B::init_av->isa("B::AV") ?
+ B::init_av->ARRAY : ());
+ } elsif ($objname eq "CHECK") {
+ concise_specials("CHECK", $order,
+ B::check_av->isa("B::AV") ?
+ B::check_av->ARRAY : ());
+ } elsif ($objname eq "END") {
+ concise_specials("END", $order,
+ B::end_av->isa("B::AV") ?
+ B::end_av->ARRAY : ());
+ }
+ else {
+ # convert function names to subrefs
+ my $objref;
+ if (ref $objname) {
+ print $walkHandle "B::Concise::compile($objname)\n"
+ if $banner;
+ $objref = $objname;
} else {
- # convert function names to subrefs
- my $objref;
- if (ref $objname) {
- print $walkHandle "B::Concise::compile($objname)\n"
- if $banner;
- $objref = $objname;
- } else {
- $objname = "main::" . $objname unless $objname =~ /::/;
- print $walkHandle "$objname:\n";
- no strict 'refs';
- die "err: unknown function ($objname)\n"
- unless *{$objname}{CODE};
- $objref = \&$objname;
- }
- concise_subref($order, $objref);
+ $objname = "main::" . $objname unless $objname =~ /::/;
+ print $walkHandle "$objname:\n";
+ no strict 'refs';
+ die "err: unknown function ($objname)\n"
+ unless *{$objname}{CODE};
+ $objref = \&$objname;
}
+ concise_subref($order, $objref);
}
}
if (!@args or $do_main) {
print $walkHandle "main program:\n" if $do_main;
concise_main($order);
}
+ return @args; # something
}
}
# reset the sequence
%sequence_num = ();
$seq_max = 1;
+ $lastnext = 0;
}
sub seq {
}
sub fmt_line { # generate text-line for op.
- my($hr, $text, $level) = @_;
+ my($hr, $op, $text, $level) = @_;
+
+ $_->($hr, $op, \$text, \$level, $stylename) for @callbacks;
+
return '' if $hr->{SKIP}; # suppress line if a callback said so
+ return '' if $hr->{goto} and $hr->{goto} eq '-'; # no goto nowhere
+ # spec: (?(text1#varText2)?)
$text =~ s/\(\?\(([^\#]*?)\#(\w+)([^\#]*?)\)\?\)/
$hr->{$2} ? $1.$hr->{$2}.$3 : ""/eg;
+ # spec: (x(exec_text;basic_text)x)
$text =~ s/\(x\((.*?);(.*?)\)x\)/$order eq "exec" ? $1 : $2/egs;
+
+ # spec: (*(text)*)
$text =~ s/\(\*\(([^;]*?)\)\*\)/$1 x $level/egs;
+
+ # spec: (*(text1;text2)*)
$text =~ s/\(\*\((.*?);(.*?)\)\*\)/$1 x ($level - 1) . $2 x ($level>0)/egs;
+
+ # convert #Var to tag=>val form: Var\t#var
+ $text =~ s/\#([A-Z][a-z]+)(\d+)?/\t\u$1\t\L#$1$2/gs;
+
+ # spec: #varN
$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;
+ $text =~ s/\#([a-zA-Z]+)/$hr->{$1}/eg; # populate #var's
+ $text =~ s/[ \t]*~+[ \t]*/ /g; # squeeze tildes
chomp $text;
return "$text\n" if $text ne "";
return $text; # suppress empty lines
} elsif (class($sv) eq "HV") {
$hr->{svval} .= 'HASH';
}
- return $hr->{svclass} . " " . $hr->{svval};
+
+ $hr->{svval} = 'undef' unless defined $hr->{svval};
+ my $out = $hr->{svclass};
+ return $out .= " $hr->{svval}" ;
}
}
$h{typenum} = $op->type;
$h{noise} = $linenoise[$op->type];
- $_->(\%h, $op, \$format, \$level, $stylename) for @callbacks;
- return fmt_line(\%h, $format, $level);
+ return fmt_line(\%h, $op, $format, $level);
}
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);
+ my $synth = {"seq" => seq($lastnext), "class" => class($lastnext),
+ "addr" => sprintf("%#x", $$lastnext),
+ "goto" => seq($lastnext), # simplify goto '-' removal
+ };
+ print $walkHandle fmt_line($synth, $op, $gotofmt, $level+1);
}
$lastnext = $op->next;
print $walkHandle concise_op($op, $level, $format);
# insert a 'goto'
my $h = {"seq" => seq($lastnext), "class" => class($lastnext),
"addr" => sprintf("%#x", $$lastnext)};
- print fmt_line($h, $style{"terse"}[1], $level+1);
+ print # $walkHandle
+ fmt_line($h, $op, $style{"terse"}[1], $level+1);
}
$lastnext = $op->next;
- print concise_op($op, $level, $style{"terse"}[0]);
+ print # $walkHandle
+ concise_op($op, $level, $style{"terse"}[0]);
}
sub tree {
=head2 Other options
+These are pairwise exclusive.
+
=over 4
=item B<-main>
Include the main program in the output, even if subroutines were also
-specified. This is the only option that is not sticky (see below)
+specified. This rendering is normally suppressed when a subroutine
+name or reference is given.
+
+=item B<-nomain>
+
+This restores the default behavior after you've changed it with '-main'
+(it's not normally needed). If no subroutine name/ref is given, main is
+rendered, regardless of this flag.
+
+=item B<-nobanner>
+
+Renderings usually include a banner line identifying the function name
+or stringified subref. This suppresses the printing of the banner.
+
+TBC: Remove the stringified coderef; while it provides a 'cookie' for
+each function rendered, the cookies used should be 1,2,3.. not a
+random hex-address. It also complicates string comparison of two
+different trees.
=item B<-banner>
-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.
+restores default banner behavior.
+
+=item B<-banneris> => subref
+
+TBC: a hookpoint (and an option to set it) for a user-supplied
+function to produce a banner appropriate for users needs. It's not
+ideal, because the rendering-state variables, which are a natural
+candidate for use in concise.t, are unavailable to the user.
=back
the first call will be remembered for the 2nd call, unless you
re-specify or change them.
+=head1 ABBREVIATIONS
+
+The concise style uses symbols to convey maximum info with minimal
+clutter (like hex addresses). With just a little practice, you can
+start to see the flowers, not just the branches, in the trees.
+
+=head2 OP class abbreviations
+
+These symbols appear before the op-name, and indicate the
+B:: namespace that represents the ops in your Perl code.
+
+ 0 OP (aka BASEOP) An OP with no children
+ 1 UNOP An OP with one child
+ 2 BINOP An OP with two children
+ | LOGOP A control branch OP
+ @ LISTOP An OP that could have lots of children
+ / PMOP An OP with a regular expression
+ $ SVOP An OP with an SV
+ " PVOP An OP with a string
+ { LOOP An OP that holds pointers for a loop
+ ; COP An OP that marks the start of a statement
+ # PADOP An OP with a GV on the pad
+
+=head2 OP flags abbreviations
+
+These symbols represent various flags which alter behavior of the
+opcode, sometimes in opcode-specific ways.
+
+ v OPf_WANT_VOID Want nothing (void context)
+ s OPf_WANT_SCALAR Want single value (scalar context)
+ l OPf_WANT_LIST Want list of any length (list context)
+ K OPf_KIDS There is a firstborn child.
+ P OPf_PARENS This operator was parenthesized.
+ (Or block needs explicit scope entry.)
+ R OPf_REF Certified reference.
+ (Return container, not containee).
+ M OPf_MOD Will modify (lvalue).
+ S OPf_STACKED Some arg is arriving on the stack.
+ * OPf_SPECIAL Do something weird for this op (see op.h)
+
=head1 FORMATTING SPECIFICATIONS
For each line-style ('concise', 'terse', 'linenoise', etc.) there 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.)
+When a line is rendered, the correct format-spec is copied and scanned
+for the following items; data is substituted in, and other
+manipulations like basic indenting are done, for each opcode rendered.
+
+There are 3 kinds of items that may be populated; special patterns,
+#vars, and literal text, which is copied verbatim. (Yes, it's a set
+of s///g steps.)
+
+=head2 Special Patterns
+
+These items are the primitives used to perform indenting, and to
+select text from amongst alternatives.
=over 4
value of I<var> surrounded by I<text1> and I<Text2>, otherwise
nothing.
+=item B<~>
+
+Any number of tildes and surrounding whitespace will be collapsed to
+a single space.
+
+=back
+
+=head2 # Variables
+
+These #vars represent opcode properties that you may want as part of
+your rendering. The '#' is intended as a private sigil; a #var's
+value is interpolated into the style-line, much like "read $this".
+
+These vars take 3 forms:
+
+=over 4
+
=item B<#>I<var>
-Generates the value of the variable I<var>.
+A property named 'var' is assumed to exist for the opcodes, and is
+interpolated into the rendering.
=item B<#>I<var>I<N>
-Generates the value of I<var>, left jutified to fill I<N> spaces.
+Generates the value of I<var>, left justified to fill I<N> spaces.
+Note that this means while you can have properties 'foo' and 'foo2',
+you cannot render 'foo2', but you could with 'foo2a'. You would be
+wise not to rely on this behavior going forward ;-)
-=item B<~>
+=item B<#>I<Var>
-Any number of tildes and surrounding whitespace will be collapsed to
-a single space.
+This ucfirst form of #var generates a tag-value form of itself for
+display; it converts '#Var' into a 'Var => #var' style, which is then
+handled as described above. (Imp-note: #Vars cannot be used for
+conditional-fills, because the => #var transform is done after the check
+for #Var's value).
=back
-The following variables are recognized:
+The following variables are 'defined' by B::Concise; when they are
+used in a style, their respective values are plugged into the
+rendering of each opcode.
+
+Only some of these are used by the standard styles, the others are
+provided for you to delve into optree mechanics, should you wish to
+add a new style (see L</add_style> below) that uses them. You can
+also add new ones using L<add_callback>.
=over 4
=item B<#addr>
-The address of the OP, in hexidecimal.
+The address of the OP, in hexadecimal.
=item B<#arg>
The OP-specific information of the OP (such as the SV for an SVOP, the
-non-local exit pointers for a LOOP, etc.) enclosed in paretheses.
+non-local exit pointers for a LOOP, etc.) enclosed in parentheses.
=item B<#class>
=back
-=head1 ABBREVIATIONS
-
-=head2 OP flags abbreviations
-
- v OPf_WANT_VOID Want nothing (void context)
- s OPf_WANT_SCALAR Want single value (scalar context)
- l OPf_WANT_LIST Want list of any length (list context)
- K OPf_KIDS There is a firstborn child.
- P OPf_PARENS This operator was parenthesized.
- (Or block needs explicit scope entry.)
- R OPf_REF Certified reference.
- (Return container, not containee).
- M OPf_MOD Will modify (lvalue).
- S OPf_STACKED Some arg is arriving on the stack.
- * OPf_SPECIAL Do something weird for this op (see op.h)
-
-=head2 OP class abbreviations
-
- 0 OP (aka BASEOP) An OP with no children
- 1 UNOP An OP with one child
- 2 BINOP An OP with two children
- | LOGOP A control branch OP
- @ LISTOP An OP that could have lots of children
- / PMOP An OP with a regular expression
- $ SVOP An OP with an SV
- " PVOP An OP with a string
- { LOOP An OP that holds pointers for a loop
- ; COP An OP that marks the start of a statement
- # PADOP An OP with a GV on the pad
-
=head1 Using B::Concise outside of the O framework
-You can use B<B::Concise>, and call compile() directly, and
+The common (and original) usage of B::Concise was for command-line
+renderings of simple code, as given in EXAMPLE. But you can also use
+B<B::Concise> from your code, 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.
+operation of O.pm, and even 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>.
+Once you're doing this, you may alter Concise output by adding new
+rendering styles, and by optionally adding callback routines which
+populate new variables, if such were referenced from those (just
+added) styles.
=head2 Example: Altering Concise Renderings
use B::Concise qw(set_style add_callback);
- set_style($your_format, $your_gotofmt, $your_treefmt);
+ add_style($yourStyleName => $defaultfmt, $gotofmt, $treefmt);
add_callback
( sub {
my ($h, $op, $format, $level, $stylename) = @_;
$h->{variable} = some_func($op);
- }
- );
- B::Concise::compile(@options)->();
+ });
+ $walker = B::Concise::compile(@options,@subnames,@subrefs);
+ $walker->();
=head2 set_style()
B<compile> accepts options as described above in L</OPTIONS>, and
arguments, which are either coderefs, or subroutine names.
-compile() constructs and returns a coderef, which when invoked, scans
-the optree, and prints the results to STDOUT. Once you have the
-coderef, you may change the output style; thereafter the coderef renders
-in the new style.
+It constructs and returns a $treewalker coderef, which when invoked,
+traverses, or walks, and renders the optrees of the given arguments to
+STDOUT. You can reuse this, and can change the rendering style used
+each time; thereafter the coderef renders in the new style.
B<walk_output> lets you change the print destination from STDOUT to
another open filehandle, or (unless you've built with -Uuseperlio)
into a string passed as a ref.
+ my $walker = B::Concise::compile('-terse','aFuncName', \&aSubRef); # 1
walk_output(\my $buf);
- 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 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
-B::Concise::compile() (as done above).
+ $walker->(); # 1 renders -terse
+ set_style_standard('concise'); # 2
+ $walker->(); # 2 renders -concise
+ $walker->(@new); # 3 renders whatever
+ print "3 different renderings: terse, concise, and @new: $buf\n";
+
+When $walker is called, it traverses the subroutines supplied when it
+was created, and renders them using the current style. You can change
+the style afterwards in several different ways:
+
+ 1. call C<compile>, altering style or mode/order
+ 2. call C<set_style_standard>
+ 3. call $walker, passing @new options
+
+Passing new options to the $walker is the easiest way to change
+amongst any pre-defined styles (the ones you add are automatically
+recognized as options), and is the only way to alter rendering order
+without calling compile again. Note however that rendering state is
+still shared amongst multiple $walker objects, so they must still be
+used in a coordinated manner.
=head2 B::Concise::reset_sequence()
package B::Showlex;
-our $VERSION = '1.00';
+our $VERSION = '1.01';
use strict;
use B qw(svref_2object comppadlist class);
use B::Terse ();
+use B::Concise ();
#
# Invoke as
# or as
# perl -MO=Showlex bar.pl
# to see the names of file scope lexicals used by bar.pl
-#
+#
+
+
+# borrowed from B::Concise
+our $walkHandle = \*STDOUT;
+
+sub walk_output { # updates $walkHandle
+ $walkHandle = B::Concise::walk_output(@_);
+ #print "got $walkHandle";
+ #print $walkHandle "using it";
+ $walkHandle;
+}
sub shownamearray {
my ($name, $av) = @_;
my @els = $av->ARRAY;
my $count = @els;
my $i;
- print "$name has $count entries\n";
+ print $walkHandle "$name has $count entries\n";
for ($i = 0; $i < $count; $i++) {
- print "$i: ";
my $sv = $els[$i];
if (class($sv) ne "SPECIAL") {
- printf "%s (0x%lx) %s\n", class($sv), $$sv, $sv->PVX;
+ printf $walkHandle "$i: %s (0x%lx) %s\n", class($sv), $$sv, $sv->PVX;
} else {
- $sv->terse;
+ printf $walkHandle "$i: %s\n", $sv->terse;
+ #printf $walkHandle "$i: %s\n", B::Concise::concise_sv($sv);
}
}
}
my @els = $av->ARRAY;
my $count = @els;
my $i;
- print "$name has $count entries\n";
+ print $walkHandle "$name has $count entries\n";
for ($i = 0; $i < $count; $i++) {
- print "$i: ";
- $els[$i]->terse;
+ printf $walkHandle "$i: %s\n", $els[$i]->terse;
+ #print $walkHandle "$i: %s\n", B::Concise::concise_sv($els[$i]);
}
}
showvaluearray("Pad of lexical values for $objname", $valsav);
}
+sub newlex { # drop-in for showlex
+ my ($objname, $names, $vals) = @_;
+ my @names = $names->ARRAY;
+ my @vals = $vals->ARRAY;
+ my $count = @names;
+ print $walkHandle "$objname Pad has $count entries\n";
+ printf $walkHandle "0: %s\n", $names[0]->terse;
+ for (my $i = 1; $i < $count; $i++) {
+ printf $walkHandle "$i: %s = %s\n", $names[$i]->terse, $vals[$i]->terse;
+ }
+}
+
+my $newlex; # rendering state var
+
sub showlex_obj {
my ($objname, $obj) = @_;
$objname =~ s/^&main::/&/;
- showlex($objname, svref_2object($obj)->PADLIST->ARRAY);
+ showlex($objname, svref_2object($obj)->PADLIST->ARRAY) if !$newlex;
+ newlex ($objname, svref_2object($obj)->PADLIST->ARRAY) if $newlex;
}
sub showlex_main {
}
sub compile {
- my @options = @_;
- if (@options) {
- return sub {
- my $objname;
- foreach $objname (@options) {
+ my @options = grep(/^-/, @_);
+ my @args = grep(!/^-/, @_);
+ for my $o (@options) {
+ $newlex = 1 if $o eq "-newlex";
+ }
+
+ return \&showlex_main unless @args;
+ return sub {
+ foreach my $objname (@args) {
+ my $objref;
+ if (ref $objname) {
+ print $walkHandle "B::Showlex::compile($objname)\n";
+ $objref = $objname;
+ } else {
$objname = "main::$objname" unless $objname =~ /::/;
- eval "showlex_obj('&$objname', \\&$objname)";
+ print $walkHandle "$objname:\n";
+ no strict 'refs';
+ die "err: unknown function ($objname)\n"
+ unless *{$objname}{CODE};
+ $objref = \&$objname;
}
+ showlex_obj($objname, $objref);
}
- } else {
- return \&showlex_main;
}
}
} else {
concise_subref('basic', $subref);
}
-
}
sub compile {
}
sub indent {
- my $level = @_ ? shift : 0;
+ my ($level) = @_ ? shift : 0;
return " " x $level;
}
my($sv, $level) = (@_, 0);
my %info;
B::Concise::concise_sv($sv, \%info);
- my $s = B::Concise::fmt_line(\%info, "#svclass~(?((#svaddr))?)~#svval", 0);
- print indent($level), $s, "\n";
+ my $s = indent($level)
+ . B::Concise::fmt_line(\%info, $sv,
+ "#svclass~(?((#svaddr))?)~#svval", 0);
+ chomp $s;
+ print "$s\n" unless defined wantarray;
+ $s;
}
sub B::NULL::terse {
my ($sv, $level) = @_;
- print indent($level);
- printf "%s (0x%lx)\n", class($sv), $$sv;
+ my $s = indent($level) . sprintf "%s (0x%lx)", class($sv), $$sv;
+ print "$s\n" unless defined wantarray;
+ $s;
}
sub B::SPECIAL::terse {
my ($sv, $level) = @_;
- print indent($level);
- printf "%s #%d %s\n", class($sv), $$sv, $specialsv_name[$$sv];
+ my $s = indent($level)
+ . sprintf( "%s #%d %s", class($sv), $$sv, $specialsv_name[$$sv]);
+ print "$s\n" unless defined wantarray;
+ $s;
}
1;
-# OptreeCheck.pm
-# package-less .pm file allows 'use OptreeCheck';
+# non-package OptreeCheck.pm
+# pm allows 'use OptreeCheck', which also imports
+# no package decl means all functions defined into main
# otherwise, it's like "require './test.pl'"
=head1 NAME
=head1 SYNOPSIS
OptreeCheck supports regression testing of perl's parser, optimizer,
-bytecode generator, via a single function: checkOptree(%args).
+bytecode generator, via a single function: checkOptree(%args).'
- checkOptree(name => "your title here",
+ checkOptree(name => "your title here", # optional, (synth from others)
bcopts => '-exec', # $opt or \@opts, passed to BC::compile
- code => sub {my $a}, # must be CODE ref
+ code => sub {my $a}, # coderef, or source (wrapped and evald)
# prog => 'sort @a', # run in subprocess, aka -MO=Concise
# skip => 1, # skips test
# todo => 'excuse', # anticipated failures
=head1 checkOptree(%in) Overview
-Runs code or prog through B::Concise, and captures its rendering.
+Calls getRendering(), which 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.
+Also calls like($rendering,/$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.
+expect and expect_nt are both: required, not empty, not whitespace.
+It's a fatal error otherwise, 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)
+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():
+treated like source, but is wrapped as a subroutine, and passed to
+B::Concise::compile().
$subref = eval "sub{$src}";
-I suppose I should also explain these more, but..
+I suppose I should also explain these more, but they seem obvious.
# prog => 'sort @a', # run in subprocess, aka -MO=Concise
+ # noanchors => 1, # no /^$/. needed for 1-liners like above
+
# skip => 1, # skips test
- # todo => 'excuse', # anticipated failures
- # fail => 1 # fails (by redirecting result)
+ # 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
+=head1 Test Philosophy
2 platforms --> 2 reftexts: You want an accurate test, independent of
-which platform youre on. This is obvious in retrospect, but ..
+which platform you're on. So, two refdata properties, 'expect' and
+'expect_nt', carry renderings taken from threaded and non-threaded
+builds. This has several benefits:
-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.
+ 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 regexes which accomodate t-nt differences.
+ 5. can test with both native and cross+converted regexes.
Cross-testing (expect_nt on threaded, expect on non-threaded) exposes
differences in B::Concise output, so mkCheckRex has code to do some
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.
+tested.'
=cut
fail => 'force all test to fail, print to stdout',
dump => 'dump cmdline arg prcessing',
rexpedant => 'try tighter regex, still buggy',
+ noanchors => 'dont anchor match rex',
help => 0, # 1 ends in die
# array values are one-of selections, with 1st value as default
cross => [ !($threaded) ? 'expect' : 'expect_nt'],
expect => [ 'expect' ],
expect_nt => [ 'expect_nt' ],
- );
+ );
our %msgs # announce cross-testing.
= (
print "checkOptree args: ",Dumper \%in if $in{dump};
SKIP: {
+ label(\%in);
skip($in{name}, 1) if $in{skip};
return runSelftest(\%in) if $gOpts{selftest};
fail("FORCED: $in{name}:\n$rendering") if $gOpts{fail}; # silly ?
# Test rendering against ..
+ TODO:
foreach $want (@{$modes{$gOpts{testmode}}}) {
+ local $TODO = $in{todo} if $in{todo};
- my $rex = mkCheckRex(\%in,$want);
+ my ($rex,$txt,$rexstr) = 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);
+ or 0); # no undefs! pedant
# couldn't bear to pass \%in to likeyn
$res = mylike ( # custom test mode stuff
[ !$bad,
- $in{retry} || $gOpts{retry},
- $in{debug} || $gOpts{retrydbg}
+ $in{retry} || $gOpts{retry},
+ $in{debug} || $gOpts{retrydbg},
+ $rexstr,
],
# remaining is std API
- $rendering, qr/$rex/ms, "$cross $in{name}")
+ $rendering, qr/$rex/ms, "$cross $in{name} $in{label}")
|| 0;
printhelp(\%in, $rendering, $rex);
}
sub label {
# may help get/keep test output consistent
my ($in) = @_;
- $in->{label} = join(',', map {"$_=>$in->{$_}"}
- qw( bcopts name prog code ));
+ return if $in->{name};
+
+ my $buf = (ref $in->{bcopts})
+ ? join(',', @{$in->{bcopts}}) : $in->{bcopts};
+
+ foreach (qw( note prog code )) {
+ $buf .= " $_: $in->{$_}" if $in->{$_} and not ref $in->{$_};
+ }
+ return $in->{label} = $buf;
}
sub testCombo {
my $in = @_;
my @cases;
foreach $want (@{$modes{$gOpts{testmode}}}) {
-
- push @cases, [ %in,
- ];
+ push @cases, [ %in ]
}
return @cases;
}
# couldn't bear to pass \%in to likeyn
$res = mylike ( [ !$bad,
$in->{retry} || $gOpts{retry},
- $in->{debug} || $gOpts{retrydbg}
+ $in->{debug} || $gOpts{retrydbg},
+ #label($in)
],
$rendering, qr/$rex/ms, "$cross $in{name}")
|| 0;
sub mylike {
# note dependence on unlike()
my ($control) = shift;
- my ($yes,$retry,$debug) = @$control; # or dies
+ my ($yes,$retry,$debug,$postmortem) = @$control; # or dies
my ($got, $expected, $name, @mess) = @_; # pass thru mostly
die "unintended usage, expecting Regex". Dumper \@_
unless ref $_[1] eq 'Regexp';
+ #ok($got=~/$expected/, "wow");
+
# 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 $postmortem) {
+ # split rexstr into units that should eat leading lines.
+ my @rexs = map qr/^$_/, split (/\n/,$postmortem);
+ foreach my $rex (@rexs) {
+ #$got =~ s/($rex)/ate: $1/msg; # noisy
+ $got =~ s/($rex)\n//msg; # remove matches
+ }
+ print "sequentially deconstructed, these are unmatched:\n$got\n";
+ }
+
if (not $ok and $retry) {
- # redo, perhaps with use re debug
+ # redo, perhaps with use re debug - NOT ROBUST
eval "use re 'debug'" if $debug;
$ok = (!$yes and unlike($got, $expected, "(RETRY) $name", @mess)
or $yes and like($got, $expected, "(RETRY) $name", @mess));
$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..
+ # convert all (args) and [args] to temp forms wo bracing
+ $str =~ s/\[(.*?)\]/__CAPSQR$1__/msg;
+ $str =~ s/\((.*?)\)/__CAPRND$1__/msg;
+ $str =~ s/\((.*?)\)/__CAPRND$1__/msg; # nested () in nextstate
+
+ # escape bracing, etc.. manual \Q (doesnt escape '+')
+ $str =~ s/([\[\]()*.\$\@\#\|{}])/\\$1/msg;
+
+ # now replace temp forms with original, preserving reference bracing
+ $str =~ s/__CAPSQR(.*?)__\b/\\[$1\\]/msg; # \b is important
+ $str =~ s/__CAPRND(.*?)__\b/\\($1\\)/msg;
+ $str =~ s/__CAPRND(.*?)__\b/\\($1\\)/msg; # nested () in nextstate
+
+ # no 'invisible' failures in debugger
+ $str =~ s/(?:next|db)state(\\\(.*?\\\))/(?:next|db)state(.*?)/msg;
+
+ # don't care about:
+ $str =~ s/:-?\d+,-?\d+/:-?\\d+,-?\\d+/msg; # FAKE line numbers
+ $str =~ s/match\\\(.*?\\\)/match\(.*?\)/msg; # match args
+ $str =~ s/(0x[0-9A-Fa-f]+)/0x[0-9A-Fa-f]+/msg; # hexnum values
+ $str =~ s/".*?"/".*?"/msg; # quoted strings
- # 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+
-
+ # allow -eval, banner at beginning of anchored matches
+ $str = "(-e .*?)?(B::Concise::compile.*?)?\n" . $str
+ unless $in->{noanchors};
+
eval "use re 'debug'" if $debug;
- my $qr = qr/$str/;
+ my $qr = ($in->{noanchors}) ? qr/$str/ms : qr/^$str$/ms ;
no re 'debug';
- return ($qr, $reftxt) if wantarray;
+ return ($qr, $reftxt, $str) if wantarray;
return $qr;
}
+
sub printhelp {
+ # crufty - may be still useful
my ($in, $rendering, $rex) = @_;
- print "<$rendering>\nVS\n<$reftext>\n" if $gOpts{vbasic};
+ print "<$rendering>\nVS\n<$rex>\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".
+ print("\$str = q%$rendering%;\n".
+ "\$rex = qr%$rex%;\n\n".
+ #"print \"\$str =~ m%\$rex%ms \";\n".
"\$str =~ m{\$rex}ms or print \"doh\\n\";\n\n")
if $in{rextract} or $gOpts{rextract};
}
+
+#########################
+# support for test writing
+
+sub preamble {
+ my $testct = shift || 1;
+ return <<EO_HEADER;
+#!perl
+
+BEGIN {
+ chdir q(t);
+ \@INC = qw(../lib ../ext/B/t);
+ require q(./test.pl);
+}
+use OptreeCheck;
+plan tests => $testct;
+
+EO_HEADER
+
+}
+
+sub OptreeCheck::wrap {
+ my $code = shift;
+ $code =~ s/(?:(\#.*?)\n)//gsm;
+ $code =~ s/\s+/ /mgs;
+ chomp $code;
+ return unless $code =~ /\S/;
+ my $comment = $1;
+
+ my $testcode = qq{
+
+checkOptree(note => q{$comment},
+ bcopts => q{-exec},
+ code => q{$code},
+ expect => <<EOT_EOT, expect_nt => <<EONT_EONT);
+ThreadedRef
+EOT_EOT
+NonThreadRef
+EONT_EONT
+
+};
+ return $testcode;
+}
+
+sub OptreeCheck::gentest {
+ my ($code,$opts) = @_;
+ my $rendering = getRendering({code => $code});
+ my $testcode = OptreeCheck::wrap($code);
+ return unless $testcode;
+
+ # run the prog, capture 'reference' concise output
+ my $preamble = preamble(1);
+ my $got = runperl( prog => "$preamble $testcode", stderr => 1,
+ #switches => ["-I../ext/B/t", "-MOptreeCheck"],
+ ); #verbose => 1);
+
+ # extract the 'reftext' ie the got 'block'
+ if ($got =~ m/got \'.*?\n(.*)\n\# \'\n\# expected/s) {
+ my $reftext = $1;
+ #and plug it into the test-src
+ if ($threaded) {
+ $testcode =~ s/ThreadedRef/$reftext/;
+ } else {
+ $testcode =~ s/NonThreadRef/$reftext/;
+ }
+ my $b4 = q{expect => <<EOT_EOT, expect_nt => <<EONT_EONT};
+ my $af = q{expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'};
+ $testcode =~ s/$b4/$af/;
+
+ my $got;
+ if ($internal_retest) {
+ $got = runperl( prog => "$preamble $testcode", stderr => 1,
+ #switches => ["-I../ext/B/t", "-MOptreeCheck"],
+ verbose => 1);
+ print "got: $got\n";
+ }
+ return $testcode;
+ }
+ return '';
+}
+
+
+sub OptreeCheck::processExamples {
+ my @files = @_;
+ # gets array of paragraphs, which should be tests.
+
+ foreach my $file (@files) {
+ open (my $fh, $file) or die "cant open $file: $!\n";
+ $/ = "";
+ my @chunks = <$fh>;
+ print preamble (scalar @chunks);
+ foreach $t (@chunks) {
+ print "\n\n=for gentest\n\n# chunk: $t=cut\n\n";
+ print OptreeCheck::gentest ($t);
+ }
+ }
+}
+
+# OK - now for the final insult to your good taste...
+
+if ($0 =~ /OptreeCheck\.pm/) {
+
+ #use lib 't';
+ require './t/test.pl';
+
+ # invoked as program. Work like former gentest.pl,
+ # ie read files given as cmdline args,
+ # convert them to usable test files.
+
+ require Getopt::Std;
+ Getopt::Std::getopts('') or
+ die qq{ $0 sample-files* # no options
+
+ expecting filenames as args. Each should have paragraphs,
+ these are converted to checkOptree() tests, and printed to
+ stdout. Redirect to file then edit for test. \n};
+
+ OptreeCheck::processExamples(@ARGV);
+}
+
1;
__END__
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.
+Once selected, reftext is massaged & converted into a Regex that
+accepts 'good' concise renderings, with appropriate input variations,
+but is otherwise 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
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.
+The regex is anchored by default, but can be suppressed with
+'noanchors', allowing 1-liner tests to succeed if opcode is found.
-=head1 FEATURES, BUGS, ENHANCEMENTS
+=head1 TEST DEVELOPMENT SUPPORT
-Hey, they're the same thing now, modulo heisen-phase-shifting, and the
-probe used to observe them.
+This optree regression testing framework needs tests in order to find
+bugs. To that end, OptreeCheck has support for developing new tests,
+according to the following model:
-=head1 Test Data
+ 1. write a set of sample code into a single file, one per
+ paragraph. f_map and f_sort in ext/B/t/ are examples.
-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:
+ 2. run OptreeCheck as a program on the file
- 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
+ ./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
-Enhancements:
+ gentest reads the sample code, runs each to generate a reference
+ rendering, folds this rendering into an optreeCheck() statement,
+ and prints it to stdout.
-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.
+ 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.
-build_only: tests which dont have the reference-sample of the
-right provenance will be skipped. NO GOOD.
+=head1 TODO
-prefer_expect: This is implied standard, as all tests done thus far
-started here. One way t->nt conversions is done, based upon Config.
+There's a considerable amount of cruft in the whole arg-handling setup.
+I'll replace / strip it before 5.10
-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.
+Treat %in as a test object, interwork better with Test::*
-activemapping: This builds upon activetest by controlling whether
-t<->nt conversions are done, and allows simpler verification that each
-conversion step is indeed necessary.
+Refactor mkCheckRex() and selfTest() to isolate the selftest,
+crosstest, etc selection mechanics.
-pedantic: this fails if tests dont have both, whereas above doesn't care.
+improve retry, retrydbg, esp. it's control of eval "use re debug".
+This seems to work part of the time, but isn't stable enough.
=cut
require './test.pl';
}
-plan tests => 38;
+plan tests => 142;
require_ok("B::Concise");
$out = runperl(
switches => ["-MO=Concise,-exec"],
- prog => q{$a//=$b && print q/foo/},
+ prog => q{$a=$b && print q/foo/},
stderr => 1,
);
######## 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));
+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 (undef, 0, "string",[], {}) {
+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;
like ($@, qr/expecting 3 style-format args/,
"set_style rejects bad style-format args");
-
#### for content with doc'd options
-SKIP:
-{ # test output to GLOB, using perlio feature directly
- skip "no perlio on this build", 18
- unless $Config::Config{useperlio};
- set_style_standard('concise'); # MUST CALL b4 output needed
- my $func = sub{ $a = $b+42 };
+my $func = sub{ $a = $b+42 }; # canonical example asub
+SKIP: {
+ # tests output to GLOB, using perlio feature directly
+ skip "no perlio on this build", 122
+ unless $Config::Config{useperlio};
+
+ set_style_standard('concise'); # MUST CALL before output needed
+
@options = qw(
- -basic -exec -tree -compact -loose -vt -ascii -main
+ -basic -exec -tree -compact -loose -vt -ascii
-base10 -bigendian -littleendian
);
foreach $opt (@options) {
#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);
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
- 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
+ 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 ???
sub nosuchfunc;
- eval { B::Concise::compile('-basic', \&nosuchfunc)->() };
+ eval { B::Concise::compile('-basic', \&nosuchfunc)->() };
like ($@, qr/^err: coderef has no START/,
"compile detects CODE-ref w/o actual code");
like ($@, qr/unknown function \(main::non_existent_function\)/,
"'$opt' reports non-existent-function properly");
}
+
+ # 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;
+ my %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
+ my %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" );
+ }
+ }
}
+
+__END__
+
--- /dev/null
+#!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
+
+
--- /dev/null
+#!perl
+
+BEGIN {
+ chdir q(t);
+ @INC = qw(../lib ../ext/B/t);
+ require q(./test.pl);
+}
+use OptreeCheck;
+plan tests => 9;
+
+
+=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
--- /dev/null
+#!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;
+
--- /dev/null
+#!perl
+
+BEGIN {
+ chdir q(t);
+ @INC = qw(../lib ../ext/B/t);
+ require q(./test.pl);
+}
+use OptreeCheck;
+plan tests => 20;
+
+
+=for gentest
+
+# chunk: #!perl
+#examples poached from perldoc -f sort
+
+=cut
+=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[t5] 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/REV
+# 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 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/REV
+# 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[t5] 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/REV,NUM
+# 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 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/REV,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(note => q{},
+ bcopts => q{-exec},
+ todo => 'sort why BARE flag happens',
+ 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(note => q{},
+ 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(note => q{},
+ 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[t5] 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
+
=cut
use Config;
-plan tests => 5 + 19 + 14 * $gOpts{selftest}; # fudged
+plan tests => 5 + 18 + 14 * $gOpts{selftest}; # fudged
SKIP: {
skip "no perlio in this build", 5 + 19 + 14 * $gOpts{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');
todo => "your excuse here ;-)",
bcopts => '-exec',
code => sub {print 1},
+ noanchors => 1, # unanchored match
expect => 'print',
expect_nt => 'print');
checkOptree ( name => '-w errors seen',
prog => 'sort our @a',
+ noanchors => 1, # unanchored match
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',
+ noanchors => 1,
expect => 'strict subs',
expect_nt => 'strict subs');
checkOptree ( name => "sort vK - flag specific search",
prog => 'sort our @a',
+ noanchors => 1,
expect => '<@> sort vK ',
expect_nt => '<@> sort vK ');
checkOptree ( name => "'prog' => 'sort our \@a'",
prog => 'sort our @a',
+ 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');
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
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");
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
# 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
use OptreeCheck; # ALSO DOES @ARGV HANDLING !!!!!!
use Config;
-plan tests => 24;
+plan tests => 23;
SKIP: {
skip "no perlio in this build", 24 unless $Config::Config{useperlio};
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
# 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
# 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");
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
+21 <1> leavesub[1 ref] K/REFC,1
EOT_EOT
-# goto -
# 1 <;> nextstate(main 62 optree_concise.t:161) v
# 2 <$> gvsv(*b) s
# 10 <$> const(IV 42) s
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]
checkOptree ( name => 'cmdline self-strict compile err',
prog => 'use strict; sort @a',
bcopts => [qw/ -basic -concise -exec /],
+ noanchors => 1,
expect => 'compilation errors',
expect_nt => 'compilation errors');
checkOptree ( name => 'error at -e line 1',
prog => 'our @a; sort @a',
bcopts => [qw/ -basic -concise -exec /],
+ noanchors => 1,
expect => 'at -e line 1',
expect_nt => 'at -e line 1');
. "(x(;~=> #extra)x)\n" # new 'variable' used here
, " (*( )*) goto #seq\n"
- , "(?(<#speq>)?)#exname#arg(?([#targarglife])?)"
+ , "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"
#. "(x(;~=> #extra)x)\n" # new 'variable' used here
);
$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';
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
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
+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
+# 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",
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
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
} #skip
-__END__
-
}
use OptreeCheck;
use Config;
-plan tests => 13;
+plan tests => 20;
SKIP: {
- skip "no perlio in this build", 13 unless $Config::Config{useperlio};
+ skip "no perlio in this build", 20 unless $Config::Config{useperlio};
pass("GENERAL OPTREE EXAMPLES");
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
# 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
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
# 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
# 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
# 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)[t7] 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 <;> nextstate(main 424 optree_sort.t:14) v
# 2 <0> pushmark s
-# 3 <#> gv(*a) s
-# 4 <1> rv2av[t1] lK/1
+# 3 <#> gv[*a] s
+# 4 <1> rv2av[t2] lK/1
# 5 <@> sort K
# 6 <1> leavesub[1 ref] K/REFC,1
EOT_EOT
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
+5 <1> rv2av[t4] lK/1
6 <@> sort lK
7 <0> pushmark s
8 <#> gv[*a] s
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
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
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
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
--- /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 !!!!!!
+use Config;
+
+plan tests => 6;
+
+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) = "'foo'";
+ BEGIN { $beg++ }
+ CHECK { $chk++ }
+ INIT { $init++ }
+ END { $end++ }
+};
+
+
+
+checkOptree ( name => 'BEGIN',
+ bcopts => 'BEGIN',
+ prog => $src,
+ 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 -242 Concise.pm:304) v/2 ->2
+# 3 <1> require sK/1 ->4
+# 2 <$> const[PV "strict.pm"] s/BARE ->3
+# 4 <;> nextstate(B::Concise -242 Concise.pm:304) v/2 ->5
+# - <@> lineseq K ->-
+# 5 <;> nextstate(B::Concise -242 Concise.pm:304) /2 ->6
+# a <1> entersub[t1] KS*/TARG,2 ->b
+# 6 <0> pushmark s ->7
+# 7 <$> const[PV "strict"] sM ->8
+# 8 <$> const[PV "refs"] sM ->9
+# 9 <$> method_named[PVIV 1520340202] ->a
+# BEGIN 2:
+# m <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->m
+# c <;> nextstate(B::Concise -227 Concise.pm:327) v/2 ->d
+# e <1> require sK/1 ->f
+# d <$> const[PV "warnings.pm"] s/BARE ->e
+# f <;> nextstate(B::Concise -227 Concise.pm:327) v/2 ->g
+# - <@> lineseq K ->-
+# g <;> nextstate(B::Concise -227 Concise.pm:327) /2 ->h
+# l <1> entersub[t1] KS*/TARG,2 ->m
+# h <0> pushmark s ->i
+# i <$> const[PV "warnings"] sM ->j
+# j <$> const[PV "qw"] sM ->k
+# k <$> method_named[PVIV 1520340202] ->l
+# BEGIN 3:
+# q <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->q
+# n <;> nextstate(main 2 -e:3) v ->o
+# p <1> postinc[t3] sK/1 ->q
+# - <1> ex-rv2sv sKRM/1 ->p
+# o <#> gvsv[*beg] s ->p
+EOT_EOT
+# BEGIN 1:
+# b <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->b
+# 1 <;> nextstate(B::Concise -242 Concise.pm:304) v/2 ->2
+# 3 <1> require sK/1 ->4
+# 2 <$> const(PV "strict.pm") s/BARE ->3
+# 4 <;> nextstate(B::Concise -242 Concise.pm:304) v/2 ->5
+# - <@> lineseq K ->-
+# 5 <;> nextstate(B::Concise -242 Concise.pm:304) /2 ->6
+# a <1> entersub[t1] KS*/TARG,2 ->b
+# 6 <0> pushmark s ->7
+# 7 <$> const(PV "strict") sM ->8
+# 8 <$> const(PV "refs") sM ->9
+# 9 <$> method_named(PVIV 1520340202) ->a
+# BEGIN 2:
+# m <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->m
+# c <;> nextstate(B::Concise -227 Concise.pm:327) v/2 ->d
+# e <1> require sK/1 ->f
+# d <$> const(PV "warnings.pm") s/BARE ->e
+# f <;> nextstate(B::Concise -227 Concise.pm:327) v/2 ->g
+# - <@> lineseq K ->-
+# g <;> nextstate(B::Concise -227 Concise.pm:327) /2 ->h
+# l <1> entersub[t1] KS*/TARG,2 ->m
+# h <0> pushmark s ->i
+# i <$> const(PV "warnings") sM ->j
+# j <$> const(PV "qw") sM ->k
+# k <$> method_named(PVIV 1520340202) ->l
+# BEGIN 3:
+# q <1> leavesub[1 ref] K/REFC,1 ->(end)
+# - <@> lineseq KP ->q
+# n <;> nextstate(main 2 -e:3) v ->o
+# p <1> postinc[t2] sK/1 ->q
+# - <1> ex-rv2sv sKRM/1 ->p
+# o <$> gvsv(*beg) s ->p
+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 /],
+ #todo => 'get working',
+ prog => $src,
+ expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+# BEGIN 1:
+# 1 <;> nextstate(B::Concise -242 Concise.pm:304) v/2
+# 2 <$> const[PV "strict.pm"] s/BARE
+# 3 <1> require sK/1
+# 4 <;> nextstate(B::Concise -242 Concise.pm:304) v/2
+# 5 <;> nextstate(B::Concise -242 Concise.pm:304) /2
+# 6 <0> pushmark s
+# 7 <$> const[PV "strict"] sM
+# 8 <$> const[PV "refs"] 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(B::Concise -227 Concise.pm:327) v/2
+# d <$> const[PV "warnings.pm"] s/BARE
+# e <1> require sK/1
+# f <;> nextstate(B::Concise -227 Concise.pm:327) v/2
+# g <;> nextstate(B::Concise -227 Concise.pm:327) /2
+# h <0> pushmark s
+# i <$> const[PV "warnings"] sM
+# j <$> const[PV "qw"] sM
+# k <$> method_named[PVIV 1520340202]
+# l <1> entersub[t1] KS*/TARG,2
+# m <1> leavesub[1 ref] K/REFC,1
+# BEGIN 3:
+# n <;> nextstate(main 2 -e:3) v
+# o <#> gvsv[*beg] s
+# p <1> postinc[t3] sK/1
+# q <1> leavesub[1 ref] K/REFC,1
+# END 1:
+# r <;> nextstate(main 5 -e:6) v
+# s <#> gvsv[*end] s
+# t <1> postinc[t3] sK/1
+# u <1> leavesub[1 ref] K/REFC,1
+# INIT 1:
+# v <;> nextstate(main 4 -e:5) v
+# w <#> gvsv[*init] s
+# x <1> postinc[t3] sK/1
+# y <1> leavesub[1 ref] K/REFC,1
+# CHECK 1:
+# z <;> nextstate(main 3 -e:4) v
+# 10 <#> gvsv[*chk] s
+# 11 <1> postinc[t3] sK/1
+# 12 <1> leavesub[1 ref] K/REFC,1
+EOT_EOT
+# BEGIN 1:
+# 1 <;> nextstate(B::Concise -242 Concise.pm:304) v/2
+# 2 <$> const(PV "strict.pm") s/BARE
+# 3 <1> require sK/1
+# 4 <;> nextstate(B::Concise -242 Concise.pm:304) v/2
+# 5 <;> nextstate(B::Concise -242 Concise.pm:304) /2
+# 6 <0> pushmark s
+# 7 <$> const(PV "strict") sM
+# 8 <$> const(PV "refs") 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(B::Concise -227 Concise.pm:327) v/2
+# d <$> const(PV "warnings.pm") s/BARE
+# e <1> require sK/1
+# f <;> nextstate(B::Concise -227 Concise.pm:327) v/2
+# g <;> nextstate(B::Concise -227 Concise.pm:327) /2
+# h <0> pushmark s
+# i <$> const(PV "warnings") sM
+# j <$> const(PV "qw") sM
+# k <$> method_named(PVIV 1520340202)
+# l <1> entersub[t1] KS*/TARG,2
+# m <1> leavesub[1 ref] K/REFC,1
+# BEGIN 3:
+# n <;> nextstate(main 2 -e:3) v
+# o <$> gvsv(*beg) s
+# p <1> postinc[t2] sK/1
+# q <1> leavesub[1 ref] K/REFC,1
+# END 1:
+# r <;> nextstate(main 5 -e:6) v
+# s <$> gvsv(*end) s
+# t <1> postinc[t2] sK/1
+# u <1> leavesub[1 ref] K/REFC,1
+# INIT 1:
+# v <;> nextstate(main 4 -e:5) v
+# w <$> gvsv(*init) s
+# x <1> postinc[t2] sK/1
+# y <1> leavesub[1 ref] K/REFC,1
+# CHECK 1:
+# z <;> nextstate(main 3 -e:4) v
+# 10 <$> gvsv(*chk) s
+# 11 <1> postinc[t2] sK/1
+# 12 <1> leavesub[1 ref] K/REFC,1
+EONT_EONT
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
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
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
checkOptree ( name => 'sub {my $a=()}',
code => sub {my $a=()},
- todo => 'optimize',
+ todo => 'apparently done, by patch #?',
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
#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
checkOptree ( name => 'my $a=()',
prog => 'my $a=()',
- todo => 'optimize ? its one of the idioms',
+ todo => 'apparently done, by patch #?',
bcopts => '-exec',
expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
1 <0> enter
} else {
@INC = '../lib';
}
+ require './test.pl';
}
-$| = 1;
+$| = 1;
use warnings;
use strict;
use Config;
+use B::Showlex ();
-print "1..1\n";
+plan tests => 8;
-my $test = 1;
-
-sub ok { print "ok $test\n"; $test++ }
+my $verbose = @ARGV; # set if ANY ARGS
my $a;
my $Is_VMS = $^O eq 'VMS';
my $is_thread = $Config{use5005threads} && $Config{use5005threads} eq 'define';
if ($is_thread) {
- print "# use5005threads: test $test skipped\n";
+ ok "# use5005threads: test skipped\n";
} else {
$a = `$^X $path "-MO=Showlex" -e "my \@one" $redir`;
- print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*\@one.*sv_undef.*AV/s;
+ like ($a, qr/sv_undef.*PVNV.*\@one.*sv_undef.*AV/s,
+ "canonical usage works");
}
-ok;
+
+# v1.01 tests
+
+my ($na,$nb,$nc); # holds regex-strs
+sub padrep {
+ my $varname = shift;
+ return "PVNV \\\(0x[0-9a-fA-F]+\\\) \\$varname\n";
+}
+
+my $out = runperl ( switches => ["-MO=Showlex"],
+ prog => 'my ($a,$b)', stderr => 1 );
+$na = padrep('$a');
+$nb = padrep('$b');
+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;
+
+our $buf = 'arb startval';
+my $ak = B::Showlex::walk_output (\$buf);
+
+my $walker = B::Showlex::compile(sub { my ($foo,$bar) });
+$walker->();
+$na = padrep('$foo');
+$nb = padrep('$bar');
+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);
+
+$walker = B::Showlex::compile(sub { my ($scalar,@arr,%hash) });
+$walker->();
+$na = padrep('$scalar');
+$nb = padrep('@arr');
+$nc = padrep('%hash');
+like ($buf, qr/1: $na/ms, 'found $scalar in "sub { my ($scalar,@arr,%hash) }"');
+like ($buf, qr/2: $nb/ms, 'found @arr in "sub { my ($scalar,@arr,%hash) }"');
+like ($buf, qr/3: $nc/ms, 'found %hash in "sub { my ($scalar,@arr,%hash) }"');
+
+print $buf if $verbose;
+
+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');
+$walker->();
+
+$walker = B::Concise::compile($asub, '-exec');
+$walker->();
+
+
+print $buf if $verbose;
projects / p5sagit/p5-mst-13.2.git / commitdiff