5 use vars qw(@open_todo $TODO);
10 # now export checkOptree, and those test.pl functions used by tests
11 our @EXPORT = qw( checkOptree plan skip skip_all pass is like unlike
12 require_ok runperl @open_todo);
15 # This is a bit of a kludge. Really we need to find a way to encode in the
16 # golden results that the hints wll differ because ${^OPEN} is set.
18 if (((caller 0)[10]||{})->{'open<'}) {
19 @open_todo = (skip => "\${^OPEN} is set");
24 OptreeCheck - check optrees as rendered by B::Concise
28 OptreeCheck supports 'golden-sample' regression testing of perl's
29 parser, optimizer, bytecode generator, via a single function:
32 It invokes B::Concise upon the sample code, checks that the rendering
33 'agrees' with the golden sample, and reports mismatches.
35 Additionally, the module processes @ARGV (which is typically unused in
36 the Core test harness), and thus provides a means to run the tests in
46 name => "test-name', # optional, made from others if not given
48 # code-under-test: must provide 1 of them
49 code => sub {my $a}, # coderef, or source (wrapped and evald)
50 prog => 'sort @a', # run in subprocess, aka -MO=Concise
51 bcopts => '-exec', # $opt or \@opts, passed to BC::compile
53 errs => 'Useless variable "@main::a" .*' # str, regex, [str+] [regex+],
55 # various test options
56 # errs => '.*', # match against any emitted errs, -w warnings
57 # skip => 1, # skips test
58 # todo => 'excuse', # anticipated failures
59 # fail => 1 # force fail (by redirecting result)
60 # retry => 1 # retry on test failure
61 # debug => 1, # use re 'debug' for retried failures !!
63 # the 'golden-sample's, (must provide both)
65 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT' ); # start HERE-DOCS
66 # 1 <;> nextstate(main 45 optree.t:23) v
67 # 2 <0> padsv[$a:45,46] M/LVINTRO
68 # 3 <1> leavesub[1 ref] K/REFC,1
70 # 1 <;> nextstate(main 45 optree.t:23) v
71 # 2 <0> padsv[$a:45,46] M/LVINTRO
72 # 3 <1> leavesub[1 ref] K/REFC,1
77 =head2 Failure Reports
79 Heres a sample failure, as induced by the following command.
80 Note the argument; option=value, after the test-file, more on that later
82 $> PERL_CORE=1 ./perl ext/B/t/optree_check.t testmode=cross
84 ok 19 - canonical example w -basic
85 not ok 20 - -exec code: $a=$b+42
86 # Failed at test.pl line 249
87 # got '1 <;> nextstate(main 600 optree_check.t:208) v
89 # 3 <$> const[IV 42] s
93 # 7 <1> leavesub[1 ref] K/REFC,1
95 # expected /(?ms-xi:^1 <;> (?:next|db)state(.*?) v
96 # 2 <\$> gvsv\(\*b\) s
97 # 3 <\$> const\(IV 42\) s
98 # 4 <2> add\[t\d+\] sK/2
99 # 5 <\$> gvsv\(\*a\) s
100 # 6 <2> sassign sKS/2
101 # 7 <1> leavesub\[\d+ refs?\] K/REFC,1
103 # got: '2 <#> gvsv[*b] s'
104 # want: (?-xism:2 <\$> gvsv\(\*b\) s)
105 # got: '3 <$> const[IV 42] s'
106 # want: (?-xism:3 <\$> const\(IV 42\) s)
107 # got: '5 <#> gvsv[*a] s'
108 # want: (?-xism:5 <\$> gvsv\(\*a\) s)
111 # 3 <$> const[IV 42] s
113 # these lines not matched:
115 # 3 <$> const[IV 42] s
118 Errors are reported 3 different ways;
120 The 1st form is directly from test.pl's like() and unlike(). Note
121 that this form is used as input, so you can easily cut-paste results
122 into test-files you are developing. Just make sure you recognize
123 insane results, to avoid canonizing them as golden samples.
125 The 2nd and 3rd forms show only the unexpected results and opcodes.
126 This is done because it's blindingly tedious to find a single opcode
127 causing the failure. 2 different ways are done in case one is
130 =head1 TestCase Overview
132 checkOptree(%tc) constructs a testcase object from %tc, and then calls
133 methods which eventually call test.pl's like() to produce test
138 getRendering() runs code or prog through B::Concise, and captures its
139 rendering. Errors emitted during rendering are checked against
140 expected errors, and are reported as diagnostics by default, or as
141 failures if 'report=fail' cmdline-option is given.
143 prog is run in a sub-shell, with $bcopts passed through. This is the way
144 to run code intended for main. The code arg in contrast, is always a
145 CODEREF, either because it starts that way as an arg, or because it's
146 wrapped and eval'd as $sub = sub {$code};
150 mkCheckRex() selects the golden-sample for the threaded-ness of the
151 platform, and produces a regex which matches the expected rendering,
152 and fails when it doesn't match.
154 The regex includes 'workarounds' which accommodate expected rendering
155 variations. These include:
157 string constants # avoid injection
158 line numbers, etc # args of nexstate()
161 pad-slot-assignments # for 5.8 compat, and testmode=cross
162 (map|grep)(start|while) # for 5.8 compat
166 mylike() calls either unlike() or like(), depending on
167 expectations. Mismatch reports are massaged, because the actual
168 difference can easily be lost in the forest of opcodes.
170 =head1 checkOptree API and Operation
172 Since the arg is a hash, the api is wide-open, and this really is
173 about what elements must be or are in the hash, and what they do. %tc
174 is passed to newTestCase(), the ctor, which adds in %proto, a global
177 =head2 name => STRING
179 If name property is not provided, it is synthesized from these params:
180 bcopts, note, prog, code. This is more convenient than trying to do
185 Either code or prog must be present.
187 =head2 prog => $perl_source_string
189 prog => $src provides a snippet of code, which is run in a sub-process,
190 via test.pl:runperl, and through B::Concise like so:
192 './perl -w -MO=Concise,$bcopts_massaged -e $src'
194 =head2 code => $perl_source_string || CODEREF
196 The $code arg is passed to B::Concise::compile(), and run in-process.
197 If $code is a string, it's first wrapped and eval'd into a $coderef.
198 In either case, $coderef is then passed to B::Concise::compile():
200 $subref = eval "sub{$code}";
201 $render = B::Concise::compile($subref)->();
203 =head2 expect and expect_nt
205 expect and expect_nt args are the B<golden-sample> renderings, and are
206 sampled from known-ok threaded and un-threaded bleadperl (5.9.1) builds.
207 They're both required, and the correct one is selected for the platform
208 being tested, and saved into the synthesized property B<wanted>.
210 =head2 bcopts => $bcopts || [ @bcopts ]
212 When getRendering() runs, it passes bcopts into B::Concise::compile().
213 The bcopts arg can be a single string, or an array of strings.
215 =head2 errs => $err_str_regex || [ @err_str_regexs ]
217 getRendering() processes the code or prog arg under warnings, and both
218 parsing and optree-traversal errors are collected. These are
219 validated against the one or more errors you specify.
221 =head1 testcase modifier properties
223 These properties are set as %tc parameters to change test behavior.
225 =head2 skip => 'reason'
227 invokes skip('reason'), causing test to skip.
229 =head2 todo => 'reason'
231 invokes todo('reason')
235 For code arguments, this option causes getRendering to redirect the
236 rendering operation to STDERR, which causes the regex match to fail.
240 If retry is set, and a test fails, it is run a second time, possibly
245 If a failure is retried, this turns on eval "use re 'debug'", thus
246 turning on regex debug. It's quite verbose, and not hugely helpful.
248 =head2 noanchors => 1
250 If set, this relaxes the regex check, which is normally pretty strict.
251 It's used primarily to validate checkOptree via tests in optree_check.
254 =head1 Synthesized object properties
256 These properties are added into the test object during execution.
260 This stores the chosen expect expect_nt string. The OptreeCheck
261 object may in the future delete the raw strings once wanted is set,
266 This tag is added if testmode=cross is passed in as argument.
267 It causes test-harness to purposely use the wrong string.
272 checkErrs() is a getRendering helper that verifies that expected errs
273 against those found when rendering the code on the platform. It is
274 run after rendering, and before mkCheckRex.
276 Errors can be reported 3 different ways; diag, fail, print.
278 diag - uses test.pl _diag()
279 fail - causes double-testing
280 print-.no # in front of the output (may mess up test harnesses)
282 The 3 ways are selectable at runtimve via cmdline-arg:
283 report={diag,fail,print}.
291 use B::Concise qw(walk_output);
294 $SIG{__WARN__} = sub {
296 $err =~ m/Subroutine re::(un)?install redefined/ and return;
302 $pkg->export_to_level(1,'checkOptree', @EXPORT);
303 getCmdLine(); # process @ARGV
307 # %gOpts params comprise a global test-state. Initial values here are
308 # HELP strings, they MUST BE REPLACED by runtime values before use, as
309 # is done by getCmdLine(), via import
311 our %gOpts = # values are replaced at runtime !!
313 # scalar values are help string
314 retry => 'retry failures after turning on re debug',
315 debug => 'turn on re debug for those retries',
316 selftest => 'self-tests mkCheckRex vs the reference rendering',
318 fail => 'force all test to fail, print to stdout',
319 dump => 'dump cmdline arg prcessing',
320 noanchors => 'dont anchor match rex',
322 # array values are one-of selections, with 1st value as default
323 # array: 2nd value is used as help-str, 1st val (still) default
324 help => [0, 'provides help and exits', 0],
325 testmode => [qw/ native cross both /],
327 # reporting mode for rendering errs
328 report => [qw/ diag fail print /],
329 errcont => [1, 'if 1, tests match even if report is fail', 0],
331 # fixup for VMS, cygwin, which dont have stderr b4 stdout
332 rxnoorder => [1, 'if 1, dont req match on -e lines, and -banner',0],
333 strip => [1, 'if 1, catch errs and remove from renderings',0],
334 stripv => 'if strip&&1, be verbose about it',
335 errs => 'expected compile errs, array if several',
339 # Not sure if this is too much cheating. Officially we say that
340 # $Config::Config{usethreads} is true if some sort of threading is in
341 # use, in which case we ought to be able to use it in place of the ||
342 # below. However, it is now possible to Configure perl with "threads"
343 # but neither ithreads or 5005threads, which forces the re-entrant
344 # APIs, but no perl user visible threading.
346 # This seems to have the side effect that most of perl doesn't think
347 # that it's threaded, hence the ops aren't threaded either. Not sure
348 # if this is actually a "supported" configuration, but given that
349 # ponie uses it, it's going to be used by something official at least
350 # in the interim. So it's nice for tests to all pass.
353 if $Config::Config{useithreads} || $Config::Config{use5005threads};
354 our $platform = ($threaded) ? "threaded" : "plain";
355 our $thrstat = ($threaded) ? "threaded" : "nonthreaded";
358 both => [ 'expect', 'expect_nt'],
359 native => [ ($threaded) ? 'expect' : 'expect_nt'],
360 cross => [ !($threaded) ? 'expect' : 'expect_nt'],
361 expect => [ 'expect' ],
362 expect_nt => [ 'expect_nt' ],
365 our %msgs # announce cross-testing.
368 'expect_nt-threaded' => " (nT on T) ",
369 'expect-nonthreaded' => " (T on nT) ",
370 # native - nothing to say (must stay empty - used for $crosstesting)
371 'expect_nt-nonthreaded' => '',
372 'expect-threaded' => '',
376 sub getCmdLine { # import assistant
378 print(qq{\n$0 accepts args to update these state-vars:
379 turn on a flag by typing its name,
380 select a value from list by typing name=val.\n },
382 if grep /help/, @ARGV;
384 # replace values for each key !! MUST MARK UP %gOpts
385 foreach my $opt (keys %gOpts) {
387 # scan ARGV for known params
388 if (ref $gOpts{$opt} eq 'ARRAY') {
390 # $opt is a One-Of construct
391 # replace with valid selection from the list
393 # uhh this WORKS. but it's inscrutable
394 # grep s/$opt=(\w+)/grep {$_ eq $1} @ARGV and $gOpts{$opt}=$1/e, @ARGV;
396 if (grep s/$opt=(\w+)/$tval=$1/e, @ARGV) {
397 # check val before accepting
398 my @allowed = @{$gOpts{$opt}};
399 if (grep { $_ eq $tval } @allowed) {
400 $gOpts{$opt} = $tval;
402 else {die "invalid value: '$tval' for $opt\n"}
405 # take 1st val as default
406 $gOpts{$opt} = ${$gOpts{$opt}}[0]
407 if ref $gOpts{$opt} eq 'ARRAY';
409 else { # handle scalars
411 # if 'opt' is present, true
412 $gOpts{$opt} = (grep /^$opt/, @ARGV) ? 1 : 0;
414 # override with 'foo' if 'opt=foo' appears
415 grep s/$opt=(.*)/$gOpts{$opt}=$1/e, @ARGV;
418 print("$0 heres current state:\n", mydumper(\%gOpts))
419 if $gOpts{help} or $gOpts{dump};
421 exit if $gOpts{help};
423 # the above arg-handling cruft should be replaced by a Getopt call
425 ##############################
426 # the API (1 function)
429 my $tc = newTestCases(@_); # ctor
432 print "checkOptree args: ",mydumper($tc) if $tc->{dump};
434 skip("$tc->{skip} $tc->{name}", 1) if $tc->{skip};
436 return runSelftest($tc) if $gOpts{selftest};
438 $tc->getRendering(); # get the actual output
442 foreach my $want (@{$modes{$gOpts{testmode}}}) {
443 local $TODO = $tc->{todo} if $tc->{todo};
445 $tc->{cross} = $msgs{"$want-$thrstat"};
447 $tc->mkCheckRex($want);
455 # make test objects (currently 1) from args (passed to checkOptree)
456 my $tc = bless { @_ }, __PACKAGE__
457 or die "test cases are hashes";
461 # cpy globals into each test
462 foreach my $k (keys %gOpts) {
464 $tc->{$k} = $gOpts{$k} unless defined $tc->{$k};
467 # transform errs to self-hash for efficient set-math
469 if (not ref $tc->{errs}) {
470 $tc->{errs} = { $tc->{errs} => 1};
472 elsif (ref $tc->{errs} eq 'ARRAY') {
474 @errs{@{$tc->{errs}}} = (1) x @{$tc->{errs}};
475 $tc->{errs} = \%errs;
477 elsif (ref $tc->{errs} eq 'Regexp') {
478 warn "regexp err matching not yet implemented";
485 # may help get/keep test output consistent
487 return $tc->{name} if $tc->{name};
489 my $buf = (ref $tc->{bcopts})
490 ? join(',', @{$tc->{bcopts}}) : $tc->{bcopts};
492 foreach (qw( note prog code )) {
493 $buf .= " $_: $tc->{$_}" if $tc->{$_} and not ref $tc->{$_};
495 return $tc->{name} = $buf;
499 # render and its helpers
503 fail("getRendering: code or prog is required")
504 unless $tc->{code} or $tc->{prog};
506 my @opts = get_bcopts($tc);
507 my $rendering = ''; # suppress "Use of uninitialized value in open"
508 my @errs; # collect errs via
512 $rendering = runperl( switches => ['-w',join(',',"-MO=Concise",@opts)],
513 prog => $tc->{prog}, stderr => 1,
516 my $code = $tc->{code};
517 unless (ref $code eq 'CODE') {
518 # treat as source, and wrap into subref
519 # in caller's package ( to test arg-fixup, comment next line)
520 my $pkg = '{ package '.caller(1) .';';
524 $code = eval "$pkg sub { $code } }";
527 if ($@) { chomp $@; push @errs, $@ }
529 # set walk-output b4 compiling, which writes 'announce' line
530 walk_output(\$rendering);
532 my $opwalker = B::Concise::compile(@opts, $code);
533 die "bad BC::compile retval" unless ref $opwalker eq 'CODE';
535 B::Concise::reset_sequence();
538 # kludge error into rendering if its empty.
539 $rendering = $@ if $@ and ! $rendering;
541 # separate banner, other stuff whose printing order isnt guaranteed
543 $rendering =~ s/(B::Concise::compile.*?\n)//;
544 print "stripped from rendering <$1>\n" if $1 and $tc->{stripv};
546 #while ($rendering =~ s/^(.*?(-e) line \d+\.)\n//g) {
547 while ($rendering =~ s/^(.*?(-e|\(eval \d+\).*?) line \d+\.)\n//g) {
548 print "stripped <$1> $2\n" if $tc->{stripv};
551 $rendering =~ s/-e syntax OK\n//;
552 $rendering =~ s/-e had compilation errors\.\n//;
554 $tc->{got} = $rendering;
555 $tc->{goterrs} = \@errs if @errs;
556 return $rendering, @errs;
560 # collect concise passthru-options if any
564 @opts = (ref $tc->{bcopts} eq 'ARRAY')
565 ? @{$tc->{bcopts}} : ($tc->{bcopts});
571 # check rendering errs against expected errors, reduce and report
574 # check for agreement, by hash (order less important)
576 $tc->{goterrs} ||= [];
577 @goterrs{@{$tc->{goterrs}}} = (1) x scalar @{$tc->{goterrs}};
579 foreach my $k (keys %{$tc->{errs}}) {
580 if (@got = grep /^$k$/, keys %goterrs) {
581 delete $tc->{errs}{$k};
582 delete $goterrs{$_} foreach @got;
585 $tc->{goterrs} = \%goterrs;
588 if (%{$tc->{errs}} or %{$tc->{goterrs}}) {
591 fail("FORCED: $tc->{name}:\n") if $gOpts{fail}; # silly ?
599 push @lines, "got unexpected:", sort keys %{$tc->{goterrs}} if %{$tc->{goterrs}};
600 push @lines, "missed expected:", sort keys %{$tc->{errs}} if %{$tc->{errs}};
603 unshift @lines, $tc->{name};
604 my $report = join("\n", @lines);
606 if ($gOpts{report} eq 'diag') { _diag ($report) }
607 elsif ($gOpts{report} eq 'fail') { fail ($report) }
608 else { print ($report) }
609 next unless $gOpts{errcont}; # skip block
613 =head1 mkCheckRex ($tc)
615 It selects the correct golden-sample from the test-case object, and
616 converts it into a Regexp which should match against the original
617 golden-sample (used in selftest, see below), and on the renderings
618 obtained by applying the code on the perl being tested.
620 The selection is driven by platform mostly, but also by test-mode,
621 which rather complicates the code. This is worsened by the potential
622 need to make platform specific conversions on the reftext.
624 but is otherwise as strict as possible. For example, it should *not*
625 match when opcode flags change, or when optimizations convert an op to
629 =head2 match criteria
631 The selected golden-sample is massaged to eliminate various match
632 irrelevancies. This is done so that the tests dont fail just because
633 you added a line to the top of the test file. (Recall that the
634 renderings contain the program's line numbers). Similar cleanups are
635 done on "strings", hex-constants, etc.
637 The need to massage is reflected in the 2 golden-sample approach of
638 the test-cases; we want the match to be as rigorous as possible, and
639 thats easier to achieve when matching against 1 input than 2.
641 Opcode arguments (text within braces) are disregarded for matching
642 purposes. This loses some info in 'add[t5]', but greatly simplifies
643 matching 'nextstate(main 22 (eval 10):1)'. Besides, we are testing
644 for regressions, not for complete accuracy.
646 The regex is anchored by default, but can be suppressed with
647 'noanchors', allowing 1-liner tests to succeed if opcode is found.
651 # needless complexity due to 'too much info' from B::Concise v.60
652 my $announce = 'B::Concise::compile\(CODE\(0x[0-9a-f]+\)\)';;
655 # converts expected text into Regexp which should match against
656 # unaltered version. also adjusts threaded => non-threaded
657 my ($tc, $want) = @_;
658 eval "no re 'debug'";
660 my $str = $tc->{expect} || $tc->{expect_nt}; # standard bias
661 $str = $tc->{$want} if $want && $tc->{$want}; # stated pref
663 die("no '$want' golden-sample found: $tc->{name}") unless $str;
665 $str =~ s/^\# //mg; # ease cut-paste testcase authoring
668 # add 5.8 private flags, which bleadperl (5.9.1) doesn't have/use/render
669 # works because it adds no wildcards, which are butchered below..
670 $str =~ s|(mapstart l?K\*?)|$1/2|mg;
671 $str =~ s|(grepstart l?K\*?)|$1/2|msg;
672 $str =~ s|(mapwhile.*? l?K)|$1/1|msg;
673 $str =~ s|(grepwhile.*? l?K)|$1/1|msg;
675 $tc->{wantstr} = $str;
677 # make targ args wild
678 $str =~ s/\[t\d+\]/[t\\d+]/msg;
680 # escape bracing, etc.. manual \Q (doesnt escape '+')
681 $str =~ s/([\[\]()*.\$\@\#\|{}])/\\$1/msg;
682 # $str =~ s/(?<!\\)([\[\]\(\)*.\$\@\#\|{}])/\\$1/msg;
684 # treat dbstate like nextstate (no in-debugger false reports)
685 $str =~ s/(?:next|db)state(\\\(.*?\\\))/(?:next|db)state(.*?)/msg;
686 # widened for -terse mode
687 $str =~ s/(?:next|db)state/(?:next|db)state/msg;
690 $str =~ s/:-?\d+,-?\d+/:-?\\d+,-?\\d+/msg; # FAKE line numbers
691 $str =~ s/match\\\(.*?\\\)/match\(.*?\)/msg; # match args
692 $str =~ s/(0x[0-9A-Fa-f]+)/0x[0-9A-Fa-f]+/msg; # hexnum values
693 $str =~ s/".*?"/".*?"/msg; # quoted strings
695 $str =~ s/(\d refs?)/\\d+ refs?/msg; # 1 ref, 2+ refs (plural)
696 $str =~ s/leavesub \[\d\]/leavesub [\\d]/msg; # for -terse
697 #$str =~ s/(\s*)\n/\n/msg; # trailing spaces
699 croak "no reftext found for $want: $tc->{name}"
700 unless $str =~ /\w+/; # fail unless a real test
702 # $str = '.*' if 1; # sanity test
703 # $str .= 'FAIL' if 1; # sanity test
705 # allow -eval, banner at beginning of anchored matches
706 $str = "(-e .*?)?(B::Concise::compile.*?)?\n" . $str
707 unless $tc->{noanchors} or $tc->{rxnoorder};
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 accommodate 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";
896 foreach my $it (@_) {
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/;
986 sub OptreeCheck::processExamples {
989 # gets array of paragraphs, which should be code-samples. Theyre
990 # turned into optreeCheck tests,
992 foreach my $file (@files) {
993 open (my $fh, $file) or die "cant open $file: $!\n";
996 print preamble (scalar @chunks);
997 foreach my $t (@chunks) {
998 print "\n\n=for gentest\n\n# chunk: $t=cut\n\n";
999 print OptreeCheck::gentest ($t);
1004 # OK - now for the final insult to your good taste...
1006 if ($0 =~ /OptreeCheck\.pm/) {
1009 require './t/test.pl';
1011 # invoked as program. Work like former gentest.pl,
1012 # ie read files given as cmdline args,
1013 # convert them to usable test files.
1015 require Getopt::Std;
1016 Getopt::Std::getopts('') or
1017 die qq{ $0 sample-files* # no options
1019 expecting filenames as args. Each should have paragraphs,
1020 these are converted to checkOptree() tests, and printed to
1021 stdout. Redirect to file then edit for test. \n};
1023 OptreeCheck::processExamples(@ARGV);
1030 =head1 TEST DEVELOPMENT SUPPORT
1032 This optree regression testing framework needs tests in order to find
1033 bugs. To that end, OptreeCheck has support for developing new tests,
1034 according to the following model:
1036 1. write a set of sample code into a single file, one per
1037 paragraph. Add <=for gentest> blocks if you care to, or just look at
1038 f_map and f_sort in ext/B/t/ for examples.
1040 2. run OptreeCheck as a program on the file
1042 ./perl -Ilib ext/B/t/OptreeCheck.pm -w ext/B/t/f_map
1043 ./perl -Ilib ext/B/t/OptreeCheck.pm -w ext/B/t/f_sort
1045 gentest reads the sample code, runs each to generate a reference
1046 rendering, folds this rendering into an optreeCheck() statement,
1047 and prints it to stdout.
1049 3. run the output file as above, redirect to files, then rerun on
1050 same build (for sanity check), and on thread-opposite build. With
1051 editor in 1 window, and cmd in other, it's fairly easy to cut-paste
1052 the gots into the expects, easier than running step 2 on both
1053 builds then trying to sdiff them together.
1057 This code is purely for testing core. While checkOptree feels flexible
1058 enough to be stable, the whole selftest framework is subject to change