1 # non-package OptreeCheck.pm
2 # pm allows 'use OptreeCheck', which also imports
3 # no package decl means all functions defined into main
4 # otherwise, it's like "require './test.pl'"
8 OptreeCheck - check optrees
12 OptreeCheck supports regression testing of perl's parser, optimizer,
13 bytecode generator, via a single function: checkOptree(%args).'
15 checkOptree(name => "your title here", # optional, (synth from others)
16 bcopts => '-exec', # $opt or \@opts, passed to BC::compile
17 code => sub {my $a}, # coderef, or source (wrapped and evald)
18 # prog => 'sort @a', # run in subprocess, aka -MO=Concise
19 # skip => 1, # skips test
20 # todo => 'excuse', # anticipated failures
21 # fail => 1 # fails (by redirecting result)
22 # debug => 1, # turns on regex debug for match test !!
23 # retry => 1 # retry with debug on test failure
24 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
25 # 1 <;> nextstate(main 45 optree.t:23) v
26 # 2 <0> padsv[$a:45,46] M/LVINTRO
27 # 3 <1> leavesub[1 ref] K/REFC,1
29 # 1 <;> nextstate(main 45 optree.t:23) v
30 # 2 <0> padsv[$a:45,46] M/LVINTRO
31 # 3 <1> leavesub[1 ref] K/REFC,1
34 =head1 checkOptree(%in) Overview
36 Calls getRendering(), which runs code or prog through B::Concise, and
37 captures its rendering.
39 Calls mkCheckRex() to produce a regex which will match the expected
40 rendering, and fail when it doesn't match.
42 Also calls like($rendering,/$regex/,$name), and thereby plugs into the
45 =head1 checkOptree(%Args) API
47 Accepts %Args, with following requirements and actions:
49 expect and expect_nt are both: required, not empty, not whitespace.
50 It's a fatal error otherwise, because false positives are BAD.
52 Either code or prog must be present. prog is some source code, and is
53 passed through via runperl, to B::Concise like this: (bcopts are fixed
56 './perl -w -MO=Concise,$bcopts_massaged -e $src'
58 code is a subref, or $src, like above. If it's not a subref, it's
59 treated like source, but is wrapped as a subroutine, and passed to
60 B::Concise::compile().
62 $subref = eval "sub{$src}";
64 I suppose I should also explain these more, but they seem obvious.
66 # prog => 'sort @a', # run in subprocess, aka -MO=Concise
67 # noanchors => 1, # no /^$/. needed for 1-liners like above
69 # skip => 1, # skips test
70 # todo => 'excuse', # anticipated failures
71 # fail => 1 # fails (by redirecting result)
72 # debug => 1, # turns on regex debug for match test !!
73 # retry => 1 # retry with debug on test failure
75 =head1 Test Philosophy
77 2 platforms --> 2 reftexts: You want an accurate test, independent of
78 which platform you're on. So, two refdata properties, 'expect' and
79 'expect_nt', carry renderings taken from threaded and non-threaded
80 builds. This has several benefits:
82 1. native reference data allows closer matching by regex.
83 2. samples can be eyeballed to grok t-nt differences.
84 3. data can help to validate mkCheckRex() operation.
85 4. can develop regexes which accomodate t-nt differences.
86 5. can test with both native and cross+converted regexes.
88 Cross-testing (expect_nt on threaded, expect on non-threaded) exposes
89 differences in B::Concise output, so mkCheckRex has code to do some
90 cross-test manipulations. This area needs more work.
94 One consequence of a single-function API is difficulty controlling
95 test-mode. Ive chosen for now to use a package hash, %gOpts, to store
96 test-state. These properties alter checkOptree() function, either
97 short-circuiting to selftest, or running a loop that runs the testcase
98 2^N times, varying conditions each time. (current N is 2 only).
100 So Test-mode is controlled with cmdline args, also called options below.
101 Run with 'help' to see the test-state, and how to change it.
105 This argument invokes runSelftest(), which tests a regex against the
106 reference renderings that they're made from. Failure of a regex match
107 its 'mold' is a strong indicator that mkCheckRex is buggy.
109 That said, selftest mode currently runs a cross-test too, they're not
110 completely orthogonal yet. See below.
112 =head2 testmode=cross
114 Cross-testing is purposely creating a T-NT mismatch, looking at the
115 fallout, and tweaking the regex to deal with it. Thus tests lead to
116 'provably' complete understanding of the differences.
118 The tweaking appears contrary to the 2-refs philosophy, but the tweaks
119 will be made in conversion-specific code, which (will) handles T->NT
120 and NT->T separately. The tweaking is incomplete.
122 A reasonable 1st step is to add tags to indicate when TonNT or NTonT
123 is known to fail. This needs an option to force failure, so the
124 test.pl reporting mechanics show results to aid the user.
126 =head2 testmode=native
128 This is normal mode. Other valid values are: native, cross, both.
130 =head2 checkOptree Notes
132 Accepts test code, renders its optree using B::Concise, and matches that
133 rendering against a regex built from one of 2 reference-renderings %in data.
135 The regex is built by mkCheckRex(\%in), which scrubs %in data to
136 remove match-irrelevancies, such as (args) and [args]. For example,
137 it strips leading '# ', making it easy to cut-paste new tests into
138 your test-file, run it, and cut-paste actual results into place. You
139 then retest and reedit until all 'errors' are gone. (now make sure you
140 haven't 'enshrined' a bug).
142 name: The test name. May be augmented by a label, which is built from
143 important params, and which helps keep names in sync with whats being
150 use B::Concise qw(walk_output);
152 $Data::Dumper::Sortkeys = 1;
155 $SIG{__WARN__} = sub {
157 $err =~ m/Subroutine re::(un)?install redefined/ and return;
161 # but wait - more skullduggery !
162 sub OptreeCheck::import { &getCmdLine; } # process @ARGV
164 # %gOpts params comprise a global test-state. Initial values here are
165 # HELP strings, they MUST BE REPLACED by runtime values before use, as
166 # is done by getCmdLine(), via import
168 our %gOpts = # values are replaced at runtime !!
170 # scalar values are help string
171 rextract => 'writes src-code todo same Optree matching',
172 vbasic => 'prints $str and $rex',
173 retry => 'retry failures after turning on re debug',
174 retrydbg => 'retry failures after turning on re debug',
175 selftest => 'self-tests mkCheckRex vs the reference rendering',
176 selfdbg => 'redo failing selftests with re debug',
177 xtest => 'extended thread/non-thread testing',
178 fail => 'force all test to fail, print to stdout',
179 dump => 'dump cmdline arg prcessing',
180 rexpedant => 'try tighter regex, still buggy',
181 noanchors => 'dont anchor match rex',
182 help => 0, # 1 ends in die
184 # array values are one-of selections, with 1st value as default
185 # tbc: 1st value is help, 2nd is default
186 testmode => [qw/ native cross both /],
190 # Not sure if this is too much cheating. Officially we say that
191 # $Config::Config{usethreads} is true if some sort of threading is in use,
192 # in which case we ought to be able to use it in place of the || below.
193 # However, it is now possible to Configure perl with "threads" but neither
194 # ithreads or 5005threads, which forces the re-entrant APIs, but no perl
195 # user visible threading. This seems to have the side effect that most of perl
196 # doesn't think that it's threaded, hence the ops aren't threaded either.
197 # Not sure if this is actually a "supported" configuration, but given that
198 # ponie uses it, it's going to be used by something official at least in the
199 # interim. So it's nice for tests to all pass.
201 if $Config::Config{useithreads} || $Config::Config{use5005threads};
202 our $platform = ($threaded) ? "threaded" : "plain";
203 our $thrstat = ($threaded) ? "threaded" : "nonthreaded";
205 our ($MatchRetry,$MatchRetryDebug); # let mylike be generic
207 *MatchRetry = \$gOpts{retry}; # but alias it into %gOpts
208 *MatchRetryDebug = \$gOpts{retrydbg}; # but alias it into %gOpts
211 both => [ 'expect', 'expect_nt'],
212 native => [ ($threaded) ? 'expect' : 'expect_nt'],
213 cross => [ !($threaded) ? 'expect' : 'expect_nt'],
214 expect => [ 'expect' ],
215 expect_nt => [ 'expect_nt' ],
218 our %msgs # announce cross-testing.
221 'expect_nt-threaded' => " (Non-threaded-ref on Threaded-build)",
222 'expect-nonthreaded' => " (Threaded-ref on Non-threaded-build)",
223 # native - nothing to say
224 'expect_nt-nonthreaded' => '',
225 'expect-threaded' => '',
229 sub getCmdLine { # import assistant
231 print(qq{\n$0 accepts args to update these state-vars:
232 turn on a flag by typing its name,
233 select a value from list by typing name=val.\n },
235 if grep /help/, @ARGV;
237 # replace values for each key !! MUST MARK UP %gOpts
238 foreach my $opt (keys %gOpts) {
240 # scan ARGV for known params
241 if (ref $gOpts{$opt} eq 'ARRAY') {
243 # $opt is a One-Of construct
244 # replace with valid selection from the list
246 # uhh this WORKS. but it's inscrutable
247 # grep s/$opt=(\w+)/grep {$_ eq $1} @ARGV and $gOpts{$opt}=$1/e, @ARGV;
249 if (grep s/$opt=(\w+)/$tval=$1/e, @ARGV) {
250 # check val before accepting
251 my @allowed = @{$gOpts{$opt}};
252 if (grep { $_ eq $tval } @allowed) {
253 $gOpts{$opt} = $tval;
255 else {die "invalid value: '$tval' for $opt\n"}
258 # take 1st val as default
259 $gOpts{$opt} = ${$gOpts{$opt}}[0]
260 if ref $gOpts{$opt} eq 'ARRAY';
262 else { # handle scalars
264 # if 'opt' is present, true
265 $gOpts{$opt} = (grep /$opt/, @ARGV) ? 1 : 0;
267 # override with 'foo' if 'opt=foo' appears
268 grep s/$opt=(.*)/$gOpts{$opt}=$1/e, @ARGV;
271 print("$0 heres current state:\n", Dumper \%gOpts)
272 if $gOpts{help} or $gOpts{dump};
274 exit if $gOpts{help};
277 ##################################
282 my ($in, $res) = (\%in,0); # set up privates.
284 print "checkOptree args: ",Dumper \%in if $in{dump};
287 skip($in{name}, 1) if $in{skip};
288 return runSelftest(\%in) if $gOpts{selftest};
290 my $rendering = getRendering(\%in); # get the actual output
291 fail("FORCED: $in{name}:\n$rendering") if $gOpts{fail}; # silly ?
293 # Test rendering against ..
295 foreach $want (@{$modes{$gOpts{testmode}}}) {
296 local $TODO = $in{todo} if $in{todo};
298 my ($rex,$txt,$rexstr) = mkCheckRex(\%in,$want);
299 my $cross = $msgs{"$want-$thrstat"};
301 # bad is anticipated failure on cross testing ONLY
302 my $bad = (0 or ( $cross && $in{crossfail})
303 or (!$cross && $in{fail})
304 or 0); # no undefs! pedant
306 # couldn't bear to pass \%in to likeyn
307 $res = mylike ( # custom test mode stuff
309 $in{retry} || $gOpts{retry},
310 $in{debug} || $gOpts{retrydbg},
313 # remaining is std API
314 $rendering, qr/$rex/ms, "$cross $in{name} $in{label}")
316 printhelp(\%in, $rendering, $rex);
326 # may help get/keep test output consistent
328 return if $in->{name};
330 my $buf = (ref $in->{bcopts})
331 ? join(',', @{$in->{bcopts}}) : $in->{bcopts};
333 foreach (qw( note prog code )) {
334 $buf .= " $_: $in->{$_}" if $in->{$_} and not ref $in->{$_};
336 return $in->{label} = $buf;
340 # generate a set of test-cases from the options
343 foreach $want (@{$modes{$gOpts{testmode}}}) {
350 # tests the test-cases offered (expect, expect_nt)
351 # needs Unification with above.
354 foreach $want (@{$modes{$gOpts{testmode}}}) {}
356 for my $provenance (qw/ expect expect_nt /) {
357 next unless $in->{$provenance};
358 my ($rex,$gospel) = mkCheckRex($in, $provenance);
359 return unless $gospel;
361 my $cross = $msgs{"$provenance-$thrstat"};
362 my $bad = (0 or ( $cross && $in->{crossfail})
363 or (!$cross && $in->{fail})
365 # couldn't bear to pass \%in to likeyn
366 $res = mylike ( [ !$bad,
367 $in->{retry} || $gOpts{retry},
368 $in->{debug} || $gOpts{retrydbg},
371 $rendering, qr/$rex/ms, "$cross $in{name}")
379 # note dependence on unlike()
380 my ($control) = shift;
381 my ($yes,$retry,$debug,$postmortem) = @$control; # or dies
382 my ($got, $expected, $name, @mess) = @_; # pass thru mostly
384 die "unintended usage, expecting Regex". Dumper \@_
385 unless ref $_[1] eq 'Regexp';
387 #ok($got=~/$expected/, "wow");
389 # same as A ^ B, but B has side effects
390 my $ok = ( (!$yes and unlike($got, $expected, $name, @mess))
391 or ($yes and like($got, $expected, $name, @mess)));
393 if (not $ok and $postmortem) {
394 # split rexstr into units that should eat leading lines.
395 my @rexs = map qr/^$_/, split (/\n/,$postmortem);
396 foreach my $rex (@rexs) {
397 #$got =~ s/($rex)/ate: $1/msg; # noisy
398 $got =~ s/($rex)\n//msg; # remove matches
400 print "sequentially deconstructed, these are unmatched:\n$got\n";
403 if (not $ok and $retry) {
404 # redo, perhaps with use re debug - NOT ROBUST
405 eval "use re 'debug'" if $debug;
406 $ok = (!$yes and unlike($got, $expected, "(RETRY) $name", @mess)
407 or $yes and like($got, $expected, "(RETRY) $name", @mess));
416 die "getRendering: code or prog is required\n"
417 unless $in->{code} or $in->{prog};
419 my @opts = get_bcopts($in);
420 my $rendering = ''; # suppress "Use of uninitialized value in open"
423 $rendering = runperl( switches => ['-w',join(',',"-MO=Concise",@opts)],
424 prog => $in->{prog}, stderr => 1,
427 my $code = $in->{code};
428 unless (ref $code eq 'CODE') {
429 # treat as source, and wrap
430 $code = eval "sub { $code }";
431 die "$@ evaling code 'sub { $in->{code} }'\n"
432 unless ref $code eq 'CODE';
434 # set walk-output b4 compiling, which writes 'announce' line
435 walk_output(\$rendering);
437 fail("forced failure: stdout follows");
438 walk_output(\*STDOUT);
440 my $opwalker = B::Concise::compile(@opts, $code);
441 die "bad BC::compile retval" unless ref $opwalker eq 'CODE';
443 B::Concise::reset_sequence();
450 # collect concise passthru-options if any
454 @opts = (ref $in->{bcopts} eq 'ARRAY')
455 ? @{$in->{bcopts}} : ($in->{bcopts});
460 # needless complexity due to 'too much info' from B::Concise v.60
461 my $announce = 'B::Concise::compile\(CODE\(0x[0-9a-f]+\)\)';;
464 # converts expected text into Regexp which should match against
465 # unaltered version. also adjusts threaded => non-threaded
466 my ($in, $want) = @_;
467 eval "no re 'debug'";
469 my $str = $in->{expect} || $in->{expect_nt}; # standard bias
470 $str = $in->{$want} if $want; # stated pref
472 die "no reftext found for $want: $in->{name}" unless $str;
473 #fail("rex-str is empty, won't allow false positives") unless $str;
475 $str =~ s/^\# //mg; # ease cut-paste testcase authoring
476 my $reftxt = $str; # extra return val !!
478 # convert all (args) and [args] to temp forms wo bracing
479 $str =~ s/\[(.*?)\]/__CAPSQR$1__/msg;
480 $str =~ s/\((.*?)\)/__CAPRND$1__/msg;
481 $str =~ s/\((.*?)\)/__CAPRND$1__/msg; # nested () in nextstate
483 # escape bracing, etc.. manual \Q (doesnt escape '+')
484 $str =~ s/([\[\]()*.\$\@\#\|{}])/\\$1/msg;
486 # now replace temp forms with original, preserving reference bracing
487 $str =~ s/__CAPSQR(.*?)__\b/\\[$1\\]/msg; # \b is important
488 $str =~ s/__CAPRND(.*?)__\b/\\($1\\)/msg;
489 $str =~ s/__CAPRND(.*?)__\b/\\($1\\)/msg; # nested () in nextstate
491 # no 'invisible' failures in debugger
492 $str =~ s/(?:next|db)state(\\\(.*?\\\))/(?:next|db)state(.*?)/msg;
495 $str =~ s/:-?\d+,-?\d+/:-?\\d+,-?\\d+/msg; # FAKE line numbers
496 $str =~ s/match\\\(.*?\\\)/match\(.*?\)/msg; # match args
497 $str =~ s/(0x[0-9A-Fa-f]+)/0x[0-9A-Fa-f]+/msg; # hexnum values
498 $str =~ s/".*?"/".*?"/msg; # quoted strings
500 croak "no reftext found for $want: $in->{name}"
501 unless $str =~ /\w+/; # fail unless a real test
503 # $str = '.*' if 1; # sanity test
504 # $str .= 'FAIL' if 1; # sanity test
506 # allow -eval, banner at beginning of anchored matches
507 $str = "(-e .*?)?(B::Concise::compile.*?)?\n" . $str
508 unless $in->{noanchors};
510 eval "use re 'debug'" if $debug;
511 my $qr = ($in->{noanchors}) ? qr/$str/ms : qr/^$str$/ms ;
514 return ($qr, $reftxt, $str) if wantarray;
520 # crufty - may be still useful
521 my ($in, $rendering, $rex) = @_;
522 print "<$rendering>\nVS\n<$rex>\n" if $gOpts{vbasic};
524 # save this output to afile, edit out 'ok's and 1..N
525 # then perl -d afile, and add re 'debug' to suit.
526 print("\$str = q%$rendering%;\n".
527 "\$rex = qr%$rex%;\n\n".
528 #"print \"\$str =~ m%\$rex%ms \";\n".
529 "\$str =~ m{\$rex}ms or print \"doh\\n\";\n\n")
530 if $in{rextract} or $gOpts{rextract};
534 #########################
535 # support for test writing
538 my $testct = shift || 1;
544 \@INC = qw(../lib ../ext/B/t);
545 require q(./test.pl);
548 plan tests => $testct;
554 sub OptreeCheck::wrap {
556 $code =~ s/(?:(\#.*?)\n)//gsm;
557 $code =~ s/\s+/ /mgs;
559 return unless $code =~ /\S/;
564 checkOptree(note => q{$comment},
567 expect => <<EOT_EOT, expect_nt => <<EONT_EONT);
577 sub OptreeCheck::gentest {
578 my ($code,$opts) = @_;
579 my $rendering = getRendering({code => $code});
580 my $testcode = OptreeCheck::wrap($code);
581 return unless $testcode;
583 # run the prog, capture 'reference' concise output
584 my $preamble = preamble(1);
585 my $got = runperl( prog => "$preamble $testcode", stderr => 1,
586 #switches => ["-I../ext/B/t", "-MOptreeCheck"],
589 # extract the 'reftext' ie the got 'block'
590 if ($got =~ m/got \'.*?\n(.*)\n\# \'\n\# expected/s) {
592 #and plug it into the test-src
594 $testcode =~ s/ThreadedRef/$reftext/;
596 $testcode =~ s/NonThreadRef/$reftext/;
598 my $b4 = q{expect => <<EOT_EOT, expect_nt => <<EONT_EONT};
599 my $af = q{expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'};
600 $testcode =~ s/$b4/$af/;
603 if ($internal_retest) {
604 $got = runperl( prog => "$preamble $testcode", stderr => 1,
605 #switches => ["-I../ext/B/t", "-MOptreeCheck"],
615 sub OptreeCheck::processExamples {
617 # gets array of paragraphs, which should be tests.
619 foreach my $file (@files) {
620 open (my $fh, $file) or die "cant open $file: $!\n";
623 print preamble (scalar @chunks);
624 foreach $t (@chunks) {
625 print "\n\n=for gentest\n\n# chunk: $t=cut\n\n";
626 print OptreeCheck::gentest ($t);
631 # OK - now for the final insult to your good taste...
633 if ($0 =~ /OptreeCheck\.pm/) {
636 require './t/test.pl';
638 # invoked as program. Work like former gentest.pl,
639 # ie read files given as cmdline args,
640 # convert them to usable test files.
643 Getopt::Std::getopts('') or
644 die qq{ $0 sample-files* # no options
646 expecting filenames as args. Each should have paragraphs,
647 these are converted to checkOptree() tests, and printed to
648 stdout. Redirect to file then edit for test. \n};
650 OptreeCheck::processExamples(@ARGV);
659 mkCheckRex receives the full testcase object, and constructs a regex.
660 1st, it selects a reftxt from either the expect or expect_nt items.
662 Once selected, reftext is massaged & converted into a Regex that
663 accepts 'good' concise renderings, with appropriate input variations,
664 but is otherwise as strict as possible. For example, it should *not*
665 match when opcode flags change, or when optimizations convert an op to
668 =head2 match criteria
670 Opcode arguments (text within braces) are disregarded for matching
671 purposes. This loses some info in 'add[t5]', but greatly simplifys
672 matching 'nextstate(main 22 (eval 10):1)'. Besides, we are testing
673 for regressions, not for complete accuracy.
675 The regex is anchored by default, but can be suppressed with
676 'noanchors', allowing 1-liner tests to succeed if opcode is found.
678 =head1 TEST DEVELOPMENT SUPPORT
680 This optree regression testing framework needs tests in order to find
681 bugs. To that end, OptreeCheck has support for developing new tests,
682 according to the following model:
684 1. write a set of sample code into a single file, one per
685 paragraph. f_map and f_sort in ext/B/t/ are examples.
687 2. run OptreeCheck as a program on the file
689 ./perl -Ilib ext/B/t/OptreeCheck.pm -w ext/B/t/f_map
690 ./perl -Ilib ext/B/t/OptreeCheck.pm -w ext/B/t/f_sort
692 gentest reads the sample code, runs each to generate a reference
693 rendering, folds this rendering into an optreeCheck() statement,
694 and prints it to stdout.
696 3. run the output file as above, redirect to files, then rerun on
697 same build (for sanity check), and on thread-opposite build. With
698 editor in 1 window, and cmd in other, it's fairly easy to cut-paste
699 the gots into the expects, easier than running step 2 on both
700 builds then trying to sdiff them together.
704 There's a considerable amount of cruft in the whole arg-handling setup.
705 I'll replace / strip it before 5.10
707 Treat %in as a test object, interwork better with Test::*
709 Refactor mkCheckRex() and selfTest() to isolate the selftest,
710 crosstest, etc selection mechanics.
712 improve retry, retrydbg, esp. it's control of eval "use re debug".
713 This seems to work part of the time, but isn't stable enough.