From: Jim Cromie Date: Mon, 10 May 2004 05:28:11 +0000 (-0600) Subject: Re: more B::Concise stuff (PATCH - updated) X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=cc02ea560c8a37fafefc4084ece79bdf6aceb9b8;p=p5sagit%2Fp5-mst-13.2.git Re: more B::Concise stuff (PATCH - updated) Message-ID: <409F674B.2000506@divsol.com> p4raw-id: //depot/perl@22820 --- diff --git a/MANIFEST b/MANIFEST index 19ab326..e05d945 100644 --- a/MANIFEST +++ b/MANIFEST @@ -122,7 +122,12 @@ ext/B/t/optree_check.t test OptreeCheck apparatus 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 diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm index 3e532e9..eb9398a 100644 --- a/ext/B/B/Concise.pm +++ b/ext/B/B/Concise.pm @@ -14,11 +14,16 @@ use warnings; # uses #3 and #4, since warnings uses Carp 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 @@ -33,8 +38,8 @@ my %style = "#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)", @@ -67,8 +72,9 @@ my $base = 36; # how is displayed my $big_endian = 1; # more 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"); @@ -102,10 +108,13 @@ sub add_callback { } # 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" @@ -113,21 +122,37 @@ sub walk_output { # updates $walkHandle # 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(@_); } @@ -188,18 +213,22 @@ my @tree_decorations = [" ", 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; @@ -207,17 +236,26 @@ sub compile { $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); @@ -225,48 +263,57 @@ sub compile { 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 } } @@ -328,6 +375,7 @@ sub reset_sequence { # reset the sequence %sequence_num = (); $seq_max = 1; + $lastnext = 0; } sub seq { @@ -430,19 +478,34 @@ sub sequence { } 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 @@ -556,7 +619,10 @@ sub concise_sv { } 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}" ; } } @@ -689,17 +755,18 @@ sub concise_op { $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); @@ -724,10 +791,12 @@ sub b_terse { # 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 { @@ -1005,19 +1074,42 @@ obviously mutually exclusive with bigendian. =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 @@ -1028,6 +1120,46 @@ the options are 'sticky'. This means that the options you provide in the first call will be remembered for the 2nd call, unless you re-specify or change them. +=head1 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 @@ -1039,10 +1171,18 @@ mode when branches are encountered. They're not real opcodes, and are inserted to look like a closing curly brace. The tree-format is tree specific. -When a line is rendered, the correct format string is scanned for the -following items, and data is substituted in, or other manipulations, -like basic indenting. Any text that doesn't match a special pattern -(the items below) is copied verbatim. (Yes, it's a set of s///g steps.) +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 @@ -1065,33 +1205,64 @@ If the value of I is true (not empty or zero), generates the value of I surrounded by I and I, 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 -Generates the value of the variable I. +A property named 'var' is assumed to exist for the opcodes, and is +interpolated into the rendering. =item B<#>II -Generates the value of I, left jutified to fill I spaces. +Generates the value of I, left justified to fill I 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 -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 below) that uses them. You can +also add new ones using L. =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> @@ -1217,59 +1388,31 @@ The numeric value of the OP's type, in decimal. =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, 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 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. +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() @@ -1320,28 +1463,37 @@ changed or even used. B accepts options as described above in L, 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 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 or -C, call C, 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, altering style or mode/order + 2. call C + 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() diff --git a/ext/B/B/Showlex.pm b/ext/B/B/Showlex.pm index 0140c8a..31708e0 100644 --- a/ext/B/B/Showlex.pm +++ b/ext/B/B/Showlex.pm @@ -1,10 +1,11 @@ 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 @@ -13,21 +14,32 @@ use B::Terse (); # 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); } } } @@ -37,10 +49,10 @@ sub showvaluearray { 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]); } } @@ -50,10 +62,25 @@ sub showlex { 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 { @@ -61,17 +88,29 @@ 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; } } diff --git a/ext/B/B/Terse.pm b/ext/B/B/Terse.pm index 401dfc2..8d295cd 100644 --- a/ext/B/B/Terse.pm +++ b/ext/B/B/Terse.pm @@ -16,7 +16,6 @@ sub terse { } else { concise_subref('basic', $subref); } - } sub compile { @@ -28,7 +27,7 @@ sub compile { } sub indent { - my $level = @_ ? shift : 0; + my ($level) = @_ ? shift : 0; return " " x $level; } @@ -43,20 +42,27 @@ sub B::SV::terse { 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; diff --git a/ext/B/t/OptreeCheck.pm b/ext/B/t/OptreeCheck.pm index 43ba1e8..47367d3 100644 --- a/ext/B/t/OptreeCheck.pm +++ b/ext/B/t/OptreeCheck.pm @@ -1,5 +1,6 @@ -# 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 @@ -9,11 +10,11 @@ OptreeCheck - check optrees =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 @@ -32,56 +33,57 @@ bytecode generator, via a single function: checkOptree(%args). =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 @@ -139,7 +141,7 @@ haven't 'enshrined' a bug). name: The test name. May be augmented by a label, which is built from important params, and which helps keep names in sync with whats being -tested. +tested.' =cut @@ -176,6 +178,7 @@ our %gOpts = # values are replaced at runtime !! 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 @@ -199,7 +202,7 @@ our %modes = ( cross => [ !($threaded) ? 'expect' : 'expect_nt'], expect => [ 'expect' ], expect_nt => [ 'expect_nt' ], - ); + ); our %msgs # announce cross-testing. = ( @@ -269,6 +272,7 @@ sub checkOptree { print "checkOptree args: ",Dumper \%in if $in{dump}; SKIP: { + label(\%in); skip($in{name}, 1) if $in{skip}; return runSelftest(\%in) if $gOpts{selftest}; @@ -276,24 +280,27 @@ sub checkOptree { 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); } @@ -307,8 +314,15 @@ sub checkOptree { 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 { @@ -316,9 +330,7 @@ sub testCombo { my $in = @_; my @cases; foreach $want (@{$modes{$gOpts{testmode}}}) { - - push @cases, [ %in, - ]; + push @cases, [ %in ] } return @cases; } @@ -342,7 +354,8 @@ sub runSelftest { # 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; @@ -354,18 +367,30 @@ sub runSelftest { 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)); @@ -439,78 +464,181 @@ sub mkCheckRex { $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 < $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 => < < $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'}; + $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__ @@ -520,11 +648,11 @@ __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 @@ -533,57 +661,44 @@ purposes. This loses some info in 'add[t5]', but greatly simplifys matching 'nextstate(main 22 (eval 10):1)'. Besides, we are testing for regressions, not for complete accuracy. -The regex is unanchored, allowing success on simple expectations, such -as one with a single 'print' opcode. - -=head2 complicating factors - -Note that %in may seem overly complicated, but it's needed to allow -mkCheckRex to better support selftest, - -The emerging complexity is that mkCheckRex must choose which refdata -to use as a template for the regex being constructed. This feels like -selection mechanics being duplicated. +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 diff --git a/ext/B/t/concise.t b/ext/B/t/concise.t index ec4795b..ac502ff 100644 --- a/ext/B/t/concise.t +++ b/ext/B/t/concise.t @@ -6,7 +6,7 @@ BEGIN { require './test.pl'; } -plan tests => 38; +plan tests => 142; require_ok("B::Concise"); @@ -30,7 +30,7 @@ is($cop_base, 1, "Smallest COP sequence number"); $out = runperl( switches => ["-MO=Concise,-exec"], - prog => q{$a//=$b && print q/foo/}, + prog => q{$a=$b && print q/foo/}, stderr => 1, ); @@ -39,17 +39,22 @@ like($out, qr/print/, "'-exec' option output has print opcode"); ######## API tests v.60 use Config; # used for perlio check -B::Concise->import(qw(set_style set_style_standard add_callback - add_style walk_output)); +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; @@ -107,18 +112,19 @@ eval { set_style (@stylespec) }; 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) { @@ -128,11 +134,11 @@ SKIP: #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); @@ -140,30 +146,34 @@ SKIP: 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"); @@ -172,4 +182,135 @@ SKIP: 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__ + diff --git a/ext/B/t/f_map b/ext/B/t/f_map new file mode 100644 index 0000000..a0e1a08 --- /dev/null +++ b/ext/B/t/f_map @@ -0,0 +1,29 @@ +#!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 + + diff --git a/ext/B/t/f_map.t b/ext/B/t/f_map.t new file mode 100644 index 0000000..df7d91c --- /dev/null +++ b/ext/B/t/f_map.t @@ -0,0 +1,517 @@ +#!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 diff --git a/ext/B/t/f_sort b/ext/B/t/f_sort new file mode 100644 index 0000000..759523b --- /dev/null +++ b/ext/B/t/f_sort @@ -0,0 +1,91 @@ +#!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; + diff --git a/ext/B/t/f_sort.t b/ext/B/t/f_sort.t new file mode 100644 index 0000000..5a0c55b --- /dev/null +++ b/ext/B/t/f_sort.t @@ -0,0 +1,941 @@ +#!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 + diff --git a/ext/B/t/optree_check.t b/ext/B/t/optree_check.t index 6dd9bdd..9968c57 100644 --- a/ext/B/t/optree_check.t +++ b/ext/B/t/optree_check.t @@ -20,7 +20,7 @@ cmdline args in 'standard' way across all clients of OptreeCheck. =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} @@ -32,12 +32,14 @@ pass("REGEX TEST HARNESS SELFTEST"); checkOptree ( name => "bare minimum opcode search", bcopts => '-exec', code => sub {my $a}, + noanchors => 1, # unanchored match expect => 'leavesub', expect_nt => 'leavesub'); checkOptree ( name => "found print opcode", bcopts => '-exec', code => sub {print 1}, + noanchors => 1, # unanchored match expect => 'print', expect_nt => 'leavesub'); @@ -52,6 +54,7 @@ checkOptree ( name => 'test todo itself', todo => "your excuse here ;-)", bcopts => '-exec', code => sub {print 1}, + noanchors => 1, # unanchored match expect => 'print', expect_nt => 'print'); @@ -103,26 +106,31 @@ pass ("TEST -e \$srcCode"); 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'); @@ -132,12 +140,10 @@ checkOptree ( name => 'fixup nextstate (in reftext)', bcopts => '-exec', code => sub {my $a}, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); -# goto - # 1 <;> nextstate( NOTE THAT THIS CAN BE ANYTHING ) v # 2 <0> padsv[$a:54,55] M/LVINTRO # 3 <1> leavesub[1 ref] K/REFC,1 EOT_EOT -# goto - # 1 <;> nextstate(main 54 optree_concise.t:84) v # 2 <0> padsv[$a:54,55] M/LVINTRO # 3 <1> leavesub[1 ref] K/REFC,1 @@ -149,31 +155,15 @@ checkOptree ( name => 'fixup square-bracket args', 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"); @@ -214,7 +204,6 @@ checkOptree ( name => 'canonical example w -exec', 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 @@ -223,7 +212,6 @@ checkOptree ( name => 'canonical example w -exec', # 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 diff --git a/ext/B/t/optree_concise.t b/ext/B/t/optree_concise.t index 2fa4469..dd6593b 100644 --- a/ext/B/t/optree_concise.t +++ b/ext/B/t/optree_concise.t @@ -10,7 +10,7 @@ BEGIN { 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}; @@ -52,7 +52,6 @@ checkOptree ( name => 'canonical example w -exec', bcopts => '-exec', code => sub{$a=$b+42}, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); -# goto - # 1 <;> nextstate(main 61 optree_concise.t:139) v # 2 <#> gvsv[*b] s # 3 <$> const[IV 42] s @@ -61,7 +60,6 @@ checkOptree ( name => 'canonical example w -exec', # 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 @@ -71,10 +69,6 @@ EOT_EOT # 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"); @@ -82,16 +76,14 @@ checkOptree ( name => '-base3 sticky-exec', bcopts => '-base3', code => sub{$a=$b+42}, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); - goto - 1 <;> dbstate(main 24 optree_concise.t:132) v 2 <#> gvsv[*b] s 10 <$> const[IV 42] s 11 <2> add[t3] sK/2 12 <#> gvsv[*a] s 20 <2> sassign sKS/2 -21 <1> leavesub[2 refs] K/REFC,1 +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 @@ -194,12 +186,10 @@ checkOptree ( name => "sticky-terse exec", bcopts => [qw/ -exec /], code => sub{$a}, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); - goto UNOP (0x82b0918) COP (0x82b0d70) nextstate PADOP (0x82b0d30) gvsv GV (0x82a818c) *a UNOP (0x82b0e08) leavesub [1] EOT_EOT -# goto UNOP (0x8282310) # COP (0x82828e0) nextstate # SVOP (0x82828a0) gvsv GV (0x814692c) *a # UNOP (0x8282938) leavesub [1] @@ -252,12 +242,14 @@ EONT_EONT 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'); @@ -301,7 +293,7 @@ use B::Concise qw( walk_output add_style set_style_standard add_callback ); . "(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 ); @@ -319,6 +311,11 @@ sub set_up_relative_test { $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'; @@ -339,7 +336,6 @@ checkOptree ( name => 'callback used, independent of style', bcopts => [qw/ -concise -exec /], code => sub{$a=$b+42}, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); - goto - 1 <;> nextstate(main 76 optree_concise.t:337) v 2 <#> gvsv[*b] s 3 <$> const[IV 42] CALLBACK s @@ -363,27 +359,27 @@ checkOptree ( name => "new 'relative' style, -exec mode", 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", @@ -391,7 +387,6 @@ 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 @@ -424,11 +419,9 @@ checkOptree ( name => "both -exec -scope", bcopts => [qw/ -exec -scope /], code => sub{$a=$b+42}, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); - goto - 1 <;> nextstate(main 50 optree_concise.t:337) v 7 <1> leavesub[1 ref] K/REFC,1 EOT_EOT - goto - 1 <;> nextstate(main 75 optree_concise.t:396) v 7 <1> leavesub[1 ref] K/REFC,1 EONT_EONT @@ -447,5 +440,3 @@ EONT_EONT } #skip -__END__ - diff --git a/ext/B/t/optree_samples.t b/ext/B/t/optree_samples.t index c42ffa0..90d57bd 100644 --- a/ext/B/t/optree_samples.t +++ b/ext/B/t/optree_samples.t @@ -7,9 +7,9 @@ BEGIN { } 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"); @@ -21,7 +21,6 @@ checkOptree ( name => '-basic sub {if shift print then,else}', 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 @@ -94,9 +93,6 @@ checkOptree ( name => '-basic (see above, with my $a = shift)', # 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 @@ -128,7 +124,6 @@ checkOptree ( name => '-exec sub {if shift print then,else}', 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 @@ -267,7 +262,6 @@ checkOptree ( name => '-exec sub { foreach (1..10) {print "foo $_"} }', # 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 @@ -389,15 +383,12 @@ EOT_EOT # 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 @@ -437,6 +428,197 @@ EOT_EOT # 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', diff --git a/ext/B/t/optree_sort.t b/ext/B/t/optree_sort.t index 5462960..1126821 100644 --- a/ext/B/t/optree_sort.t +++ b/ext/B/t/optree_sort.t @@ -20,8 +20,8 @@ checkOptree ( name => 'sub {sort @a}', 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 @@ -58,12 +58,11 @@ checkOptree ( name => 'sub {@a = sort @a}', code => sub {@a = sort @a}, bcopts => '-exec', expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); - goto - 1 <;> nextstate(main -438 optree.t:244) v 2 <0> pushmark s 3 <0> pushmark s 4 <#> gv[*a] s -5 <1> rv2av[t2] lK/1 +5 <1> rv2av[t4] lK/1 6 <@> sort lK 7 <0> pushmark s 8 <#> gv[*a] s @@ -111,7 +110,6 @@ checkOptree ( name => 'sub {@a = sort @a; reverse @a}', code => sub {@a = sort @a; reverse @a}, bcopts => '-exec', expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); - goto - 1 <;> nextstate(main -438 optree.t:286) v 2 <0> pushmark s 3 <0> pushmark s @@ -176,7 +174,6 @@ checkOptree ( name => 'sub {my @a; @a = sort @a}', code => sub {my @a; @a = sort @a}, bcopts => '-exec', expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); - goto - 1 <;> nextstate(main -437 optree.t:254) v 2 <0> padav[@a:-437,-436] vM/LVINTRO 3 <;> nextstate(main -436 optree.t:256) v @@ -232,7 +229,6 @@ checkOptree ( name => 'sub {my @a; @a = sort @a; push @a, 1}', bcopts => '-exec', debug => 0, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); - goto - 1 <;> nextstate(main -437 optree.t:325) v 2 <0> padav[@a:-437,-436] vM/LVINTRO 3 <;> nextstate(main -436 optree.t:325) v @@ -267,7 +263,6 @@ checkOptree ( name => 'sub {my @a; @a = sort @a; 1}', bcopts => '-exec', debug => 0, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); - goto - 1 <;> nextstate(main -437 optree.t:325) v 2 <0> padav[@a:-437,-436] vM/LVINTRO 3 <;> nextstate(main -436 optree.t:325) v diff --git a/ext/B/t/optree_specials.t b/ext/B/t/optree_specials.t new file mode 100644 index 0000000..bceda7c --- /dev/null +++ b/ext/B/t/optree_specials.t @@ -0,0 +1,273 @@ +#!./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 diff --git a/ext/B/t/optree_varinit.t b/ext/B/t/optree_varinit.t index 25129793..dd1ef92 100644 --- a/ext/B/t/optree_varinit.t +++ b/ext/B/t/optree_varinit.t @@ -30,12 +30,10 @@ checkOptree ( name => '-exec sub {my $a}', bcopts => '-exec', code => sub {my $a}, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); -# goto - # 1 <;> nextstate(main 49 optree.t:52) v # 2 <0> padsv[$a:49,50] M/LVINTRO # 3 <1> leavesub[1 ref] K/REFC,1 EOT_EOT -# goto - # 1 <;> nextstate(main 49 optree.t:45) v # 2 <0> padsv[$a:49,50] M/LVINTRO # 3 <1> leavesub[1 ref] K/REFC,1 @@ -45,12 +43,10 @@ checkOptree ( name => 'sub {our $a}', bcopts => '-exec', code => sub {our $a}, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); - goto - 1 <;> nextstate(main 21 optree.t:47) v 2 <#> gvsv[*a] s/OURINTR 3 <1> leavesub[1 ref] K/REFC,1 EOT_EOT -# goto - # 1 <;> nextstate(main 51 optree.t:56) v # 2 <$> gvsv(*a) s/OURINTR # 3 <1> leavesub[1 ref] K/REFC,1 @@ -60,12 +56,10 @@ checkOptree ( name => 'sub {local $a}', bcopts => '-exec', code => sub {local $a}, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); - goto - 1 <;> nextstate(main 23 optree.t:57) v 2 <#> gvsv[*a] s/LVINTRO 3 <1> leavesub[1 ref] K/REFC,1 EOT_EOT -# goto - # 1 <;> nextstate(main 53 optree.t:67) v # 2 <$> gvsv(*a) s/LVINTRO # 3 <1> leavesub[1 ref] K/REFC,1 @@ -242,10 +236,9 @@ EONT_EONT 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 @@ -282,14 +275,12 @@ checkOptree ( name => 'sub {local $a=()}', #todo => 'probly not worth doing', bcopts => '-exec', expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); - goto - 1 <;> nextstate(main 33 optree.t:190) v 2 <0> stub sP 3 <#> gvsv[*a] s/LVINTRO 4 <2> sassign sKS/2 5 <1> leavesub[1 ref] K/REFC,1 EOT_EOT -# goto - # 1 <;> nextstate(main 63 optree.t:225) v # 2 <0> stub sP # 3 <$> gvsv(*a) s/LVINTRO @@ -299,7 +290,7 @@ EONT_EONT 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 diff --git a/ext/B/t/showlex.t b/ext/B/t/showlex.t index afff12e..9e3240f 100755 --- a/ext/B/t/showlex.t +++ b/ext/B/t/showlex.t @@ -7,18 +7,18 @@ BEGIN { } 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'; @@ -30,9 +30,73 @@ my $redir = $Is_MacOS ? "" : "2>&1"; 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;