optreecheck.pm

source of perl for linux application,

    $str =~ s/(0x[0-9A-Fa-f]+)/0x[0-9A-Fa-f]+/msg;	# hexnum values
    $str =~ s/".*?"/".*?"/msg;				# quoted strings
    $str =~ s/FAKE:(\w):\d+/FAKE:$1:\\d+/msg;		# parent pad index

    $str =~ s/(\d refs?)/\\d+ refs?/msg;		# 1 ref, 2+ refs (plural)
    $str =~ s/leavesub \[\d\]/leavesub [\\d]/msg;	# for -terse
    #$str =~ s/(\s*)\n/\n/msg;				# trailing spaces
    
    croak "no reftext found for $want: $tc->{name}"
	unless $str =~ /\w+/; # fail unless a real test
    
    # $str = '.*'	if 1;	# sanity test
    # $str .= 'FAIL'	if 1;	# sanity test

    # allow -eval, banner at beginning of anchored matches
    $str = "(-e .*?)?(B::Concise::compile.*?)?\n" . $str
	unless $tc->{noanchors} or $tc->{rxnoorder};
    
    my $qr = ($tc->{noanchors})	? qr/$str/ms : qr/^$str$/ms ;

    $tc->{rex}		= $qr;
    $tc->{rexstr}	= $str;
    $tc;
}

##############
# compare and report

sub mylike {
    # reworked mylike to use hash-obj
    my $tc	= shift;
    my $got	= $tc->{got};
    my $want	= $tc->{rex};
    my $cmnt	= $tc->{name};
    my $cross	= $tc->{cross};

    my $msgs	= $tc->{msgs};
    my $retry	= $tc->{retry}; # || $gopts{retry};
    my $debug	= $tc->{debug}; #|| $gopts{retrydbg};

    # bad is anticipated failure
    my $bad = (0 or ( $cross && $tc->{crossfail})
	       or (!$cross && $tc->{fail})
	       or 0); # no undefs !

    # same as A ^ B, but B has side effects
    my $ok = ( $bad  &&  unlike ($got, $want, $cmnt, @$msgs)
	       or !$bad && like ($got, $want, $cmnt, @$msgs));

    reduceDiffs ($tc) if not $ok;

    if (not $ok and $retry) {
	# redo, perhaps with use re debug - NOT ROBUST
	eval "use re 'debug'" if $debug;
	$ok = ( $bad  &&  unlike ($got, $want, "(RETRY) $cmnt", @$msgs)
		or !$bad && like ($got, $want, "(RETRY) $cmnt", @$msgs));
	eval "no re 'debug'";
    }
    return $ok;
}

sub reduceDiffs {
    # isolate the real diffs and report them.
    # i.e. these kinds of errs:
    # 1. missing or extra ops.  this skews all following op-sequences
    # 2. single op diff, the rest of the chain is unaltered
    # in either case, std err report is inadequate;

    my $tc	= shift;
    my $got	= $tc->{got};
    my @got	= split(/\n/, $got);
    my $want	= $tc->{wantstr};
    my @want	= split(/\n/, $want);

    # split rexstr into units that should eat leading lines.
    my @rexs = map qr/$_/, split (/\n/, $tc->{rexstr});

    foreach my $rex (@rexs) {
        my $exp = shift @want;
        my $line = shift @got;
        # remove matches, and report
        unless ($got =~ s/($rex\n)//msg) {
            _diag("got:\t\t'$line'\nwant:\t $rex\n");
        }
    }
    _diag("remainder:\n$got");
    _diag("these lines not matched:\n$got\n");
}

=head1 Global modes

Unusually, this module also processes @ARGV for command-line arguments
which set global modes.  These 'options' change the way the tests run,
essentially reusing the tests for different purposes.



Additionally, there's an experimental control-arg interface (i.e.
subject to change) which allows the user to set global modes.


=head1 Testing Method

At 1st, optreeCheck used one reference-text, but the differences
between Threaded and Non-threaded renderings meant that a single
reference (sampled from say, threaded) would be tricky and iterative
to convert for testing on a non-threaded build.  Worse, this conflicts
with making tests both strict and precise.

We now use 2 reference texts, the right one is used based upon the
build's threaded-ness.  This has several benefits:

 1. native reference data allows closer/easier 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 accommodate 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
cross-test manipulations.  This area needs more work.

=head1 Test Modes

One consequence of a single-function API is difficulty controlling
test-mode.  I've chosen for now to use a package hash, %gOpts, to store
test-state.  These properties alter checkOptree() function, either
short-circuiting to selftest, or running a loop that runs the testcase
2^N times, varying conditions each time.  (current N is 2 only).

So Test-mode is controlled with cmdline args, also called options below.
Run with 'help' to see the test-state, and how to change it.

=head2  selftest

This argument invokes runSelftest(), which tests a regex against the
reference renderings that they're made from.  Failure of a regex match
its 'mold' is a strong indicator that mkCheckRex is buggy.

That said, selftest mode currently runs a cross-test too, they're not
completely orthogonal yet.  See below.

=head2 testmode=cross

Cross-testing is purposely creating a T-NT mismatch, looking at the
fallout, which helps to understand the T-NT differences.

The tweaking appears contrary to the 2-refs philosophy, but the tweaks
will be made in conversion-specific code, which (will) handles T->NT
and NT->T separately.  The tweaking is incomplete.

A reasonable 1st step is to add tags to indicate when TonNT or NTonT
is known to fail.  This needs an option to force failure, so the
test.pl reporting mechanics show results to aid the user.

=head2 testmode=native

This is normal mode.  Other valid values are: native, cross, both.

=head2 checkOptree Notes

Accepts test code, renders its optree using B::Concise, and matches
that rendering against a regex built from one of 2 reference
renderings %tc data.

The regex is built by mkCheckRex(\%tc), which scrubs %tc data to
remove match-irrelevancies, such as (args) and [args].  For example,
it strips leading '# ', making it easy to cut-paste new tests into
your test-file, run it, and cut-paste actual results into place.  You
then retest and reedit until all 'errors' are gone.  (now make sure you
haven't 'enshrined' a bug).

name: The test name.  May be augmented by a label, which is built from
important params, and which helps keep names in sync with whats being
tested.

=cut

sub runSelftest {
    # tests the regex produced by mkCheckRex()
    # by using on the expect* text it was created with
    # failures indicate a code bug, 
    # OR regexs plugged into the expect* text (which defeat conversions)
    my $tc = shift;

    for my $provenance (qw/ expect expect_nt /) {
	#next unless $tc->{$provenance};

	$tc->mkCheckRex($provenance);
	$tc->{got} = $tc->{wantstr};	# fake the rendering
	$tc->mylike();
    }
}

my $dumploaded = 0;

sub mydumper {

    do { Dumper(@_); return } if $dumploaded;

    eval "require Data::Dumper"
	or do{
	    print "Sorry, Data::Dumper is not available\n";
	    print "half hearted attempt:\n";
	    foreach my $it (@_) {
		if (ref $it eq 'HASH') {
		    print " $_ => $it->{$_}\n" foreach sort keys %$it;
		}
	    }
	    return;
	};

    Data::Dumper->import;
    $Data::Dumper::Sortkeys = 1;
    $dumploaded++;
    Dumper(@_);
}

############################
# support for test writing

sub preamble {
    my $testct = shift || 1;
    return <<EO_HEADER;
#!perl

BEGIN {
    chdir q(t);
    \@INC = qw(../lib ../ext/B/t);
    require q(./test.pl);
}
use OptreeCheck;
plan tests => $testct;

EO_HEADER

}

sub OptreeCheck::wrap {
    my $code = shift;
    $code =~ s/(?:(\#.*?)\n)//gsm;
    $code =~ s/\s+/ /mgs;	       
    chomp $code;
    return unless $code =~ /\S/;
    my $comment = $1;
    
    my $testcode = qq{
	
checkOptree(note   => q{$comment},
	    bcopts => q{-exec},
	    code   => q{$code},
	    expect => <<EOT_EOT, expect_nt => <<EONT_EONT);
ThreadedRef
    paste your 'golden-example' here, then retest
EOT_EOT
NonThreadedRef
    paste your 'golden-example' here, then retest
EONT_EONT
    
};
    return $testcode;
}

sub OptreeCheck::gentest {
    my ($code,$opts) = @_;
    my $rendering = getRendering({code => $code});
    my $testcode = OptreeCheck::wrap($code);
    return unless $testcode;

    # run the prog, capture 'reference' concise output
    my $preamble = preamble(1);
    my $got = runperl( prog => "$preamble $testcode", stderr => 1,
		       #switches => ["-I../ext/B/t", "-MOptreeCheck"], 
		       );  #verbose => 1);
    
    # extract the 'reftext' ie the got 'block'
    if ($got =~ m/got \'.*?\n(.*)\n\# \'\n\# expected/s) {
	my $goldentxt = $1;
	#and plug it into the test-src
	if ($threaded) {
	    $testcode =~ s/ThreadedRef/$goldentxt/;
	} else {
	    $testcode =~ s/NonThreadRef/$goldentxt/;
	}
	my $b4 = q{expect => <<EOT_EOT, expect_nt => <<EONT_EONT};
	my $af = q{expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'};
	$testcode =~ s/$b4/$af/;
	
	return $testcode;
    }
    return '';
}


sub OptreeCheck::processExamples {
    my @files = @_;

    # gets array of paragraphs, which should be code-samples.  Theyre
    # turned into optreeCheck tests,

    foreach my $file (@files) {
	open (my $fh, $file) or die "cant open $file: $!\n";
	$/ = "";
	my @chunks = <$fh>;
	print preamble (scalar @chunks);
	foreach my $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__

=head1 TEST DEVELOPMENT SUPPORT

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:

 1. write a set of sample code into a single file, one per
    paragraph.  Add <=for gentest> blocks if you care to, or just look at
    f_map and f_sort in ext/B/t/ for examples.

 2. run OptreeCheck as a program on the file

   ./perl -Ilib ext/B/t/OptreeCheck.pm -w ext/B/t/f_map
   ./perl -Ilib ext/B/t/OptreeCheck.pm -w ext/B/t/f_sort

   gentest reads the sample code, runs each to generate a reference
   rendering, folds this rendering into an optreeCheck() statement,
   and prints it to stdout.

 3. run the output file as above, redirect to files, then rerun on
    same build (for sanity check), and on thread-opposite build.  With
    editor in 1 window, and cmd in other, it's fairly easy to cut-paste
    the gots into the expects, easier than running step 2 on both
    builds then trying to sdiff them together.

=head1 CAVEATS

This code is purely for testing core. While checkOptree feels flexible
enough to be stable, the whole selftest framework is subject to change
w/o notice.

=cut