7 # now export checkOptree, and those test.pl functions used by tests
8 our @EXPORT = qw( checkOptree plan skip skip_all pass is like unlike
14 OptreeCheck - check optrees as rendered by B::Concise
18 OptreeCheck supports 'golden-sample' regression testing of perl's
19 parser, optimizer, bytecode generator, via a single function:
22 It invokes B::Concise upon the sample code, checks that the rendering
23 'agrees' with the golden sample, and reports mismatches.
25 Additionally, the module processes @ARGV (which is typically unused in
26 the Core test harness), and thus provides a means to run the tests in
36 name => "test-name', # optional, made from others if not given
38 # code-under-test: must provide 1 of them
39 code => sub {my $a}, # coderef, or source (wrapped and evald)
40 prog => 'sort @a', # run in subprocess, aka -MO=Concise
41 bcopts => '-exec', # $opt or \@opts, passed to BC::compile
43 errs => 'Useless variable "@main::a" .*' # str, regex, [str+] [regex+],
45 # various test options
46 # errs => '.*', # match against any emitted errs, -w warnings
47 # skip => 1, # skips test
48 # todo => 'excuse', # anticipated failures
49 # fail => 1 # force fail (by redirecting result)
50 # retry => 1 # retry on test failure
51 # debug => 1, # use re 'debug' for retried failures !!
53 # the 'golden-sample's, (must provide both)
55 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT' ); # start HERE-DOCS
56 # 1 <;> nextstate(main 45 optree.t:23) v
57 # 2 <0> padsv[$a:45,46] M/LVINTRO
58 # 3 <1> leavesub[1 ref] K/REFC,1
60 # 1 <;> nextstate(main 45 optree.t:23) v
61 # 2 <0> padsv[$a:45,46] M/LVINTRO
62 # 3 <1> leavesub[1 ref] K/REFC,1
67 =head2 Failure Reports
69 Heres a sample failure, as induced by the following command.
70 Note the argument; option=value, after the test-file, more on that later
72 $> PERL_CORE=1 ./perl ext/B/t/optree_check.t testmode=cross
74 ok 19 - canonical example w -basic
75 not ok 20 - -exec code: $a=$b+42
76 # Failed at test.pl line 249
77 # got '1 <;> nextstate(main 600 optree_check.t:208) v
79 # 3 <$> const[IV 42] s
83 # 7 <1> leavesub[1 ref] K/REFC,1
85 # expected /(?ms-xi:^1 <;> (?:next|db)state(.*?) v
86 # 2 <\$> gvsv\(\*b\) s
87 # 3 <\$> const\(IV 42\) s
88 # 4 <2> add\[t\d+\] sK/2
89 # 5 <\$> gvsv\(\*a\) s
91 # 7 <1> leavesub\[\d+ refs?\] K/REFC,1
93 # got: '2 <#> gvsv[*b] s'
94 # want: (?-xism:2 <\$> gvsv\(\*b\) s)
95 # got: '3 <$> const[IV 42] s'
96 # want: (?-xism:3 <\$> const\(IV 42\) s)
97 # got: '5 <#> gvsv[*a] s'
98 # want: (?-xism:5 <\$> gvsv\(\*a\) s)
101 # 3 <$> const[IV 42] s
103 # these lines not matched:
105 # 3 <$> const[IV 42] s
108 Errors are reported 3 different ways;
110 The 1st form is directly from test.pl's like() and unlike(). Note
111 that this form is used as input, so you can easily cut-paste results
112 into test-files you are developing. Just make sure you recognize
113 insane results, to avoid canonizing them as golden samples.
115 The 2nd and 3rd forms show only the unexpected results and opcodes.
116 This is done because it's blindingly tedious to find a single opcode
117 causing the failure. 2 different ways are done in case one is
120 =head1 TestCase Overview
122 checkOptree(%tc) constructs a testcase object from %tc, and then calls
123 methods which eventually call test.pl's like() to produce test
128 getRendering() runs code or prog through B::Concise, and captures its
129 rendering. Errors emitted during rendering are checked against
130 expected errors, and are reported as diagnostics by default, or as
131 failures if 'report=fail' cmdline-option is given.
133 prog is run in a sub-shell, with $bcopts passed through. This is the way
134 to run code intended for main. The code arg in contrast, is always a
135 CODEREF, either because it starts that way as an arg, or because it's
136 wrapped and eval'd as $sub = sub {$code};
140 mkCheckRex() selects the golden-sample for the threaded-ness of the
141 platform, and produces a regex which matches the expected rendering,
142 and fails when it doesn't match.
144 The regex includes 'workarounds' which accommodate expected rendering
145 variations. These include:
147 string constants # avoid injection
148 line numbers, etc # args of nexstate()
151 pad-slot-assignments # for 5.8 compat, and testmode=cross
152 (map|grep)(start|while) # for 5.8 compat
156 mylike() calls either unlike() or like(), depending on
157 expectations. Mismatch reports are massaged, because the actual
158 difference can easily be lost in the forest of opcodes.
160 =head1 checkOptree API and Operation
162 Since the arg is a hash, the api is wide-open, and this really is
163 about what elements must be or are in the hash, and what they do. %tc
164 is passed to newTestCase(), the ctor, which adds in %proto, a global
167 =head2 name => STRING
169 If name property is not provided, it is synthesized from these params:
170 bcopts, note, prog, code. This is more convenient than trying to do
175 Either code or prog must be present.
177 =head2 prog => $perl_source_string
179 prog => $src provides a snippet of code, which is run in a sub-process,
180 via test.pl:runperl, and through B::Concise like so:
182 './perl -w -MO=Concise,$bcopts_massaged -e $src'
184 =head2 code => $perl_source_string || CODEREF
186 The $code arg is passed to B::Concise::compile(), and run in-process.
187 If $code is a string, it's first wrapped and eval'd into a $coderef.
188 In either case, $coderef is then passed to B::Concise::compile():
190 $subref = eval "sub{$code}";
191 $render = B::Concise::compile($subref)->();
193 =head2 expect and expect_nt
195 expect and expect_nt args are the B<golden-sample> renderings, and are
196 sampled from known-ok threaded and un-threaded bleadperl (5.9.1) builds.
197 They're both required, and the correct one is selected for the platform
198 being tested, and saved into the synthesized property B<wanted>.
200 =head2 bcopts => $bcopts || [ @bcopts ]
202 When getRendering() runs, it passes bcopts into B::Concise::compile().
203 The bcopts arg can be a singls string, or an array of strings.
205 =head2 errs => $err_str_regex || [ @err_str_regexs ]
207 getRendering() processes the code or prog arg under warnings, and both
208 parsing and optree-traversal errors are collected. These are
209 validated against the one or more errors you specify.
211 =head1 testcase modifier properties
213 These properties are set as %tc parameters to change test behavior.
215 =head2 skip => 'reason'
217 invokes skip('reason'), causing test to skip.
219 =head2 todo => 'reason'
221 invokes todo('reason')
225 For code arguments, this option causes getRendering to redirect the
226 rendering operation to STDERR, which causes the regex match to fail.
230 If retry is set, and a test fails, it is run a second time, possibly
235 If a failure is retried, this turns on eval "use re 'debug'", thus
236 turning on regex debug. It's quite verbose, and not hugely helpful.
238 =head2 noanchors => 1
240 If set, this relaxes the regex check, which is normally pretty strict.
241 It's used primarily to validate checkOptree via tests in optree_check.
244 =head1 Synthesized object properties
246 These properties are added into the test object during execution.
250 This stores the chosen expect expect_nt string. The OptreeCheck
251 object may in the future delete the raw strings once wanted is set,
256 This tag is added if testmode=cross is passed in as argument.
257 It causes test-harness to purposely use the wrong string.
262 checkErrs() is a getRendering helper that verifies that expected errs
263 against those found when rendering the code on the platform. It is
264 run after rendering, and before mkCheckRex.
266 Errors can be reported 3 different ways; diag, fail, print.
268 diag - uses test.pl _diag()
269 fail - causes double-testing
270 print-.no # in front of the output (may mess up test harnesses)
272 The 3 ways are selectable at runtimve via cmdline-arg:
273 report={diag,fail,print}.
281 use B::Concise qw(walk_output);
284 $SIG{__WARN__} = sub {
286 $err =~ m/Subroutine re::(un)?install redefined/ and return;
292 $pkg->export_to_level(1,'checkOptree', @EXPORT);
293 getCmdLine(); # process @ARGV
297 # %gOpts params comprise a global test-state. Initial values here are
298 # HELP strings, they MUST BE REPLACED by runtime values before use, as
299 # is done by getCmdLine(), via import
301 our %gOpts = # values are replaced at runtime !!
303 # scalar values are help string
304 retry => 'retry failures after turning on re debug',
305 debug => 'turn on re debug for those retries',
306 selftest => 'self-tests mkCheckRex vs the reference rendering',
308 fail => 'force all test to fail, print to stdout',
309 dump => 'dump cmdline arg prcessing',
310 noanchors => 'dont anchor match rex',
312 # array values are one-of selections, with 1st value as default
313 # array: 2nd value is used as help-str, 1st val (still) default
314 help => [0, 'provides help and exits', 0],
315 testmode => [qw/ native cross both /],
317 # reporting mode for rendering errs
318 report => [qw/ diag fail print /],
319 errcont => [1, 'if 1, tests match even if report is fail', 0],
321 # fixup for VMS, cygwin, which dont have stderr b4 stdout
322 rxnoorder => [1, 'if 1, dont req match on -e lines, and -banner',0],
323 strip => [1, 'if 1, catch errs and remove from renderings',0],
324 stripv => 'if strip&&1, be verbose about it',
325 errs => 'expected compile errs, array if several',
329 # Not sure if this is too much cheating. Officially we say that
330 # $Config::Config{usethreads} is true if some sort of threading is in
331 # use, in which case we ought to be able to use it in place of the ||
332 # below. However, it is now possible to Configure perl with "threads"
333 # but neither ithreads or 5005threads, which forces the re-entrant
334 # APIs, but no perl user visible threading.
336 # This seems to have the side effect that most of perl doesn't think
337 # that it's threaded, hence the ops aren't threaded either. Not sure
338 # if this is actually a "supported" configuration, but given that
339 # ponie uses it, it's going to be used by something official at least
340 # in the interim. So it's nice for tests to all pass.
343 if $Config::Config{useithreads} || $Config::Config{use5005threads};
344 our $platform = ($threaded) ? "threaded" : "plain";
345 our $thrstat = ($threaded) ? "threaded" : "nonthreaded";
348 both => [ 'expect', 'expect_nt'],
349 native => [ ($threaded) ? 'expect' : 'expect_nt'],
350 cross => [ !($threaded) ? 'expect' : 'expect_nt'],
351 expect => [ 'expect' ],
352 expect_nt => [ 'expect_nt' ],
355 our %msgs # announce cross-testing.
358 'expect_nt-threaded' => " (nT on T) ",
359 'expect-nonthreaded' => " (T on nT) ",
360 # native - nothing to say (must stay empty - used for $crosstesting)
361 'expect_nt-nonthreaded' => '',
362 'expect-threaded' => '',
366 sub getCmdLine { # import assistant
368 print(qq{\n$0 accepts args to update these state-vars:
369 turn on a flag by typing its name,
370 select a value from list by typing name=val.\n },
372 if grep /help/, @ARGV;
374 # replace values for each key !! MUST MARK UP %gOpts
375 foreach my $opt (keys %gOpts) {
377 # scan ARGV for known params
378 if (ref $gOpts{$opt} eq 'ARRAY') {
380 # $opt is a One-Of construct
381 # replace with valid selection from the list
383 # uhh this WORKS. but it's inscrutable
384 # grep s/$opt=(\w+)/grep {$_ eq $1} @ARGV and $gOpts{$opt}=$1/e, @ARGV;
386 if (grep s/$opt=(\w+)/$tval=$1/e, @ARGV) {
387 # check val before accepting
388 my @allowed = @{$gOpts{$opt}};
389 if (grep { $_ eq $tval } @allowed) {
390 $gOpts{$opt} = $tval;
392 else {die "invalid value: '$tval' for $opt\n"}
395 # take 1st val as default
396 $gOpts{$opt} = ${$gOpts{$opt}}[0]
397 if ref $gOpts{$opt} eq 'ARRAY';
399 else { # handle scalars
401 # if 'opt' is present, true
402 $gOpts{$opt} = (grep /^$opt/, @ARGV) ? 1 : 0;
404 # override with 'foo' if 'opt=foo' appears
405 grep s/$opt=(.*)/$gOpts{$opt}=$1/e, @ARGV;
408 print("$0 heres current state:\n", mydumper(\%gOpts))
409 if $gOpts{help} or $gOpts{dump};
411 exit if $gOpts{help};
413 # the above arg-handling cruft should be replaced by a Getopt call
415 ##############################
416 # the API (1 function)
419 my $tc = newTestCases(@_); # ctor
422 print "checkOptree args: ",mydumper($tc) if $tc->{dump};
424 skip("$tc->{skip} $tc->{name}", 1) if $tc->{skip};
426 return runSelftest($tc) if $gOpts{selftest};
428 $tc->getRendering(); # get the actual output
432 foreach $want (@{$modes{$gOpts{testmode}}}) {
433 local $TODO = $tc->{todo} if $tc->{todo};
435 $tc->{cross} = $msgs{"$want-$thrstat"};
437 $tc->mkCheckRex($want);
445 # make test objects (currently 1) from args (passed to checkOptree)
446 my $tc = bless { @_ }, __PACKAGE__
447 or die "test cases are hashes";
451 # cpy globals into each test
452 foreach $k (keys %gOpts) {
454 $tc->{$k} = $gOpts{$k} unless defined $tc->{$k};
457 # transform errs to self-hash for efficient set-math
459 if (not ref $tc->{errs}) {
460 $tc->{errs} = { $tc->{errs} => 1};
462 elsif (ref $tc->{errs} eq 'ARRAY') {
464 @errs{@{$tc->{errs}}} = (1) x @{$tc->{errs}};
465 $tc->{errs} = \%errs;
467 elsif (ref $tc->{errs} eq 'Regexp') {
468 warn "regexp err matching not yet implemented";
475 # may help get/keep test output consistent
477 return $tc->{name} if $tc->{name};
479 my $buf = (ref $tc->{bcopts})
480 ? join(',', @{$tc->{bcopts}}) : $tc->{bcopts};
482 foreach (qw( note prog code )) {
483 $buf .= " $_: $tc->{$_}" if $tc->{$_} and not ref $tc->{$_};
485 return $tc->{name} = $buf;
489 # render and its helpers
493 fail("getRendering: code or prog is required")
494 unless $tc->{code} or $tc->{prog};
496 my @opts = get_bcopts($tc);
497 my $rendering = ''; # suppress "Use of uninitialized value in open"
498 my @errs; # collect errs via
502 $rendering = runperl( switches => ['-w',join(',',"-MO=Concise",@opts)],
503 prog => $tc->{prog}, stderr => 1,
506 my $code = $tc->{code};
507 unless (ref $code eq 'CODE') {
508 # treat as source, and wrap into subref
509 # in caller's package ( to test arg-fixup, comment next line)
510 my $pkg = '{ package '.caller(1) .';';
511 $code = eval "$pkg sub { $code } }";
513 if ($@) { chomp $@; push @errs, $@ }
515 # set walk-output b4 compiling, which writes 'announce' line
516 walk_output(\$rendering);
518 fail("forced failure: stdout follows");
519 walk_output(\*STDOUT);
521 my $opwalker = B::Concise::compile(@opts, $code);
522 die "bad BC::compile retval" unless ref $opwalker eq 'CODE';
524 B::Concise::reset_sequence();
527 # kludge error into rendering if its empty.
528 $rendering = $@ if $@ and ! $rendering;
530 # separate banner, other stuff whose printing order isnt guaranteed
532 $rendering =~ s/(B::Concise::compile.*?\n)//;
533 print "stripped from rendering <$1>\n" if $1 and $tc->{stripv};
535 #while ($rendering =~ s/^(.*?(-e) line \d+\.)\n//g) {
536 while ($rendering =~ s/^(.*?(-e|\(eval \d+\).*?) line \d+\.)\n//g) {
537 print "stripped <$1> $2\n" if $tc->{stripv};
540 $rendering =~ s/-e syntax OK\n//;
541 $rendering =~ s/-e had compilation errors\.\n//;
543 $tc->{got} = $rendering;
544 $tc->{goterrs} = \@errs if @errs;
545 return $rendering, @errs;
549 # collect concise passthru-options if any
553 @opts = (ref $tc->{bcopts} eq 'ARRAY')
554 ? @{$tc->{bcopts}} : ($tc->{bcopts});
560 # check rendering errs against expected errors, reduce and report
563 # check for agreement, by hash (order less important)
565 @goterrs{@{$tc->{goterrs}}} = (1) x scalar @{$tc->{goterrs}};
567 foreach my $k (keys %{$tc->{errs}}) {
568 if (@got = grep /^$k$/, keys %goterrs) {
569 delete $tc->{errs}{$k};
570 delete $goterrs{$_} foreach @got;
573 $tc->{goterrs} = \%goterrs;
576 if (%{$tc->{errs}} or %{$tc->{goterrs}}) {
579 fail("FORCED: $tc->{name}:\n$rendering") if $gOpts{fail}; # silly ?
587 push @lines, "got unexpected:", sort keys %{$tc->{goterrs}} if %{$tc->{goterrs}};
588 push @lines, "missed expected:", sort keys %{$tc->{errs}} if %{$tc->{errs}};
591 unshift @lines, $tc->{name};
592 my $report = join("\n", @lines);
594 if ($gOpts{report} eq 'diag') { _diag ($report) }
595 elsif ($gOpts{report} eq 'fail') { fail ($report) }
596 else { print ($report) }
597 next unless $gOpts{errcont}; # skip block
601 =head1 mkCheckRex ($tc)
603 It selects the correct golden-sample from the test-case object, and
604 converts it into a Regexp which should match against the original
605 golden-sample (used in selftest, see below), and on the renderings
606 obtained by applying the code on the perl being tested.
608 The selection is driven by platform mostly, but also by test-mode,
609 which rather complicates the code. This is worsened by the potential
610 need to make platform specific conversions on the reftext.
612 but is otherwise as strict as possible. For example, it should *not*
613 match when opcode flags change, or when optimizations convert an op to
617 =head2 match criteria
619 The selected golden-sample is massaged to eliminate various match
620 irrelevancies. This is done so that the tests dont fail just because
621 you added a line to the top of the test file. (Recall that the
622 renderings contain the program's line numbers). Similar cleanups are
623 done on "strings", hex-constants, etc.
625 The need to massage is reflected in the 2 golden-sample approach of
626 the test-cases; we want the match to be as rigorous as possible, and
627 thats easier to achieve when matching against 1 input than 2.
629 Opcode arguments (text within braces) are disregarded for matching
630 purposes. This loses some info in 'add[t5]', but greatly simplifys
631 matching 'nextstate(main 22 (eval 10):1)'. Besides, we are testing
632 for regressions, not for complete accuracy.
634 The regex is anchored by default, but can be suppressed with
635 'noanchors', allowing 1-liner tests to succeed if opcode is found.
639 # needless complexity due to 'too much info' from B::Concise v.60
640 my $announce = 'B::Concise::compile\(CODE\(0x[0-9a-f]+\)\)';;
643 # converts expected text into Regexp which should match against
644 # unaltered version. also adjusts threaded => non-threaded
645 my ($tc, $want) = @_;
646 eval "no re 'debug'";
648 my $str = $tc->{expect} || $tc->{expect_nt}; # standard bias
649 $str = $tc->{$want} if $want && $tc->{$want}; # stated pref
651 die("no '$want' golden-sample found: $tc->{name}") unless $str;
653 $str =~ s/^\# //mg; # ease cut-paste testcase authoring
656 # add 5.8 private flags, which bleadperl (5.9.1) doesn't have/use/render
657 # works because it adds no wildcards, which are butchered below..
658 $str =~ s|(mapstart l?K\*?)|$1/2|mg;
659 $str =~ s|(grepstart l?K\*?)|$1/2|msg;
660 $str =~ s|(mapwhile.*? l?K)|$1/1|msg;
661 $str =~ s|(grepwhile.*? l?K)|$1/1|msg;
663 $tc->{wantstr} = $str;
665 # convert all (args) and [args] to temp forms wo bracing
666 $str =~ s/\[(.*?)\]/__CAPSQR$1__/msg;
667 $str =~ s/\((.*?)\)/__CAPRND$1__/msg;
668 $str =~ s/\((.*?)\)/__CAPRND$1__/msg; # nested () in nextstate
670 # escape bracing, etc.. manual \Q (doesnt escape '+')
671 $str =~ s/([\[\]()*.\$\@\#\|{}])/\\$1/msg;
673 # now replace temp forms with original, preserving reference bracing
674 $str =~ s/__CAPSQR(.*?)__\b/\\[$1\\]/msg; # \b is important
675 $str =~ s/__CAPRND(.*?)__\b/\\($1\\)/msg;
676 $str =~ s/__CAPRND(.*?)__\b/\\($1\\)/msg; # nested () in nextstate
678 # treat dbstate like nextstate (no in-debugger false reports)
679 $str =~ s/(?:next|db)state(\\\(.*?\\\))/(?:next|db)state(.*?)/msg;
680 # widened for -terse mode
681 $str =~ s/(?:next|db)state/(?:next|db)state/msg;
684 $str =~ s/:-?\d+,-?\d+/:-?\\d+,-?\\d+/msg; # FAKE line numbers
685 $str =~ s/match\\\(.*?\\\)/match\(.*?\)/msg; # match args
686 $str =~ s/(0x[0-9A-Fa-f]+)/0x[0-9A-Fa-f]+/msg; # hexnum values
687 $str =~ s/".*?"/".*?"/msg; # quoted strings
689 $str =~ s/(\d refs?)/\\d+ refs?/msg; # 1 ref, 2+ refs (plural)
690 $str =~ s/leavesub \[\d\]/leavesub [\\d]/msg; # for -terse
691 #$str =~ s/(\s*)\n/\n/msg; # trailing spaces
693 # these fix up pad-slot assignment args
694 if ($] < 5.009 or $tc->{cross}) {
695 $str =~ s/\[t\d+\\]/\[t\\d+\\]/msg; # pad slot assignments
698 croak "no reftext found for $want: $tc->{name}"
699 unless $str =~ /\w+/; # fail unless a real test
701 # $str = '.*' if 1; # sanity test
702 # $str .= 'FAIL' if 1; # sanity test
704 # allow -eval, banner at beginning of anchored matches
705 $str = "(-e .*?)?(B::Concise::compile.*?)?\n" . $str
706 unless $tc->{noanchors} or $tc->{rxnoorder};
708 eval "use re 'debug'" if $debug;
709 my $qr = ($tc->{noanchors}) ? qr/$str/ms : qr/^$str$/ms ;
713 $tc->{rexstr} = $str;
721 # reworked mylike to use hash-obj
723 my $got = $tc->{got};
724 my $want = $tc->{rex};
725 my $cmnt = $tc->{name};
726 my $cross = $tc->{cross};
728 my $msgs = $tc->{msgs};
729 my $retry = $tc->{retry}; # || $gopts{retry};
730 my $debug = $tc->{debug}; #|| $gopts{retrydbg};
732 # bad is anticipated failure
733 my $bad = (0 or ( $cross && $tc->{crossfail})
734 or (!$cross && $tc->{fail})
737 # same as A ^ B, but B has side effects
738 my $ok = ( $bad && unlike ($got, $want, $cmnt, @$msgs)
739 or !$bad && like ($got, $want, $cmnt, @$msgs));
741 reduceDiffs ($tc) if not $ok;
743 if (not $ok and $retry) {
744 # redo, perhaps with use re debug - NOT ROBUST
745 eval "use re 'debug'" if $debug;
746 $ok = ( $bad && unlike ($got, $want, "(RETRY) $cmnt", @$msgs)
747 or !$bad && like ($got, $want, "(RETRY) $cmnt", @$msgs));
748 eval "no re 'debug'";
754 # isolate the real diffs and report them.
755 # i.e. these kinds of errs:
756 # 1. missing or extra ops. this skews all following op-sequences
757 # 2. single op diff, the rest of the chain is unaltered
758 # in either case, std err report is inadequate;
761 my $got = $tc->{got};
762 my @got = split(/\n/, $got);
763 my $want = $tc->{wantstr};
764 my @want = split(/\n/, $want);
766 # split rexstr into units that should eat leading lines.
767 my @rexs = map qr/$_/, split (/\n/, $tc->{rexstr});
769 foreach my $rex (@rexs) {
770 my $exp = shift @want;
771 my $line = shift @got;
772 # remove matches, and report
773 unless ($got =~ s/($rex\n)//msg) {
774 _diag("got:\t\t'$line'\nwant:\t $rex\n");
777 _diag("remainder:\n$got");
778 _diag("these lines not matched:\n$got\n");
783 Unusually, this module also processes @ARGV for command-line arguments
784 which set global modes. These 'options' change the way the tests run,
785 essentially reusing the tests for different purposes.
789 Additionally, there's an experimental control-arg interface (i.e.
790 subject to change) which allows the user to set global modes.
793 =head1 Testing Method
795 At 1st, optreeCheck used one reference-text, but the differences
796 between Threaded and Non-threaded renderings meant that a single
797 reference (sampled from say, threaded) would be tricky and iterative
798 to convert for testing on a non-threaded build. Worse, this conflicts
799 with making tests both strict and precise.
801 We now use 2 reference texts, the right one is used based upon the
802 build's threaded-ness. This has several benefits:
804 1. native reference data allows closer/easier matching by regex.
805 2. samples can be eyeballed to grok T-nT differences.
806 3. data can help to validate mkCheckRex() operation.
807 4. can develop regexes which accomodate T-nT differences.
808 5. can test with both native and cross-converted regexes.
810 Cross-testing (expect_nt on threaded, expect on non-threaded) exposes
811 differences in B::Concise output, so mkCheckRex has code to do some
812 cross-test manipulations. This area needs more work.
816 One consequence of a single-function API is difficulty controlling
817 test-mode. I've chosen for now to use a package hash, %gOpts, to store
818 test-state. These properties alter checkOptree() function, either
819 short-circuiting to selftest, or running a loop that runs the testcase
820 2^N times, varying conditions each time. (current N is 2 only).
822 So Test-mode is controlled with cmdline args, also called options below.
823 Run with 'help' to see the test-state, and how to change it.
827 This argument invokes runSelftest(), which tests a regex against the
828 reference renderings that they're made from. Failure of a regex match
829 its 'mold' is a strong indicator that mkCheckRex is buggy.
831 That said, selftest mode currently runs a cross-test too, they're not
832 completely orthogonal yet. See below.
834 =head2 testmode=cross
836 Cross-testing is purposely creating a T-NT mismatch, looking at the
837 fallout, which helps to understand the T-NT differences.
839 The tweaking appears contrary to the 2-refs philosophy, but the tweaks
840 will be made in conversion-specific code, which (will) handles T->NT
841 and NT->T separately. The tweaking is incomplete.
843 A reasonable 1st step is to add tags to indicate when TonNT or NTonT
844 is known to fail. This needs an option to force failure, so the
845 test.pl reporting mechanics show results to aid the user.
847 =head2 testmode=native
849 This is normal mode. Other valid values are: native, cross, both.
851 =head2 checkOptree Notes
853 Accepts test code, renders its optree using B::Concise, and matches
854 that rendering against a regex built from one of 2 reference
857 The regex is built by mkCheckRex(\%tc), which scrubs %tc data to
858 remove match-irrelevancies, such as (args) and [args]. For example,
859 it strips leading '# ', making it easy to cut-paste new tests into
860 your test-file, run it, and cut-paste actual results into place. You
861 then retest and reedit until all 'errors' are gone. (now make sure you
862 haven't 'enshrined' a bug).
864 name: The test name. May be augmented by a label, which is built from
865 important params, and which helps keep names in sync with whats being
871 # tests the regex produced by mkCheckRex()
872 # by using on the expect* text it was created with
873 # failures indicate a code bug,
874 # OR regexs plugged into the expect* text (which defeat conversions)
877 for my $provenance (qw/ expect expect_nt /) {
878 #next unless $tc->{$provenance};
880 $tc->mkCheckRex($provenance);
881 $tc->{got} = $tc->{wantstr}; # fake the rendering
890 do { Dumper(@_); return } if $dumploaded;
892 eval "require Data::Dumper"
894 print "Sorry, Data::Dumper is not available\n";
895 print "half hearted attempt:\n";
897 if (ref $it eq 'HASH') {
898 print " $_ => $it->{$_}\n" foreach sort keys %$it;
904 Data::Dumper->import;
905 $Data::Dumper::Sortkeys = 1;
910 ############################
911 # support for test writing
914 my $testct = shift || 1;
920 \@INC = qw(../lib ../ext/B/t);
921 require q(./test.pl);
924 plan tests => $testct;
930 sub OptreeCheck::wrap {
932 $code =~ s/(?:(\#.*?)\n)//gsm;
933 $code =~ s/\s+/ /mgs;
935 return unless $code =~ /\S/;
940 checkOptree(note => q{$comment},
943 expect => <<EOT_EOT, expect_nt => <<EONT_EONT);
945 paste your 'golden-example' here, then retest
948 paste your 'golden-example' here, then retest
955 sub OptreeCheck::gentest {
956 my ($code,$opts) = @_;
957 my $rendering = getRendering({code => $code});
958 my $testcode = OptreeCheck::wrap($code);
959 return unless $testcode;
961 # run the prog, capture 'reference' concise output
962 my $preamble = preamble(1);
963 my $got = runperl( prog => "$preamble $testcode", stderr => 1,
964 #switches => ["-I../ext/B/t", "-MOptreeCheck"],
967 # extract the 'reftext' ie the got 'block'
968 if ($got =~ m/got \'.*?\n(.*)\n\# \'\n\# expected/s) {
970 #and plug it into the test-src
972 $testcode =~ s/ThreadedRef/$goldentxt/;
974 $testcode =~ s/NonThreadRef/$goldentxt/;
976 my $b4 = q{expect => <<EOT_EOT, expect_nt => <<EONT_EONT};
977 my $af = q{expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'};
978 $testcode =~ s/$b4/$af/;
981 if ($internal_retest) {
982 $got = runperl( prog => "$preamble $testcode", stderr => 1,
983 #switches => ["-I../ext/B/t", "-MOptreeCheck"],
993 sub OptreeCheck::processExamples {
996 # gets array of paragraphs, which should be code-samples. Theyre
997 # turned into optreeCheck tests,
999 foreach my $file (@files) {
1000 open (my $fh, $file) or die "cant open $file: $!\n";
1003 print preamble (scalar @chunks);
1004 foreach $t (@chunks) {
1005 print "\n\n=for gentest\n\n# chunk: $t=cut\n\n";
1006 print OptreeCheck::gentest ($t);
1011 # OK - now for the final insult to your good taste...
1013 if ($0 =~ /OptreeCheck\.pm/) {
1016 require './t/test.pl';
1018 # invoked as program. Work like former gentest.pl,
1019 # ie read files given as cmdline args,
1020 # convert them to usable test files.
1022 require Getopt::Std;
1023 Getopt::Std::getopts('') or
1024 die qq{ $0 sample-files* # no options
1026 expecting filenames as args. Each should have paragraphs,
1027 these are converted to checkOptree() tests, and printed to
1028 stdout. Redirect to file then edit for test. \n};
1030 OptreeCheck::processExamples(@ARGV);
1037 =head1 TEST DEVELOPMENT SUPPORT
1039 This optree regression testing framework needs tests in order to find
1040 bugs. To that end, OptreeCheck has support for developing new tests,
1041 according to the following model:
1043 1. write a set of sample code into a single file, one per
1044 paragraph. Add <=for gentest> blocks if you care to, or just look at
1045 f_map and f_sort in ext/B/t/ for examples.
1047 2. run OptreeCheck as a program on the file
1049 ./perl -Ilib ext/B/t/OptreeCheck.pm -w ext/B/t/f_map
1050 ./perl -Ilib ext/B/t/OptreeCheck.pm -w ext/B/t/f_sort
1052 gentest reads the sample code, runs each to generate a reference
1053 rendering, folds this rendering into an optreeCheck() statement,
1054 and prints it to stdout.
1056 3. run the output file as above, redirect to files, then rerun on
1057 same build (for sanity check), and on thread-opposite build. With
1058 editor in 1 window, and cmd in other, it's fairly easy to cut-paste
1059 the gots into the expects, easier than running step 2 on both
1060 builds then trying to sdiff them together.
1064 This code is purely for testing core. While checkOptree feels flexible
1065 enough to be stable, the whole selftest framework is subject to change