Re: more B::Concise stuff (PATCH - updated)
[p5sagit/p5-mst-13.2.git] / ext / B / t / OptreeCheck.pm
CommitLineData
cc02ea56 1# non-package OptreeCheck.pm
2# pm allows 'use OptreeCheck', which also imports
3# no package decl means all functions defined into main
724aa791 4# otherwise, it's like "require './test.pl'"
5
6=head1 NAME
7
8OptreeCheck - check optrees
9
10=head1 SYNOPSIS
11
12OptreeCheck supports regression testing of perl's parser, optimizer,
cc02ea56 13bytecode generator, via a single function: checkOptree(%args).'
724aa791 14
cc02ea56 15 checkOptree(name => "your title here", # optional, (synth from others)
724aa791 16 bcopts => '-exec', # $opt or \@opts, passed to BC::compile
cc02ea56 17 code => sub {my $a}, # coderef, or source (wrapped and evald)
724aa791 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
28 EOT_EOT
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
32 EONT_EONT
33
34=head1 checkOptree(%in) Overview
35
cc02ea56 36Calls getRendering(), which runs code or prog through B::Concise, and
37captures its rendering.
724aa791 38
39Calls mkCheckRex() to produce a regex which will match the expected
40rendering, and fail when it doesn't match.
41
cc02ea56 42Also calls like($rendering,/$regex/,$name), and thereby plugs into the
43test.pl framework.
724aa791 44
45=head1 checkOptree(%Args) API
46
47Accepts %Args, with following requirements and actions:
48
cc02ea56 49expect and expect_nt are both: required, not empty, not whitespace.
50It's a fatal error otherwise, because false positives are BAD.
724aa791 51
cc02ea56 52Either code or prog must be present. prog is some source code, and is
53passed through via runperl, to B::Concise like this: (bcopts are fixed
54up for cmdline)
724aa791 55
56 './perl -w -MO=Concise,$bcopts_massaged -e $src'
57
58code is a subref, or $src, like above. If it's not a subref, it's
cc02ea56 59treated like source, but is wrapped as a subroutine, and passed to
60B::Concise::compile().
724aa791 61
62 $subref = eval "sub{$src}";
63
cc02ea56 64I suppose I should also explain these more, but they seem obvious.
724aa791 65
66 # prog => 'sort @a', # run in subprocess, aka -MO=Concise
cc02ea56 67 # noanchors => 1, # no /^$/. needed for 1-liners like above
68
724aa791 69 # skip => 1, # skips test
cc02ea56 70 # todo => 'excuse', # anticipated failures
71 # fail => 1 # fails (by redirecting result)
724aa791 72 # debug => 1, # turns on regex debug for match test !!
73 # retry => 1 # retry with debug on test failure
74
cc02ea56 75=head1 Test Philosophy
724aa791 76
772 platforms --> 2 reftexts: You want an accurate test, independent of
cc02ea56 78which platform you're on. So, two refdata properties, 'expect' and
79'expect_nt', carry renderings taken from threaded and non-threaded
80builds. This has several benefits:
724aa791 81
cc02ea56 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.
724aa791 87
88Cross-testing (expect_nt on threaded, expect on non-threaded) exposes
89differences in B::Concise output, so mkCheckRex has code to do some
90cross-test manipulations. This area needs more work.
91
92=head1 Test Modes
93
94One consequence of a single-function API is difficulty controlling
95test-mode. Ive chosen for now to use a package hash, %gOpts, to store
96test-state. These properties alter checkOptree() function, either
97short-circuiting to selftest, or running a loop that runs the testcase
982^N times, varying conditions each time. (current N is 2 only).
99
100So Test-mode is controlled with cmdline args, also called options below.
101Run with 'help' to see the test-state, and how to change it.
102
103=head2 selftest
104
105This argument invokes runSelftest(), which tests a regex against the
106reference renderings that they're made from. Failure of a regex match
107its 'mold' is a strong indicator that mkCheckRex is buggy.
108
109That said, selftest mode currently runs a cross-test too, they're not
110completely orthogonal yet. See below.
111
112=head2 testmode=cross
113
114Cross-testing is purposely creating a T-NT mismatch, looking at the
115fallout, and tweaking the regex to deal with it. Thus tests lead to
116'provably' complete understanding of the differences.
117
118The tweaking appears contrary to the 2-refs philosophy, but the tweaks
119will be made in conversion-specific code, which (will) handles T->NT
120and NT->T separately. The tweaking is incomplete.
121
122A reasonable 1st step is to add tags to indicate when TonNT or NTonT
123is known to fail. This needs an option to force failure, so the
124test.pl reporting mechanics show results to aid the user.
125
126=head2 testmode=native
127
128This is normal mode. Other valid values are: native, cross, both.
129
130=head2 checkOptree Notes
131
132Accepts test code, renders its optree using B::Concise, and matches that
133rendering against a regex built from one of 2 reference-renderings %in data.
134
135The regex is built by mkCheckRex(\%in), which scrubs %in data to
136remove match-irrelevancies, such as (args) and [args]. For example,
137it strips leading '# ', making it easy to cut-paste new tests into
138your test-file, run it, and cut-paste actual results into place. You
139then retest and reedit until all 'errors' are gone. (now make sure you
140haven't 'enshrined' a bug).
141
142name: The test name. May be augmented by a label, which is built from
143important params, and which helps keep names in sync with whats being
cc02ea56 144tested.'
724aa791 145
146=cut
147
148use Config;
149use Carp;
150use B::Concise qw(walk_output);
151use Data::Dumper;
152$Data::Dumper::Sortkeys = 1;
153
154BEGIN {
155 $SIG{__WARN__} = sub {
156 my $err = shift;
157 $err =~ m/Subroutine re::(un)?install redefined/ and return;
158 };
159}
160
161# but wait - more skullduggery !
162sub OptreeCheck::import { &getCmdLine; } # process @ARGV
163
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
167
168our %gOpts = # values are replaced at runtime !!
169 (
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',
cc02ea56 181 noanchors => 'dont anchor match rex',
724aa791 182 help => 0, # 1 ends in die
183
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 /],
187 );
188
189
190our $threaded = 1 if $Config::Config{usethreads};
191our $platform = ($threaded) ? "threaded" : "plain";
192our $thrstat = ($threaded) ? "threaded" : "nonthreaded";
193
194our ($MatchRetry,$MatchRetryDebug); # let mylike be generic
195# test.pl-ish hack
196*MatchRetry = \$gOpts{retry}; # but alias it into %gOpts
197*MatchRetryDebug = \$gOpts{retrydbg}; # but alias it into %gOpts
198
199our %modes = (
200 both => [ 'expect', 'expect_nt'],
201 native => [ ($threaded) ? 'expect' : 'expect_nt'],
202 cross => [ !($threaded) ? 'expect' : 'expect_nt'],
203 expect => [ 'expect' ],
204 expect_nt => [ 'expect_nt' ],
cc02ea56 205 );
724aa791 206
207our %msgs # announce cross-testing.
208 = (
209 # cross-platform
210 'expect_nt-threaded' => " (Non-threaded-ref on Threaded-build)",
211 'expect-nonthreaded' => " (Threaded-ref on Non-threaded-build)",
212 # native - nothing to say
213 'expect_nt-nonthreaded' => '',
214 'expect-threaded' => '',
215 );
216
217#######
218sub getCmdLine { # import assistant
219 # offer help
220 print(qq{\n$0 accepts args to update these state-vars:
221 turn on a flag by typing its name,
222 select a value from list by typing name=val.\n },
223 Dumper \%gOpts)
224 if grep /help/, @ARGV;
225
226 # replace values for each key !! MUST MARK UP %gOpts
227 foreach my $opt (keys %gOpts) {
228
229 # scan ARGV for known params
230 if (ref $gOpts{$opt} eq 'ARRAY') {
231
232 # $opt is a One-Of construct
233 # replace with valid selection from the list
234
235 # uhh this WORKS. but it's inscrutable
236 # grep s/$opt=(\w+)/grep {$_ eq $1} @ARGV and $gOpts{$opt}=$1/e, @ARGV;
237 my $tval; # temp
238 if (grep s/$opt=(\w+)/$tval=$1/e, @ARGV) {
239 # check val before accepting
240 my @allowed = @{$gOpts{$opt}};
241 if (grep { $_ eq $tval } @allowed) {
242 $gOpts{$opt} = $tval;
243 }
244 else {die "invalid value: '$tval' for $opt\n"}
245 }
246
247 # take 1st val as default
248 $gOpts{$opt} = ${$gOpts{$opt}}[0]
249 if ref $gOpts{$opt} eq 'ARRAY';
250 }
251 else { # handle scalars
252
253 # if 'opt' is present, true
254 $gOpts{$opt} = (grep /$opt/, @ARGV) ? 1 : 0;
255
256 # override with 'foo' if 'opt=foo' appears
257 grep s/$opt=(.*)/$gOpts{$opt}=$1/e, @ARGV;
258 }
259 }
260 print("$0 heres current state:\n", Dumper \%gOpts)
261 if $gOpts{help} or $gOpts{dump};
262
263 exit if $gOpts{help};
264}
265
266##################################
267# API
268
269sub checkOptree {
270 my %in = @_;
271 my ($in, $res) = (\%in,0); # set up privates.
272
273 print "checkOptree args: ",Dumper \%in if $in{dump};
274 SKIP: {
cc02ea56 275 label(\%in);
724aa791 276 skip($in{name}, 1) if $in{skip};
277 return runSelftest(\%in) if $gOpts{selftest};
278
279 my $rendering = getRendering(\%in); # get the actual output
280 fail("FORCED: $in{name}:\n$rendering") if $gOpts{fail}; # silly ?
281
282 # Test rendering against ..
cc02ea56 283 TODO:
724aa791 284 foreach $want (@{$modes{$gOpts{testmode}}}) {
cc02ea56 285 local $TODO = $in{todo} if $in{todo};
724aa791 286
cc02ea56 287 my ($rex,$txt,$rexstr) = mkCheckRex(\%in,$want);
724aa791 288 my $cross = $msgs{"$want-$thrstat"};
289
290 # bad is anticipated failure on cross testing ONLY
291 my $bad = (0 or ( $cross && $in{crossfail})
292 or (!$cross && $in{fail})
cc02ea56 293 or 0); # no undefs! pedant
724aa791 294
295 # couldn't bear to pass \%in to likeyn
296 $res = mylike ( # custom test mode stuff
297 [ !$bad,
cc02ea56 298 $in{retry} || $gOpts{retry},
299 $in{debug} || $gOpts{retrydbg},
300 $rexstr,
724aa791 301 ],
302 # remaining is std API
cc02ea56 303 $rendering, qr/$rex/ms, "$cross $in{name} $in{label}")
724aa791 304 || 0;
305 printhelp(\%in, $rendering, $rex);
306 }
307 }
308 $res;
309}
310
311#################
312# helpers
313
314sub label {
315 # may help get/keep test output consistent
316 my ($in) = @_;
cc02ea56 317 return if $in->{name};
318
319 my $buf = (ref $in->{bcopts})
320 ? join(',', @{$in->{bcopts}}) : $in->{bcopts};
321
322 foreach (qw( note prog code )) {
323 $buf .= " $_: $in->{$_}" if $in->{$_} and not ref $in->{$_};
324 }
325 return $in->{label} = $buf;
724aa791 326}
327
328sub testCombo {
329 # generate a set of test-cases from the options
330 my $in = @_;
331 my @cases;
332 foreach $want (@{$modes{$gOpts{testmode}}}) {
cc02ea56 333 push @cases, [ %in ]
724aa791 334 }
335 return @cases;
336}
337
338sub runSelftest {
339 # tests the test-cases offered (expect, expect_nt)
340 # needs Unification with above.
341 my ($in) = @_;
342 my $ok;
343 foreach $want (@{$modes{$gOpts{testmode}}}) {}
344
345 for my $provenance (qw/ expect expect_nt /) {
346 next unless $in->{$provenance};
347 my ($rex,$gospel) = mkCheckRex($in, $provenance);
348 return unless $gospel;
349
350 my $cross = $msgs{"$provenance-$thrstat"};
351 my $bad = (0 or ( $cross && $in->{crossfail})
352 or (!$cross && $in->{fail})
353 or 0);
354 # couldn't bear to pass \%in to likeyn
355 $res = mylike ( [ !$bad,
356 $in->{retry} || $gOpts{retry},
cc02ea56 357 $in->{debug} || $gOpts{retrydbg},
358 #label($in)
724aa791 359 ],
360 $rendering, qr/$rex/ms, "$cross $in{name}")
361 || 0;
362 }
363 $ok;
364}
365
366# use re;
367sub mylike {
368 # note dependence on unlike()
369 my ($control) = shift;
cc02ea56 370 my ($yes,$retry,$debug,$postmortem) = @$control; # or dies
724aa791 371 my ($got, $expected, $name, @mess) = @_; # pass thru mostly
372
373 die "unintended usage, expecting Regex". Dumper \@_
374 unless ref $_[1] eq 'Regexp';
375
cc02ea56 376 #ok($got=~/$expected/, "wow");
377
724aa791 378 # same as A ^ B, but B has side effects
379 my $ok = ( (!$yes and unlike($got, $expected, $name, @mess))
380 or ($yes and like($got, $expected, $name, @mess)));
381
cc02ea56 382 if (not $ok and $postmortem) {
383 # split rexstr into units that should eat leading lines.
384 my @rexs = map qr/^$_/, split (/\n/,$postmortem);
385 foreach my $rex (@rexs) {
386 #$got =~ s/($rex)/ate: $1/msg; # noisy
387 $got =~ s/($rex)\n//msg; # remove matches
388 }
389 print "sequentially deconstructed, these are unmatched:\n$got\n";
390 }
391
724aa791 392 if (not $ok and $retry) {
cc02ea56 393 # redo, perhaps with use re debug - NOT ROBUST
724aa791 394 eval "use re 'debug'" if $debug;
395 $ok = (!$yes and unlike($got, $expected, "(RETRY) $name", @mess)
396 or $yes and like($got, $expected, "(RETRY) $name", @mess));
397
398 no re 'debug';
399 }
400 return $ok;
401}
402
403sub getRendering {
404 my ($in) = @_;
405 die "getRendering: code or prog is required\n"
406 unless $in->{code} or $in->{prog};
407
408 my @opts = get_bcopts($in);
409 my $rendering = ''; # suppress "Use of uninitialized value in open"
410
411 if ($in->{prog}) {
412 $rendering = runperl( switches => ['-w',join(',',"-MO=Concise",@opts)],
413 prog => $in->{prog}, stderr => 1,
414 ); #verbose => 1);
415 } else {
416 my $code = $in->{code};
417 unless (ref $code eq 'CODE') {
418 # treat as source, and wrap
419 $code = eval "sub { $code }";
420 die "$@ evaling code 'sub { $in->{code} }'\n"
421 unless ref $code eq 'CODE';
422 }
423 # set walk-output b4 compiling, which writes 'announce' line
424 walk_output(\$rendering);
425 if ($in->{fail}) {
426 fail("forced failure: stdout follows");
427 walk_output(\*STDOUT);
428 }
429 my $opwalker = B::Concise::compile(@opts, $code);
430 die "bad BC::compile retval" unless ref $opwalker eq 'CODE';
431
432 B::Concise::reset_sequence();
433 $opwalker->();
434 }
435 return $rendering;
436}
437
438sub get_bcopts {
439 # collect concise passthru-options if any
440 my ($in) = shift;
441 my @opts = ();
442 if ($in->{bcopts}) {
443 @opts = (ref $in->{bcopts} eq 'ARRAY')
444 ? @{$in->{bcopts}} : ($in->{bcopts});
445 }
446 return @opts;
447}
448
449# needless complexity due to 'too much info' from B::Concise v.60
450my $announce = 'B::Concise::compile\(CODE\(0x[0-9a-f]+\)\)';;
451
452sub mkCheckRex {
453 # converts expected text into Regexp which should match against
454 # unaltered version. also adjusts threaded => non-threaded
455 my ($in, $want) = @_;
456 eval "no re 'debug'";
457
458 my $str = $in->{expect} || $in->{expect_nt}; # standard bias
459 $str = $in->{$want} if $want; # stated pref
460
461 die "no reftext found for $want: $in->{name}" unless $str;
462 #fail("rex-str is empty, won't allow false positives") unless $str;
463
464 $str =~ s/^\# //mg; # ease cut-paste testcase authoring
465 my $reftxt = $str; # extra return val !!
466
cc02ea56 467 # convert all (args) and [args] to temp forms wo bracing
468 $str =~ s/\[(.*?)\]/__CAPSQR$1__/msg;
469 $str =~ s/\((.*?)\)/__CAPRND$1__/msg;
470 $str =~ s/\((.*?)\)/__CAPRND$1__/msg; # nested () in nextstate
471
472 # escape bracing, etc.. manual \Q (doesnt escape '+')
473 $str =~ s/([\[\]()*.\$\@\#\|{}])/\\$1/msg;
474
475 # now replace temp forms with original, preserving reference bracing
476 $str =~ s/__CAPSQR(.*?)__\b/\\[$1\\]/msg; # \b is important
477 $str =~ s/__CAPRND(.*?)__\b/\\($1\\)/msg;
478 $str =~ s/__CAPRND(.*?)__\b/\\($1\\)/msg; # nested () in nextstate
479
480 # no 'invisible' failures in debugger
481 $str =~ s/(?:next|db)state(\\\(.*?\\\))/(?:next|db)state(.*?)/msg;
482
483 # don't care about:
484 $str =~ s/:-?\d+,-?\d+/:-?\\d+,-?\\d+/msg; # FAKE line numbers
485 $str =~ s/match\\\(.*?\\\)/match\(.*?\)/msg; # match args
486 $str =~ s/(0x[0-9A-Fa-f]+)/0x[0-9A-Fa-f]+/msg; # hexnum values
487 $str =~ s/".*?"/".*?"/msg; # quoted strings
724aa791 488
724aa791 489 croak "no reftext found for $want: $in->{name}"
490 unless $str =~ /\w+/; # fail unless a real test
491
492 # $str = '.*' if 1; # sanity test
493 # $str .= 'FAIL' if 1; # sanity test
494
cc02ea56 495 # allow -eval, banner at beginning of anchored matches
496 $str = "(-e .*?)?(B::Concise::compile.*?)?\n" . $str
497 unless $in->{noanchors};
498
724aa791 499 eval "use re 'debug'" if $debug;
cc02ea56 500 my $qr = ($in->{noanchors}) ? qr/$str/ms : qr/^$str$/ms ;
724aa791 501 no re 'debug';
502
cc02ea56 503 return ($qr, $reftxt, $str) if wantarray;
724aa791 504 return $qr;
505}
506
cc02ea56 507
724aa791 508sub printhelp {
cc02ea56 509 # crufty - may be still useful
724aa791 510 my ($in, $rendering, $rex) = @_;
cc02ea56 511 print "<$rendering>\nVS\n<$rex>\n" if $gOpts{vbasic};
724aa791 512
513 # save this output to afile, edit out 'ok's and 1..N
514 # then perl -d afile, and add re 'debug' to suit.
cc02ea56 515 print("\$str = q%$rendering%;\n".
516 "\$rex = qr%$rex%;\n\n".
517 #"print \"\$str =~ m%\$rex%ms \";\n".
724aa791 518 "\$str =~ m{\$rex}ms or print \"doh\\n\";\n\n")
519 if $in{rextract} or $gOpts{rextract};
520}
521
cc02ea56 522
523#########################
524# support for test writing
525
526sub preamble {
527 my $testct = shift || 1;
528 return <<EO_HEADER;
529#!perl
530
531BEGIN {
532 chdir q(t);
533 \@INC = qw(../lib ../ext/B/t);
534 require q(./test.pl);
535}
536use OptreeCheck;
537plan tests => $testct;
538
539EO_HEADER
540
541}
542
543sub OptreeCheck::wrap {
544 my $code = shift;
545 $code =~ s/(?:(\#.*?)\n)//gsm;
546 $code =~ s/\s+/ /mgs;
547 chomp $code;
548 return unless $code =~ /\S/;
549 my $comment = $1;
550
551 my $testcode = qq{
552
553checkOptree(note => q{$comment},
554 bcopts => q{-exec},
555 code => q{$code},
556 expect => <<EOT_EOT, expect_nt => <<EONT_EONT);
557ThreadedRef
558EOT_EOT
559NonThreadRef
560EONT_EONT
561
562};
563 return $testcode;
564}
565
566sub OptreeCheck::gentest {
567 my ($code,$opts) = @_;
568 my $rendering = getRendering({code => $code});
569 my $testcode = OptreeCheck::wrap($code);
570 return unless $testcode;
571
572 # run the prog, capture 'reference' concise output
573 my $preamble = preamble(1);
574 my $got = runperl( prog => "$preamble $testcode", stderr => 1,
575 #switches => ["-I../ext/B/t", "-MOptreeCheck"],
576 ); #verbose => 1);
577
578 # extract the 'reftext' ie the got 'block'
579 if ($got =~ m/got \'.*?\n(.*)\n\# \'\n\# expected/s) {
580 my $reftext = $1;
581 #and plug it into the test-src
582 if ($threaded) {
583 $testcode =~ s/ThreadedRef/$reftext/;
584 } else {
585 $testcode =~ s/NonThreadRef/$reftext/;
586 }
587 my $b4 = q{expect => <<EOT_EOT, expect_nt => <<EONT_EONT};
588 my $af = q{expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'};
589 $testcode =~ s/$b4/$af/;
590
591 my $got;
592 if ($internal_retest) {
593 $got = runperl( prog => "$preamble $testcode", stderr => 1,
594 #switches => ["-I../ext/B/t", "-MOptreeCheck"],
595 verbose => 1);
596 print "got: $got\n";
597 }
598 return $testcode;
599 }
600 return '';
601}
602
603
604sub OptreeCheck::processExamples {
605 my @files = @_;
606 # gets array of paragraphs, which should be tests.
607
608 foreach my $file (@files) {
609 open (my $fh, $file) or die "cant open $file: $!\n";
610 $/ = "";
611 my @chunks = <$fh>;
612 print preamble (scalar @chunks);
613 foreach $t (@chunks) {
614 print "\n\n=for gentest\n\n# chunk: $t=cut\n\n";
615 print OptreeCheck::gentest ($t);
616 }
617 }
618}
619
620# OK - now for the final insult to your good taste...
621
622if ($0 =~ /OptreeCheck\.pm/) {
623
624 #use lib 't';
625 require './t/test.pl';
626
627 # invoked as program. Work like former gentest.pl,
628 # ie read files given as cmdline args,
629 # convert them to usable test files.
630
631 require Getopt::Std;
632 Getopt::Std::getopts('') or
633 die qq{ $0 sample-files* # no options
634
635 expecting filenames as args. Each should have paragraphs,
636 these are converted to checkOptree() tests, and printed to
637 stdout. Redirect to file then edit for test. \n};
638
639 OptreeCheck::processExamples(@ARGV);
640}
641
724aa791 6421;
643
644__END__
645
646=head1 mkCheckRex
647
648mkCheckRex receives the full testcase object, and constructs a regex.
6491st, it selects a reftxt from either the expect or expect_nt items.
650
cc02ea56 651Once selected, reftext is massaged & converted into a Regex that
652accepts 'good' concise renderings, with appropriate input variations,
653but is otherwise as strict as possible. For example, it should *not*
654match when opcode flags change, or when optimizations convert an op to
655an ex-op.
724aa791 656
657=head2 match criteria
658
659Opcode arguments (text within braces) are disregarded for matching
660purposes. This loses some info in 'add[t5]', but greatly simplifys
661matching 'nextstate(main 22 (eval 10):1)'. Besides, we are testing
662for regressions, not for complete accuracy.
663
cc02ea56 664The regex is anchored by default, but can be suppressed with
665'noanchors', allowing 1-liner tests to succeed if opcode is found.
724aa791 666
cc02ea56 667=head1 TEST DEVELOPMENT SUPPORT
724aa791 668
cc02ea56 669This optree regression testing framework needs tests in order to find
670bugs. To that end, OptreeCheck has support for developing new tests,
671according to the following model:
724aa791 672
cc02ea56 673 1. write a set of sample code into a single file, one per
674 paragraph. f_map and f_sort in ext/B/t/ are examples.
724aa791 675
cc02ea56 676 2. run OptreeCheck as a program on the file
724aa791 677
cc02ea56 678 ./perl -Ilib ext/B/t/OptreeCheck.pm -w ext/B/t/f_map
679 ./perl -Ilib ext/B/t/OptreeCheck.pm -w ext/B/t/f_sort
724aa791 680
cc02ea56 681 gentest reads the sample code, runs each to generate a reference
682 rendering, folds this rendering into an optreeCheck() statement,
683 and prints it to stdout.
724aa791 684
cc02ea56 685 3. run the output file as above, redirect to files, then rerun on
686 same build (for sanity check), and on thread-opposite build. With
687 editor in 1 window, and cmd in other, it's fairly easy to cut-paste
688 the gots into the expects, easier than running step 2 on both
689 builds then trying to sdiff them together.
724aa791 690
cc02ea56 691=head1 TODO
724aa791 692
cc02ea56 693There's a considerable amount of cruft in the whole arg-handling setup.
694I'll replace / strip it before 5.10
724aa791 695
cc02ea56 696Treat %in as a test object, interwork better with Test::*
724aa791 697
cc02ea56 698Refactor mkCheckRex() and selfTest() to isolate the selftest,
699crosstest, etc selection mechanics.
724aa791 700
cc02ea56 701improve retry, retrydbg, esp. it's control of eval "use re debug".
702This seems to work part of the time, but isn't stable enough.
724aa791 703
704=cut