optreecheck.pm

source of perl for linux application,

package OptreeCheck;
use base 'Exporter';
use strict;
use warnings;
use vars qw($TODO $Level $using_open);
require "test.pl";

our $VERSION = '0.02';

# now export checkOptree, and those test.pl functions used by tests
our @EXPORT = qw( checkOptree plan skip skip_all pass is like unlike
		  require_ok runperl);


# The hints flags will differ if ${^OPEN} is set.
# The approach taken is to put the hints-with-open in the golden results, and
# flag that they need to be taken out if ${^OPEN} is set.

if (((caller 0)[10]||{})->{'open<'}) {
    $using_open = 1;
}

=head1 NAME

OptreeCheck - check optrees as rendered by B::Concise

=head1 SYNOPSIS

OptreeCheck supports 'golden-sample' regression testing of perl's
parser, optimizer, bytecode generator, via a single function:
checkOptree(%in).

It invokes B::Concise upon the sample code, checks that the rendering
'agrees' with the golden sample, and reports mismatches.

Additionally, the module processes @ARGV (which is typically unused in
the Core test harness), and thus provides a means to run the tests in
various modes.

=head1 EXAMPLE

  # your test file
  use OptreeCheck;
  plan tests => 1;

  checkOptree (
    name   => "test-name',	# optional, made from others if not given

    # code-under-test: must provide 1 of them
    code   => sub {my $a},	# coderef, or source (wrapped and evald)
    prog   => 'sort @a',	# run in subprocess, aka -MO=Concise
    bcopts => '-exec',		# $opt or \@opts, passed to BC::compile

    errs   => 'Useless variable "@main::a" .*'	# str, regex, [str+] [regex+],

    # various test options
    # errs   => '.*',		# match against any emitted errs, -w warnings
    # skip => 1,		# skips test
    # todo => 'excuse',		# anticipated failures
    # fail => 1			# force fail (by redirecting result)
    # retry => 1		# retry on test failure
    # debug => 1,		# use re 'debug' for retried failures !!

    # the 'golden-sample's, (must provide both)

    expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT' );  # start HERE-DOCS
 # 1  <;> nextstate(main 45 optree.t:23) v
 # 2  <0> padsv[$a:45,46] M/LVINTRO
 # 3  <1> leavesub[1 ref] K/REFC,1
 EOT_EOT
 # 1  <;> nextstate(main 45 optree.t:23) v
 # 2  <0> padsv[$a:45,46] M/LVINTRO
 # 3  <1> leavesub[1 ref] K/REFC,1
 EONT_EONT

 __END__

=head2 Failure Reports

 Heres a sample failure, as induced by the following command.
 Note the argument; option=value, after the test-file, more on that later

 $> PERL_CORE=1 ./perl ext/B/t/optree_check.t  testmode=cross
 ...
 ok 19 - canonical example w -basic
 not ok 20 - -exec code: $a=$b+42
 # Failed at test.pl line 249
 #      got '1  <;> nextstate(main 600 optree_check.t:208) v
 # 2  <#> gvsv[*b] s
 # 3  <$> const[IV 42] s
 # 4  <2> add[t3] sK/2
 # 5  <#> gvsv[*a] s
 # 6  <2> sassign sKS/2
 # 7  <1> leavesub[1 ref] K/REFC,1
 # '
 # expected /(?ms-xi:^1  <;> (?:next|db)state(.*?) v
 # 2  <\$> gvsv\(\*b\) s
 # 3  <\$> const\(IV 42\) s
 # 4  <2> add\[t\d+\] sK/2
 # 5  <\$> gvsv\(\*a\) s
 # 6  <2> sassign sKS/2
 # 7  <1> leavesub\[\d+ refs?\] K/REFC,1
 # $)/
 # got:          '2  <#> gvsv[*b] s'
 # want:  (?-xism:2  <\$> gvsv\(\*b\) s)
 # got:          '3  <$> const[IV 42] s'
 # want:  (?-xism:3  <\$> const\(IV 42\) s)
 # got:          '5  <#> gvsv[*a] s'
 # want:  (?-xism:5  <\$> gvsv\(\*a\) s)
 # remainder:
 # 2  <#> gvsv[*b] s
 # 3  <$> const[IV 42] s
 # 5  <#> gvsv[*a] s
 # these lines not matched:
 # 2  <#> gvsv[*b] s
 # 3  <$> const[IV 42] s
 # 5  <#> gvsv[*a] s

Errors are reported 3 different ways;

The 1st form is directly from test.pl's like() and unlike().  Note
that this form is used as input, so you can easily cut-paste results
into test-files you are developing.  Just make sure you recognize
insane results, to avoid canonizing them as golden samples.

The 2nd and 3rd forms show only the unexpected results and opcodes.
This is done because it's blindingly tedious to find a single opcode
causing the failure.  2 different ways are done in case one is
unhelpful.

=head1 TestCase Overview

checkOptree(%tc) constructs a testcase object from %tc, and then calls
methods which eventually call test.pl's like() to produce test
results.

=head2 getRendering

getRendering() runs code or prog through B::Concise, and captures its
rendering.  Errors emitted during rendering are checked against
expected errors, and are reported as diagnostics by default, or as
failures if 'report=fail' cmdline-option is given.

prog is run in a sub-shell, with $bcopts passed through. This is the way
to run code intended for main.  The code arg in contrast, is always a
CODEREF, either because it starts that way as an arg, or because it's
wrapped and eval'd as $sub = sub {$code};

=head2 mkCheckRex

mkCheckRex() selects the golden-sample for the threaded-ness of the
platform, and produces a regex which matches the expected rendering,
and fails when it doesn't match.

The regex includes 'workarounds' which accommodate expected rendering
variations. These include:

  string constants		# avoid injection
  line numbers, etc		# args of nexstate()
  hexadecimal-numbers

  pad-slot-assignments		# for 5.8 compat, and testmode=cross
  (map|grep)(start|while)	# for 5.8 compat

=head2 mylike

mylike() calls either unlike() or like(), depending on
expectations.  Mismatch reports are massaged, because the actual
difference can easily be lost in the forest of opcodes.

=head1 checkOptree API and Operation

Since the arg is a hash, the api is wide-open, and this really is
about what elements must be or are in the hash, and what they do.  %tc
is passed to newTestCase(), the ctor, which adds in %proto, a global
prototype object.

=head2 name => STRING

If name property is not provided, it is synthesized from these params:
bcopts, note, prog, code.  This is more convenient than trying to do
it manually.

=head2 code or prog

Either code or prog must be present.

=head2 prog => $perl_source_string

prog => $src provides a snippet of code, which is run in a sub-process,
via test.pl:runperl, and through B::Concise like so:

    './perl -w -MO=Concise,$bcopts_massaged -e $src'

=head2 code => $perl_source_string || CODEREF

The $code arg is passed to B::Concise::compile(), and run in-process.
If $code is a string, it's first wrapped and eval'd into a $coderef.
In either case, $coderef is then passed to B::Concise::compile():

    $subref = eval "sub{$code}";
    $render = B::Concise::compile($subref)->();

=head2 expect and expect_nt

expect and expect_nt args are the B<golden-sample> renderings, and are
sampled from known-ok threaded and un-threaded bleadperl (5.9.1) builds.
They're both required, and the correct one is selected for the platform
being tested, and saved into the synthesized property B<wanted>.

=head2 bcopts => $bcopts || [ @bcopts ]

When getRendering() runs, it passes bcopts into B::Concise::compile().
The bcopts arg can be a single string, or an array of strings.

=head2 errs => $err_str_regex || [ @err_str_regexs ] 

getRendering() processes the code or prog arg under warnings, and both
parsing and optree-traversal errors are collected.  These are
validated against the one or more errors you specify.

=head1 testcase modifier properties

These properties are set as %tc parameters to change test behavior.

=head2 skip => 'reason'

invokes skip('reason'), causing test to skip.

=head2 todo => 'reason'

invokes todo('reason')

=head2 fail => 1

For code arguments, this option causes getRendering to redirect the
rendering operation to STDERR, which causes the regex match to fail.

=head2 retry => 1

If retry is set, and a test fails, it is run a second time, possibly
with regex debug.

=head2 debug => 1

If a failure is retried, this turns on eval "use re 'debug'", thus
turning on regex debug.  It's quite verbose, and not hugely helpful.

=head2 noanchors => 1

If set, this relaxes the regex check, which is normally pretty strict.
It's used primarily to validate checkOptree via tests in optree_check.


=head1 Synthesized object properties

These properties are added into the test object during execution.

=head2 wanted

This stores the chosen expect expect_nt string.  The OptreeCheck
object may in the future delete the raw strings once wanted is set,
thus saving space.

=head2 cross => 1

This tag is added if testmode=cross is passed in as argument.
It causes test-harness to purposely use the wrong string.


=head2 checkErrs

checkErrs() is a getRendering helper that verifies that expected errs
against those found when rendering the code on the platform.  It is
run after rendering, and before mkCheckRex.

Errors can be reported 3 different ways; diag, fail, print.

  diag - uses test.pl _diag()
  fail - causes double-testing
  print-.no # in front of the output (may mess up test harnesses)

The 3 ways are selectable at runtimve via cmdline-arg:
report={diag,fail,print}.  



=cut

use Config;
use Carp;
use B::Concise qw(walk_output);

BEGIN {
    $SIG{__WARN__} = sub {
	my $err = shift;
	$err =~ m/Subroutine re::(un)?install redefined/ and return;
    };
}

sub import {
    my $pkg = shift;
    $pkg->export_to_level(1,'checkOptree', @EXPORT);
    getCmdLine();	# process @ARGV
}


# %gOpts params comprise a global test-state.  Initial values here are
# HELP strings, they MUST BE REPLACED by runtime values before use, as
# is done by getCmdLine(), via import

our %gOpts = 	# values are replaced at runtime !!
    (
     # scalar values are help string
     retry	=> 'retry failures after turning on re debug',
     debug	=> 'turn on re debug for those retries',
     selftest	=> 'self-tests mkCheckRex vs the reference rendering',

     fail	=> 'force all test to fail, print to stdout',
     dump	=> 'dump cmdline arg prcessing',
     noanchors	=> 'dont anchor match rex',

     # array values are one-of selections, with 1st value as default
     #  array: 2nd value is used as help-str, 1st val (still) default
     help	=> [0, 'provides help and exits', 0],
     testmode	=> [qw/ native cross both /],

     # reporting mode for rendering errs
     report	=> [qw/ diag fail print /],
     errcont	=> [1, 'if 1, tests match even if report is fail', 0],

     # fixup for VMS, cygwin, which dont have stderr b4 stdout
     rxnoorder	=> [1, 'if 1, dont req match on -e lines, and -banner',0],
     strip	=> [1, 'if 1, catch errs and remove from renderings',0],
     stripv	=> 'if strip&&1, be verbose about it',
     errs	=> 'expected compile errs, array if several',
    );


# Not sure if this is too much cheating. Officially we say that
# $Config::Config{usethreads} is true if some sort of threading is in
# use, in which case we ought to be able to use it in place of the ||
# below.  However, it is now possible to Configure perl with "threads"
# but neither ithreads or 5005threads, which forces the re-entrant
# APIs, but no perl user visible threading.

# This seems to have the side effect that most of perl doesn't think
# that it's threaded, hence the ops aren't threaded either.  Not sure
# if this is actually a "supported" configuration, but given that
# ponie uses it, it's going to be used by something official at least
# in the interim. So it's nice for tests to all pass.

our $threaded = 1
  if $Config::Config{useithreads} || $Config::Config{use5005threads};
our $platform = ($threaded) ? "threaded" : "plain";
our $thrstat = ($threaded)  ? "threaded" : "nonthreaded";

our %modes = (
	      both	=> [ 'expect', 'expect_nt'],
	      native	=> [ ($threaded) ? 'expect' : 'expect_nt'],
	      cross	=> [ !($threaded) ? 'expect' : 'expect_nt'],
	      expect	=> [ 'expect' ],
	      expect_nt	=> [ 'expect_nt' ],
	      );

our %msgs # announce cross-testing.
    = (
       # cross-platform
       'expect_nt-threaded' => " (nT on T) ",
       'expect-nonthreaded' => " (T on nT) ",
       # native - nothing to say (must stay empty - used for $crosstesting)