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 single 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 my $opwalker = B::Concise::compile(@opts, $code);
519 die "bad BC::compile retval" unless ref $opwalker eq 'CODE';
521 B::Concise::reset_sequence();
524 # kludge error into rendering if its empty.
525 $rendering = $@ if $@ and ! $rendering;
527 # separate banner, other stuff whose printing order isnt guaranteed
529 $rendering =~ s/(B::Concise::compile.*?\n)//;
530 print "stripped from rendering <$1>\n" if $1 and $tc->{stripv};
532 #while ($rendering =~ s/^(.*?(-e) line \d+\.)\n//g) {
533 while ($rendering =~ s/^(.*?(-e|\(eval \d+\).*?) line \d+\.)\n//g) {
534 print "stripped <$1> $2\n" if $tc->{stripv};
537 $rendering =~ s/-e syntax OK\n//;
538 $rendering =~ s/-e had compilation errors\.\n//;
540 $tc->{got} = $rendering;
541 $tc->{goterrs} = \@errs if @errs;
542 return $rendering, @errs;
546 # collect concise passthru-options if any
550 @opts = (ref $tc->{bcopts} eq 'ARRAY')
551 ? @{$tc->{bcopts}} : ($tc->{bcopts});
557 # check rendering errs against expected errors, reduce and report
560 # check for agreement, by hash (order less important)
562 @goterrs{@{$tc->{goterrs}}} = (1) x scalar @{$tc->{goterrs}};
564 foreach my $k (keys %{$tc->{errs}}) {
565 if (@got = grep /^$k$/, keys %goterrs) {
566 delete $tc->{errs}{$k};
567 delete $goterrs{$_} foreach @got;
570 $tc->{goterrs} = \%goterrs;
573 if (%{$tc->{errs}} or %{$tc->{goterrs}}) {
576 fail("FORCED: $tc->{name}:\n$rendering") if $gOpts{fail}; # silly ?
584 push @lines, "got unexpected:", sort keys %{$tc->{goterrs}} if %{$tc->{goterrs}};
585 push @lines, "missed expected:", sort keys %{$tc->{errs}} if %{$tc->{errs}};
588 unshift @lines, $tc->{name};
589 my $report = join("\n", @lines);
591 if ($gOpts{report} eq 'diag') { _diag ($report) }
592 elsif ($gOpts{report} eq 'fail') { fail ($report) }
593 else { print ($report) }
594 next unless $gOpts{errcont}; # skip block
598 =head1 mkCheckRex ($tc)
600 It selects the correct golden-sample from the test-case object, and
601 converts it into a Regexp which should match against the original
602 golden-sample (used in selftest, see below), and on the renderings
603 obtained by applying the code on the perl being tested.
605 The selection is driven by platform mostly, but also by test-mode,
606 which rather complicates the code. This is worsened by the potential
607 need to make platform specific conversions on the reftext.
609 but is otherwise as strict as possible. For example, it should *not*
610 match when opcode flags change, or when optimizations convert an op to
614 =head2 match criteria
616 The selected golden-sample is massaged to eliminate various match
617 irrelevancies. This is done so that the tests dont fail just because
618 you added a line to the top of the test file. (Recall that the
619 renderings contain the program's line numbers). Similar cleanups are
620 done on "strings", hex-constants, etc.
622 The need to massage is reflected in the 2 golden-sample approach of
623 the test-cases; we want the match to be as rigorous as possible, and
624 thats easier to achieve when matching against 1 input than 2.
626 Opcode arguments (text within braces) are disregarded for matching
627 purposes. This loses some info in 'add[t5]', but greatly simplifies
628 matching 'nextstate(main 22 (eval 10):1)'. Besides, we are testing
629 for regressions, not for complete accuracy.
631 The regex is anchored by default, but can be suppressed with
632 'noanchors', allowing 1-liner tests to succeed if opcode is found.
636 # needless complexity due to 'too much info' from B::Concise v.60
637 my $announce = 'B::Concise::compile\(CODE\(0x[0-9a-f]+\)\)';;
640 # converts expected text into Regexp which should match against
641 # unaltered version. also adjusts threaded => non-threaded
642 my ($tc, $want) = @_;
643 eval "no re 'debug'";
645 my $str = $tc->{expect} || $tc->{expect_nt}; # standard bias
646 $str = $tc->{$want} if $want && $tc->{$want}; # stated pref
648 die("no '$want' golden-sample found: $tc->{name}") unless $str;
650 $str =~ s/^\# //mg; # ease cut-paste testcase authoring
653 # add 5.8 private flags, which bleadperl (5.9.1) doesn't have/use/render
654 # works because it adds no wildcards, which are butchered below..
655 $str =~ s|(mapstart l?K\*?)|$1/2|mg;
656 $str =~ s|(grepstart l?K\*?)|$1/2|msg;
657 $str =~ s|(mapwhile.*? l?K)|$1/1|msg;
658 $str =~ s|(grepwhile.*? l?K)|$1/1|msg;
660 $tc->{wantstr} = $str;
662 # make targ args wild
663 $str =~ s/\[t\d+\]/[t\\d+]/msg;
665 # escape bracing, etc.. manual \Q (doesnt escape '+')
666 $str =~ s/([\[\]()*.\$\@\#\|{}])/\\$1/msg;
667 # $str =~ s/(?<!\\)([\[\]\(\)*.\$\@\#\|{}])/\\$1/msg;
669 # treat dbstate like nextstate (no in-debugger false reports)
670 $str =~ s/(?:next|db)state(\\\(.*?\\\))/(?:next|db)state(.*?)/msg;
671 # widened for -terse mode
672 $str =~ s/(?:next|db)state/(?:next|db)state/msg;
675 $str =~ s/:-?\d+,-?\d+/:-?\\d+,-?\\d+/msg; # FAKE line numbers
676 $str =~ s/match\\\(.*?\\\)/match\(.*?\)/msg; # match args
677 $str =~ s/(0x[0-9A-Fa-f]+)/0x[0-9A-Fa-f]+/msg; # hexnum values
678 $str =~ s/".*?"/".*?"/msg; # quoted strings
680 $str =~ s/(\d refs?)/\\d+ refs?/msg; # 1 ref, 2+ refs (plural)
681 $str =~ s/leavesub \[\d\]/leavesub [\\d]/msg; # for -terse
682 #$str =~ s/(\s*)\n/\n/msg; # trailing spaces
684 croak "no reftext found for $want: $tc->{name}"
685 unless $str =~ /\w+/; # fail unless a real test
687 # $str = '.*' if 1; # sanity test
688 # $str .= 'FAIL' if 1; # sanity test
690 # allow -eval, banner at beginning of anchored matches
691 $str = "(-e .*?)?(B::Concise::compile.*?)?\n" . $str
692 unless $tc->{noanchors} or $tc->{rxnoorder};
694 eval "use re 'debug'" if $debug;
695 my $qr = ($tc->{noanchors}) ? qr/$str/ms : qr/^$str$/ms ;
699 $tc->{rexstr} = $str;
707 # reworked mylike to use hash-obj
709 my $got = $tc->{got};
710 my $want = $tc->{rex};
711 my $cmnt = $tc->{name};
712 my $cross = $tc->{cross};
714 my $msgs = $tc->{msgs};
715 my $retry = $tc->{retry}; # || $gopts{retry};
716 my $debug = $tc->{debug}; #|| $gopts{retrydbg};
718 # bad is anticipated failure
719 my $bad = (0 or ( $cross && $tc->{crossfail})
720 or (!$cross && $tc->{fail})
723 # same as A ^ B, but B has side effects
724 my $ok = ( $bad && unlike ($got, $want, $cmnt, @$msgs)
725 or !$bad && like ($got, $want, $cmnt, @$msgs));
727 reduceDiffs ($tc) if not $ok;
729 if (not $ok and $retry) {
730 # redo, perhaps with use re debug - NOT ROBUST
731 eval "use re 'debug'" if $debug;
732 $ok = ( $bad && unlike ($got, $want, "(RETRY) $cmnt", @$msgs)
733 or !$bad && like ($got, $want, "(RETRY) $cmnt", @$msgs));
734 eval "no re 'debug'";
740 # isolate the real diffs and report them.
741 # i.e. these kinds of errs:
742 # 1. missing or extra ops. this skews all following op-sequences
743 # 2. single op diff, the rest of the chain is unaltered
744 # in either case, std err report is inadequate;
747 my $got = $tc->{got};
748 my @got = split(/\n/, $got);
749 my $want = $tc->{wantstr};
750 my @want = split(/\n/, $want);
752 # split rexstr into units that should eat leading lines.
753 my @rexs = map qr/$_/, split (/\n/, $tc->{rexstr});
755 foreach my $rex (@rexs) {
756 my $exp = shift @want;
757 my $line = shift @got;
758 # remove matches, and report
759 unless ($got =~ s/($rex\n)//msg) {
760 _diag("got:\t\t'$line'\nwant:\t $rex\n");
763 _diag("remainder:\n$got");
764 _diag("these lines not matched:\n$got\n");
769 Unusually, this module also processes @ARGV for command-line arguments
770 which set global modes. These 'options' change the way the tests run,
771 essentially reusing the tests for different purposes.
775 Additionally, there's an experimental control-arg interface (i.e.
776 subject to change) which allows the user to set global modes.
779 =head1 Testing Method
781 At 1st, optreeCheck used one reference-text, but the differences
782 between Threaded and Non-threaded renderings meant that a single
783 reference (sampled from say, threaded) would be tricky and iterative
784 to convert for testing on a non-threaded build. Worse, this conflicts
785 with making tests both strict and precise.
787 We now use 2 reference texts, the right one is used based upon the
788 build's threaded-ness. This has several benefits:
790 1. native reference data allows closer/easier matching by regex.
791 2. samples can be eyeballed to grok T-nT differences.
792 3. data can help to validate mkCheckRex() operation.
793 4. can develop regexes which accommodate T-nT differences.
794 5. can test with both native and cross-converted regexes.
796 Cross-testing (expect_nt on threaded, expect on non-threaded) exposes
797 differences in B::Concise output, so mkCheckRex has code to do some
798 cross-test manipulations. This area needs more work.
802 One consequence of a single-function API is difficulty controlling
803 test-mode. I've chosen for now to use a package hash, %gOpts, to store
804 test-state. These properties alter checkOptree() function, either
805 short-circuiting to selftest, or running a loop that runs the testcase
806 2^N times, varying conditions each time. (current N is 2 only).
808 So Test-mode is controlled with cmdline args, also called options below.
809 Run with 'help' to see the test-state, and how to change it.
813 This argument invokes runSelftest(), which tests a regex against the
814 reference renderings that they're made from. Failure of a regex match
815 its 'mold' is a strong indicator that mkCheckRex is buggy.
817 That said, selftest mode currently runs a cross-test too, they're not
818 completely orthogonal yet. See below.
820 =head2 testmode=cross
822 Cross-testing is purposely creating a T-NT mismatch, looking at the
823 fallout, which helps to understand the T-NT differences.
825 The tweaking appears contrary to the 2-refs philosophy, but the tweaks
826 will be made in conversion-specific code, which (will) handles T->NT
827 and NT->T separately. The tweaking is incomplete.
829 A reasonable 1st step is to add tags to indicate when TonNT or NTonT
830 is known to fail. This needs an option to force failure, so the
831 test.pl reporting mechanics show results to aid the user.
833 =head2 testmode=native
835 This is normal mode. Other valid values are: native, cross, both.
837 =head2 checkOptree Notes
839 Accepts test code, renders its optree using B::Concise, and matches
840 that rendering against a regex built from one of 2 reference
843 The regex is built by mkCheckRex(\%tc), which scrubs %tc data to
844 remove match-irrelevancies, such as (args) and [args]. For example,
845 it strips leading '# ', making it easy to cut-paste new tests into
846 your test-file, run it, and cut-paste actual results into place. You
847 then retest and reedit until all 'errors' are gone. (now make sure you
848 haven't 'enshrined' a bug).
850 name: The test name. May be augmented by a label, which is built from
851 important params, and which helps keep names in sync with whats being
857 # tests the regex produced by mkCheckRex()
858 # by using on the expect* text it was created with
859 # failures indicate a code bug,
860 # OR regexs plugged into the expect* text (which defeat conversions)
863 for my $provenance (qw/ expect expect_nt /) {
864 #next unless $tc->{$provenance};
866 $tc->mkCheckRex($provenance);
867 $tc->{got} = $tc->{wantstr}; # fake the rendering
876 do { Dumper(@_); return } if $dumploaded;
878 eval "require Data::Dumper"
880 print "Sorry, Data::Dumper is not available\n";
881 print "half hearted attempt:\n";
883 if (ref $it eq 'HASH') {
884 print " $_ => $it->{$_}\n" foreach sort keys %$it;
890 Data::Dumper->import;
891 $Data::Dumper::Sortkeys = 1;
896 ############################
897 # support for test writing
900 my $testct = shift || 1;
906 \@INC = qw(../lib ../ext/B/t);
907 require q(./test.pl);
910 plan tests => $testct;
916 sub OptreeCheck::wrap {
918 $code =~ s/(?:(\#.*?)\n)//gsm;
919 $code =~ s/\s+/ /mgs;
921 return unless $code =~ /\S/;
926 checkOptree(note => q{$comment},
929 expect => <<EOT_EOT, expect_nt => <<EONT_EONT);
931 paste your 'golden-example' here, then retest
934 paste your 'golden-example' here, then retest
941 sub OptreeCheck::gentest {
942 my ($code,$opts) = @_;
943 my $rendering = getRendering({code => $code});
944 my $testcode = OptreeCheck::wrap($code);
945 return unless $testcode;
947 # run the prog, capture 'reference' concise output
948 my $preamble = preamble(1);
949 my $got = runperl( prog => "$preamble $testcode", stderr => 1,
950 #switches => ["-I../ext/B/t", "-MOptreeCheck"],
953 # extract the 'reftext' ie the got 'block'
954 if ($got =~ m/got \'.*?\n(.*)\n\# \'\n\# expected/s) {
956 #and plug it into the test-src
958 $testcode =~ s/ThreadedRef/$goldentxt/;
960 $testcode =~ s/NonThreadRef/$goldentxt/;
962 my $b4 = q{expect => <<EOT_EOT, expect_nt => <<EONT_EONT};
963 my $af = q{expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'};
964 $testcode =~ s/$b4/$af/;
967 if ($internal_retest) {
968 $got = runperl( prog => "$preamble $testcode", stderr => 1,
969 #switches => ["-I../ext/B/t", "-MOptreeCheck"],
979 sub OptreeCheck::processExamples {
982 # gets array of paragraphs, which should be code-samples. Theyre
983 # turned into optreeCheck tests,
985 foreach my $file (@files) {
986 open (my $fh, $file) or die "cant open $file: $!\n";
989 print preamble (scalar @chunks);
990 foreach $t (@chunks) {
991 print "\n\n=for gentest\n\n# chunk: $t=cut\n\n";
992 print OptreeCheck::gentest ($t);
997 # OK - now for the final insult to your good taste...
999 if ($0 =~ /OptreeCheck\.pm/) {
1002 require './t/test.pl';
1004 # invoked as program. Work like former gentest.pl,
1005 # ie read files given as cmdline args,
1006 # convert them to usable test files.
1008 require Getopt::Std;
1009 Getopt::Std::getopts('') or
1010 die qq{ $0 sample-files* # no options
1012 expecting filenames as args. Each should have paragraphs,
1013 these are converted to checkOptree() tests, and printed to
1014 stdout. Redirect to file then edit for test. \n};
1016 OptreeCheck::processExamples(@ARGV);
1023 =head1 TEST DEVELOPMENT SUPPORT
1025 This optree regression testing framework needs tests in order to find
1026 bugs. To that end, OptreeCheck has support for developing new tests,
1027 according to the following model:
1029 1. write a set of sample code into a single file, one per
1030 paragraph. Add <=for gentest> blocks if you care to, or just look at
1031 f_map and f_sort in ext/B/t/ for examples.
1033 2. run OptreeCheck as a program on the file
1035 ./perl -Ilib ext/B/t/OptreeCheck.pm -w ext/B/t/f_map
1036 ./perl -Ilib ext/B/t/OptreeCheck.pm -w ext/B/t/f_sort
1038 gentest reads the sample code, runs each to generate a reference
1039 rendering, folds this rendering into an optreeCheck() statement,
1040 and prints it to stdout.
1042 3. run the output file as above, redirect to files, then rerun on
1043 same build (for sanity check), and on thread-opposite build. With
1044 editor in 1 window, and cmd in other, it's fairly easy to cut-paste
1045 the gots into the expects, easier than running step 2 on both
1046 builds then trying to sdiff them together.
1050 This code is purely for testing core. While checkOptree feels flexible
1051 enough to be stable, the whole selftest framework is subject to change