6 # now export checkOptree, and those test.pl functions used by tests
7 our @EXPORT = qw( checkOptree plan skip skip_all pass is like unlike
13 OptreeCheck - check optrees as rendered by B::Concise
17 OptreeCheck supports 'golden-sample' regression testing of perl's
18 parser, optimizer, bytecode generator, via a single function:
21 It invokes B::Concise upon the sample code, checks that the rendering
22 'agrees' with the golden sample, and reports mismatches.
24 Additionally, the module processes @ARGV (which is typically unused in
25 the Core test harness), and thus provides a means to run the tests in
35 name => "test-name', # optional, made from others if not given
37 # code-under-test: must provide 1 of them
38 code => sub {my $a}, # coderef, or source (wrapped and evald)
39 prog => 'sort @a', # run in subprocess, aka -MO=Concise
40 bcopts => '-exec', # $opt or \@opts, passed to BC::compile
42 errs => 'Useless variable "@main::a" .*' # str, regex, [str+] [regex+],
44 # various test options
45 # errs => '.*', # match against any emitted errs, -w warnings
46 # skip => 1, # skips test
47 # todo => 'excuse', # anticipated failures
48 # fail => 1 # force fail (by redirecting result)
49 # retry => 1 # retry on test failure
50 # debug => 1, # use re 'debug' for retried failures !!
52 # the 'golden-sample's, (must provide both)
54 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT' ); # start HERE-DOCS
55 # 1 <;> nextstate(main 45 optree.t:23) v
56 # 2 <0> padsv[$a:45,46] M/LVINTRO
57 # 3 <1> leavesub[1 ref] K/REFC,1
59 # 1 <;> nextstate(main 45 optree.t:23) v
60 # 2 <0> padsv[$a:45,46] M/LVINTRO
61 # 3 <1> leavesub[1 ref] K/REFC,1
66 =head2 Failure Reports
68 Heres a sample failure, as induced by the following command.
69 Note the argument; option=value, after the test-file, more on that later
71 $> PERL_CORE=1 ./perl ext/B/t/optree_check.t testmode=cross
73 ok 19 - canonical example w -basic
74 not ok 20 - -exec code: $a=$b+42
75 # Failed at test.pl line 249
76 # got '1 <;> nextstate(main 600 optree_check.t:208) v
78 # 3 <$> const[IV 42] s
82 # 7 <1> leavesub[1 ref] K/REFC,1
84 # expected /(?ms-xi:^1 <;> (?:next|db)state(.*?) v
85 # 2 <\$> gvsv\(\*b\) s
86 # 3 <\$> const\(IV 42\) s
87 # 4 <2> add\[t\d+\] sK/2
88 # 5 <\$> gvsv\(\*a\) s
90 # 7 <1> leavesub\[\d+ refs?\] K/REFC,1
92 # got: '2 <#> gvsv[*b] s'
93 # want: (?-xism:2 <\$> gvsv\(\*b\) s)
94 # got: '3 <$> const[IV 42] s'
95 # want: (?-xism:3 <\$> const\(IV 42\) s)
96 # got: '5 <#> gvsv[*a] s'
97 # want: (?-xism:5 <\$> gvsv\(\*a\) s)
100 # 3 <$> const[IV 42] s
102 # these lines not matched:
104 # 3 <$> const[IV 42] s
107 Errors are reported 3 different ways;
109 The 1st form is directly from test.pl's like() and unlike(). Note
110 that this form is used as input, so you can easily cut-paste results
111 into test-files you are developing. Just make sure you recognize
112 insane results, to avoid canonizing them as golden samples.
114 The 2nd and 3rd forms show only the unexpected results and opcodes.
115 This is done because it's blindingly tedious to find a single opcode
116 causing the failure. 2 different ways are done in case one is
119 =head1 TestCase Overview
121 checkOptree(%tc) constructs a testcase object from %tc, and then calls
122 methods which eventually call test.pl's like() to produce test
127 getRendering() runs code or prog through B::Concise, and captures its
128 rendering. Errors emitted during rendering are checked against
129 expected errors, and are reported as diagnostics by default, or as
130 failures if 'report=fail' cmdline-option is given.
132 prog is run in a sub-shell, with $bcopts passed through. This is the way
133 to run code intended for main. The code arg in contrast, is always a
134 CODEREF, either because it starts that way as an arg, or because it's
135 wrapped and eval'd as $sub = sub {$code};
139 mkCheckRex() selects the golden-sample for the threaded-ness of the
140 platform, and produces a regex which matches the expected rendering,
141 and fails when it doesn't match.
143 The regex includes 'workarounds' which accommodate expected rendering
144 variations. These include:
146 string constants # avoid injection
147 line numbers, etc # args of nexstate()
150 pad-slot-assignments # for 5.8 compat, and testmode=cross
151 (map|grep)(start|while) # for 5.8 compat
155 mylike() calls either unlike() or like(), depending on
156 expectations. Mismatch reports are massaged, because the actual
157 difference can easily be lost in the forest of opcodes.
159 =head1 checkOptree API and Operation
161 Since the arg is a hash, the api is wide-open, and this really is
162 about what elements must be or are in the hash, and what they do. %tc
163 is passed to newTestCase(), the ctor, which adds in %proto, a global
166 =head2 name => STRING
168 If name property is not provided, it is synthesized from these params:
169 bcopts, note, prog, code. This is more convenient than trying to do
174 Either code or prog must be present.
176 =head2 prog => $perl_source_string
178 prog => $src provides a snippet of code, which is run in a sub-process,
179 via test.pl:runperl, and through B::Concise like so:
181 './perl -w -MO=Concise,$bcopts_massaged -e $src'
183 =head2 code => $perl_source_string || CODEREF
185 The $code arg is passed to B::Concise::compile(), and run in-process.
186 If $code is a string, it's first wrapped and eval'd into a $coderef.
187 In either case, $coderef is then passed to B::Concise::compile():
189 $subref = eval "sub{$code}";
190 $render = B::Concise::compile($subref)->();
192 =head2 expect and expect_nt
194 expect and expect_nt args are the B<golden-sample> renderings, and are
195 sampled from known-ok threaded and un-threaded bleadperl (5.9.1) builds.
196 They're both required, and the correct one is selected for the platform
197 being tested, and saved into the synthesized property B<wanted>.
199 =head2 bcopts => $bcopts || [ @bcopts ]
201 When getRendering() runs, it passes bcopts into B::Concise::compile().
202 The bcopts arg can be a singls string, or an array of strings.
204 =head2 errs => $err_str_regex || [ @err_str_regexs ]
206 getRendering() processes the code or prog arg under warnings, and both
207 parsing and optree-traversal errors are collected. These are
208 validated against the one or more errors you specify.
210 =head1 testcase modifier properties
212 These properties are set as %tc parameters to change test behavior.
214 =head2 skip => 'reason'
216 invokes skip('reason'), causing test to skip.
218 =head2 todo => 'reason'
220 invokes todo('reason')
224 For code arguments, this option causes getRendering to redirect the
225 rendering operation to STDERR, which causes the regex match to fail.
229 If retry is set, and a test fails, it is run a second time, possibly
234 If a failure is retried, this turns on eval "use re 'debug'", thus
235 turning on regex debug. It's quite verbose, and not hugely helpful.
237 =head2 noanchors => 1
239 If set, this relaxes the regex check, which is normally pretty strict.
240 It's used primarily to validate checkOptree via tests in optree_check.
243 =head1 Synthesized object properties
245 These properties are added into the test object during execution.
249 This stores the chosen expect expect_nt string. The OptreeCheck
250 object may in the future delete the raw strings once wanted is set,
255 This tag is added if testmode=cross is passed in as argument.
256 It causes test-harness to purposely use the wrong string.
261 checkErrs() is a getRendering helper that verifies that expected errs
262 against those found when rendering the code on the platform. It is
263 run after rendering, and before mkCheckRex.
265 Errors can be reported 3 different ways; diag, fail, print.
267 diag - uses test.pl _diag()
268 fail - causes double-testing
269 print-.no # in front of the output (may mess up test harnesses)
271 The 3 ways are selectable at runtimve via cmdline-arg:
272 report={diag,fail,print}.
280 use B::Concise qw(walk_output);
283 $SIG{__WARN__} = sub {
285 $err =~ m/Subroutine re::(un)?install redefined/ and return;
291 $pkg->export_to_level(1,'checkOptree', @EXPORT);
292 getCmdLine(); # process @ARGV
296 # %gOpts params comprise a global test-state. Initial values here are
297 # HELP strings, they MUST BE REPLACED by runtime values before use, as
298 # is done by getCmdLine(), via import
300 our %gOpts = # values are replaced at runtime !!
302 # scalar values are help string
303 retry => 'retry failures after turning on re debug',
304 debug => 'turn on re debug for those retries',
305 selftest => 'self-tests mkCheckRex vs the reference rendering',
307 fail => 'force all test to fail, print to stdout',
308 dump => 'dump cmdline arg prcessing',
309 noanchors => 'dont anchor match rex',
311 # array values are one-of selections, with 1st value as default
312 # array: 2nd value is used as help-str, 1st val (still) default
313 help => [0, 'provides help and exits', 0],
314 testmode => [qw/ native cross both /],
316 # reporting mode for rendering errs
317 report => [qw/ diag fail print /],
318 errcont => [1, 'if 1, tests match even if report is fail', 0],
320 # fixup for VMS, cygwin, which dont have stderr b4 stdout
321 rxnoorder => [1, 'if 1, dont req match on -e lines, and -banner',0],
322 strip => [1, 'if 1, catch errs and remove from renderings',0],
323 stripv => 'if strip&&1, be verbose about it',
324 errs => 'expected compile errs, array if several',
328 # Not sure if this is too much cheating. Officially we say that
329 # $Config::Config{usethreads} is true if some sort of threading is in
330 # use, in which case we ought to be able to use it in place of the ||
331 # below. However, it is now possible to Configure perl with "threads"
332 # but neither ithreads or 5005threads, which forces the re-entrant
333 # APIs, but no perl user visible threading.
335 # This seems to have the side effect that most of perl doesn't think
336 # that it's threaded, hence the ops aren't threaded either. Not sure
337 # if this is actually a "supported" configuration, but given that
338 # ponie uses it, it's going to be used by something official at least
339 # in the interim. So it's nice for tests to all pass.
342 if $Config::Config{useithreads} || $Config::Config{use5005threads};
343 our $platform = ($threaded) ? "threaded" : "plain";
344 our $thrstat = ($threaded) ? "threaded" : "nonthreaded";
347 both => [ 'expect', 'expect_nt'],
348 native => [ ($threaded) ? 'expect' : 'expect_nt'],
349 cross => [ !($threaded) ? 'expect' : 'expect_nt'],
350 expect => [ 'expect' ],
351 expect_nt => [ 'expect_nt' ],
354 our %msgs # announce cross-testing.
357 'expect_nt-threaded' => " (nT on T) ",
358 'expect-nonthreaded' => " (T on nT) ",
359 # native - nothing to say (must stay empty - used for $crosstesting)
360 'expect_nt-nonthreaded' => '',
361 'expect-threaded' => '',
365 sub getCmdLine { # import assistant
367 print(qq{\n$0 accepts args to update these state-vars:
368 turn on a flag by typing its name,
369 select a value from list by typing name=val.\n },
371 if grep /help/, @ARGV;
373 # replace values for each key !! MUST MARK UP %gOpts
374 foreach my $opt (keys %gOpts) {
376 # scan ARGV for known params
377 if (ref $gOpts{$opt} eq 'ARRAY') {
379 # $opt is a One-Of construct
380 # replace with valid selection from the list
382 # uhh this WORKS. but it's inscrutable
383 # grep s/$opt=(\w+)/grep {$_ eq $1} @ARGV and $gOpts{$opt}=$1/e, @ARGV;
385 if (grep s/$opt=(\w+)/$tval=$1/e, @ARGV) {
386 # check val before accepting
387 my @allowed = @{$gOpts{$opt}};
388 if (grep { $_ eq $tval } @allowed) {
389 $gOpts{$opt} = $tval;
391 else {die "invalid value: '$tval' for $opt\n"}
394 # take 1st val as default
395 $gOpts{$opt} = ${$gOpts{$opt}}[0]
396 if ref $gOpts{$opt} eq 'ARRAY';
398 else { # handle scalars
400 # if 'opt' is present, true
401 $gOpts{$opt} = (grep /^$opt/, @ARGV) ? 1 : 0;
403 # override with 'foo' if 'opt=foo' appears
404 grep s/$opt=(.*)/$gOpts{$opt}=$1/e, @ARGV;
407 print("$0 heres current state:\n", mydumper(\%gOpts))
408 if $gOpts{help} or $gOpts{dump};
410 exit if $gOpts{help};
412 # the above arg-handling cruft should be replaced by a Getopt call
414 ##############################
415 # the API (1 function)
418 my $tc = newTestCases(@_); # ctor
421 print "checkOptree args: ",mydumper($tc) if $tc->{dump};
423 skip("$tc->{skip} $tc->{name}", 1) if $tc->{skip};
425 return runSelftest($tc) if $gOpts{selftest};
427 $tc->getRendering(); # get the actual output
431 foreach $want (@{$modes{$gOpts{testmode}}}) {
432 local $TODO = $tc->{todo} if $tc->{todo};
434 $tc->{cross} = $msgs{"$want-$thrstat"};
436 $tc->mkCheckRex($want);
444 # make test objects (currently 1) from args (passed to checkOptree)
445 my $tc = bless { @_ }, __PACKAGE__
446 or die "test cases are hashes";
450 # cpy globals into each test
451 foreach $k (keys %gOpts) {
453 $tc->{$k} = $gOpts{$k} unless defined $tc->{$k};
456 # transform errs to self-hash for efficient set-math
458 if (not ref $tc->{errs}) {
459 $tc->{errs} = { $tc->{errs} => 1};
461 elsif (ref $tc->{errs} eq 'ARRAY') {
463 @errs{@{$tc->{errs}}} = (1) x @{$tc->{errs}};
464 $tc->{errs} = \%errs;
466 elsif (ref $tc->{errs} eq 'Regexp') {
467 warn "regexp err matching not yet implemented";
474 # may help get/keep test output consistent
476 return $tc->{name} if $tc->{name};
478 my $buf = (ref $tc->{bcopts})
479 ? join(',', @{$tc->{bcopts}}) : $tc->{bcopts};
481 foreach (qw( note prog code )) {
482 $buf .= " $_: $tc->{$_}" if $tc->{$_} and not ref $tc->{$_};
484 return $tc->{name} = $buf;
488 # render and its helpers
492 fail("getRendering: code or prog is required")
493 unless $tc->{code} or $tc->{prog};
495 my @opts = get_bcopts($tc);
496 my $rendering = ''; # suppress "Use of uninitialized value in open"
497 my @errs; # collect errs via
501 $rendering = runperl( switches => ['-w',join(',',"-MO=Concise",@opts)],
502 prog => $tc->{prog}, stderr => 1,
505 my $code = $tc->{code};
506 unless (ref $code eq 'CODE') {
507 # treat as source, and wrap into subref
508 # in caller's package ( to test arg-fixup, comment next line)
509 my $pkg = '{ package '.caller(1) .';';
510 $code = eval "$pkg sub { $code } }";
512 if ($@) { chomp $@; push @errs, $@ }
514 # set walk-output b4 compiling, which writes 'announce' line
515 walk_output(\$rendering);
517 fail("forced failure: stdout follows");
518 walk_output(\*STDOUT);
520 my $opwalker = B::Concise::compile(@opts, $code);
521 die "bad BC::compile retval" unless ref $opwalker eq 'CODE';
523 B::Concise::reset_sequence();
526 # kludge error into rendering if its empty.
527 $rendering = $@ if $@ and ! $rendering;
529 # separate banner, other stuff whose printing order isnt guaranteed
531 $rendering =~ s/(B::Concise::compile.*?\n)//;
532 print "stripped from rendering <$1>\n" if $1 and $tc->{stripv};
534 #while ($rendering =~ s/^(.*?(-e) line \d+\.)\n//g) {
535 while ($rendering =~ s/^(.*?(-e|\(eval \d+\).*?) line \d+\.)\n//g) {
536 print "stripped <$1> $2\n" if $tc->{stripv};
539 $rendering =~ s/-e syntax OK\n//;
540 $rendering =~ s/-e had compilation errors\.\n//;
542 $tc->{got} = $rendering;
543 $tc->{goterrs} = \@errs if @errs;
544 return $rendering, @errs;
548 # collect concise passthru-options if any
552 @opts = (ref $tc->{bcopts} eq 'ARRAY')
553 ? @{$tc->{bcopts}} : ($tc->{bcopts});
559 # check rendering errs against expected errors, reduce and report
562 # check for agreement, by hash (order less important)
564 @goterrs{@{$tc->{goterrs}}} = (1) x scalar @{$tc->{goterrs}};
566 foreach my $k (keys %{$tc->{errs}}) {
567 if (@got = grep /^$k$/, keys %goterrs) {
568 delete $tc->{errs}{$k};
569 delete $goterrs{$_} foreach @got;
572 $tc->{goterrs} = \%goterrs;
575 if (%{$tc->{errs}} or %{$tc->{goterrs}}) {
578 fail("FORCED: $tc->{name}:\n$rendering") if $gOpts{fail}; # silly ?
586 push @lines, "got unexpected:", sort keys %{$tc->{goterrs}} if %{$tc->{goterrs}};
587 push @lines, "missed expected:", sort keys %{$tc->{errs}} if %{$tc->{errs}};
590 unshift @lines, $tc->{name};
591 my $report = join("\n", @lines);
593 if ($gOpts{report} eq 'diag') { _diag ($report) }
594 elsif ($gOpts{report} eq 'fail') { fail ($report) }
595 else { print ($report) }
596 next unless $gOpts{errcont}; # skip block
600 =head1 mkCheckRex ($tc)
602 It selects the correct golden-sample from the test-case object, and
603 converts it into a Regexp which should match against the original
604 golden-sample (used in selftest, see below), and on the renderings
605 obtained by applying the code on the perl being tested.
607 The selection is driven by platform mostly, but also by test-mode,
608 which rather complicates the code. This is worsened by the potential
609 need to make platform specific conversions on the reftext.
611 but is otherwise as strict as possible. For example, it should *not*
612 match when opcode flags change, or when optimizations convert an op to
616 =head2 match criteria
618 The selected golden-sample is massaged to eliminate various match
619 irrelevancies. This is done so that the tests dont fail just because
620 you added a line to the top of the test file. (Recall that the
621 renderings contain the program's line numbers). Similar cleanups are
622 done on "strings", hex-constants, etc.
624 The need to massage is reflected in the 2 golden-sample approach of
625 the test-cases; we want the match to be as rigorous as possible, and
626 thats easier to achieve when matching against 1 input than 2.
628 Opcode arguments (text within braces) are disregarded for matching
629 purposes. This loses some info in 'add[t5]', but greatly simplifys
630 matching 'nextstate(main 22 (eval 10):1)'. Besides, we are testing
631 for regressions, not for complete accuracy.
633 The regex is anchored by default, but can be suppressed with
634 'noanchors', allowing 1-liner tests to succeed if opcode is found.
638 # needless complexity due to 'too much info' from B::Concise v.60
639 my $announce = 'B::Concise::compile\(CODE\(0x[0-9a-f]+\)\)';;
642 # converts expected text into Regexp which should match against
643 # unaltered version. also adjusts threaded => non-threaded
644 my ($tc, $want) = @_;
645 eval "no re 'debug'";
647 my $str = $tc->{expect} || $tc->{expect_nt}; # standard bias
648 $str = $tc->{$want} if $want && $tc->{$want}; # stated pref
650 die("no '$want' golden-sample found: $tc->{name}") unless $str;
652 $str =~ s/^\# //mg; # ease cut-paste testcase authoring
655 # add 5.8 private flags, which bleadperl (5.9.1) doesn't have/use/render
656 # works because it adds no wildcards, which are butchered below..
657 $str =~ s|(mapstart l?K\*?)|$1/2|mg;
658 $str =~ s|(grepstart l?K\*?)|$1/2|msg;
659 $str =~ s|(mapwhile.*? l?K)|$1/1|msg;
660 $str =~ s|(grepwhile.*? l?K)|$1/1|msg;
662 $tc->{wantstr} = $str;
664 # convert all (args) and [args] to temp forms wo bracing
665 $str =~ s/\[(.*?)\]/__CAPSQR$1__/msg;
666 $str =~ s/\((.*?)\)/__CAPRND$1__/msg;
667 $str =~ s/\((.*?)\)/__CAPRND$1__/msg; # nested () in nextstate
669 # escape bracing, etc.. manual \Q (doesnt escape '+')
670 $str =~ s/([\[\]()*.\$\@\#\|{}])/\\$1/msg;
672 # now replace temp forms with original, preserving reference bracing
673 $str =~ s/__CAPSQR(.*?)__\b/\\[$1\\]/msg; # \b is important
674 $str =~ s/__CAPRND(.*?)__\b/\\($1\\)/msg;
675 $str =~ s/__CAPRND(.*?)__\b/\\($1\\)/msg; # nested () in nextstate
677 # treat dbstate like nextstate (no in-debugger false reports)
678 $str =~ s/(?:next|db)state(\\\(.*?\\\))/(?:next|db)state(.*?)/msg;
679 # widened for -terse mode
680 $str =~ s/(?:next|db)state/(?:next|db)state/msg;
683 $str =~ s/:-?\d+,-?\d+/:-?\\d+,-?\\d+/msg; # FAKE line numbers
684 $str =~ s/match\\\(.*?\\\)/match\(.*?\)/msg; # match args
685 $str =~ s/(0x[0-9A-Fa-f]+)/0x[0-9A-Fa-f]+/msg; # hexnum values
686 $str =~ s/".*?"/".*?"/msg; # quoted strings
688 $str =~ s/(\d refs?)/\\d+ refs?/msg; # 1 ref, 2+ refs (plural)
689 $str =~ s/leavesub \[\d\]/leavesub [\\d]/msg; # for -terse
690 #$str =~ s/(\s*)\n/\n/msg; # trailing spaces
692 # these fix up pad-slot assignment args
693 if ($] < 5.009 or $tc->{cross}) {
694 $str =~ s/\[t\d+\\]/\[t\\d+\\]/msg; # pad slot assignments
697 croak "no reftext found for $want: $tc->{name}"
698 unless $str =~ /\w+/; # fail unless a real test
700 # $str = '.*' if 1; # sanity test
701 # $str .= 'FAIL' if 1; # sanity test
703 # allow -eval, banner at beginning of anchored matches
704 $str = "(-e .*?)?(B::Concise::compile.*?)?\n" . $str
705 unless $tc->{noanchors} or $tc->{rxnoorder};
707 eval "use re 'debug'" if $debug;
708 my $qr = ($tc->{noanchors}) ? qr/$str/ms : qr/^$str$/ms ;
712 $tc->{rexstr} = $str;
720 # reworked mylike to use hash-obj
722 my $got = $tc->{got};
723 my $want = $tc->{rex};
724 my $cmnt = $tc->{name};
725 my $cross = $tc->{cross};
727 my $msgs = $tc->{msgs};
728 my $retry = $tc->{retry}; # || $gopts{retry};
729 my $debug = $tc->{debug}; #|| $gopts{retrydbg};
731 # bad is anticipated failure
732 my $bad = (0 or ( $cross && $tc->{crossfail})
733 or (!$cross && $tc->{fail})
736 # same as A ^ B, but B has side effects
737 my $ok = ( $bad && unlike ($got, $want, $cmnt, @$msgs)
738 or !$bad && like ($got, $want, $cmnt, @$msgs));
740 reduceDiffs ($tc) if not $ok;
742 if (not $ok and $retry) {
743 # redo, perhaps with use re debug - NOT ROBUST
744 eval "use re 'debug'" if $debug;
745 $ok = ( $bad && unlike ($got, $want, "(RETRY) $cmnt", @$msgs)
746 or !$bad && like ($got, $want, "(RETRY) $cmnt", @$msgs));
747 eval "no re 'debug'";
753 # isolate the real diffs and report them.
754 # i.e. these kinds of errs:
755 # 1. missing or extra ops. this skews all following op-sequences
756 # 2. single op diff, the rest of the chain is unaltered
757 # in either case, std err report is inadequate;
760 my $got = $tc->{got};
761 my @got = split(/\n/, $got);
762 my $want = $tc->{wantstr};
763 my @want = split(/\n/, $want);
765 # split rexstr into units that should eat leading lines.
766 my @rexs = map qr/$_/, split (/\n/, $tc->{rexstr});
768 foreach my $rex (@rexs) {
769 my $exp = shift @want;
770 my $line = shift @got;
771 # remove matches, and report
772 unless ($got =~ s/($rex\n)//msg) {
773 _diag("got:\t\t'$line'\nwant:\t $rex\n");
776 _diag("remainder:\n$got");
777 _diag("these lines not matched:\n$got\n");
782 Unusually, this module also processes @ARGV for command-line arguments
783 which set global modes. These 'options' change the way the tests run,
784 essentially reusing the tests for different purposes.
788 Additionally, there's an experimental control-arg interface (i.e.
789 subject to change) which allows the user to set global modes.
792 =head1 Testing Method
794 At 1st, optreeCheck used one reference-text, but the differences
795 between Threaded and Non-threaded renderings meant that a single
796 reference (sampled from say, threaded) would be tricky and iterative
797 to convert for testing on a non-threaded build. Worse, this conflicts
798 with making tests both strict and precise.
800 We now use 2 reference texts, the right one is used based upon the
801 build's threaded-ness. This has several benefits:
803 1. native reference data allows closer/easier matching by regex.
804 2. samples can be eyeballed to grok T-nT differences.
805 3. data can help to validate mkCheckRex() operation.
806 4. can develop regexes which accomodate T-nT differences.
807 5. can test with both native and cross-converted regexes.
809 Cross-testing (expect_nt on threaded, expect on non-threaded) exposes
810 differences in B::Concise output, so mkCheckRex has code to do some
811 cross-test manipulations. This area needs more work.
815 One consequence of a single-function API is difficulty controlling
816 test-mode. I've chosen for now to use a package hash, %gOpts, to store
817 test-state. These properties alter checkOptree() function, either
818 short-circuiting to selftest, or running a loop that runs the testcase
819 2^N times, varying conditions each time. (current N is 2 only).
821 So Test-mode is controlled with cmdline args, also called options below.
822 Run with 'help' to see the test-state, and how to change it.
826 This argument invokes runSelftest(), which tests a regex against the
827 reference renderings that they're made from. Failure of a regex match
828 its 'mold' is a strong indicator that mkCheckRex is buggy.
830 That said, selftest mode currently runs a cross-test too, they're not
831 completely orthogonal yet. See below.
833 =head2 testmode=cross
835 Cross-testing is purposely creating a T-NT mismatch, looking at the
836 fallout, which helps to understand the T-NT differences.
838 The tweaking appears contrary to the 2-refs philosophy, but the tweaks
839 will be made in conversion-specific code, which (will) handles T->NT
840 and NT->T separately. The tweaking is incomplete.
842 A reasonable 1st step is to add tags to indicate when TonNT or NTonT
843 is known to fail. This needs an option to force failure, so the
844 test.pl reporting mechanics show results to aid the user.
846 =head2 testmode=native
848 This is normal mode. Other valid values are: native, cross, both.
850 =head2 checkOptree Notes
852 Accepts test code, renders its optree using B::Concise, and matches
853 that rendering against a regex built from one of 2 reference
856 The regex is built by mkCheckRex(\%tc), which scrubs %tc data to
857 remove match-irrelevancies, such as (args) and [args]. For example,
858 it strips leading '# ', making it easy to cut-paste new tests into
859 your test-file, run it, and cut-paste actual results into place. You
860 then retest and reedit until all 'errors' are gone. (now make sure you
861 haven't 'enshrined' a bug).
863 name: The test name. May be augmented by a label, which is built from
864 important params, and which helps keep names in sync with whats being
870 # tests the regex produced by mkCheckRex()
871 # by using on the expect* text it was created with
872 # failures indicate a code bug,
873 # OR regexs plugged into the expect* text (which defeat conversions)
876 for my $provenance (qw/ expect expect_nt /) {
877 #next unless $tc->{$provenance};
879 $tc->mkCheckRex($provenance);
880 $tc->{got} = $tc->{wantstr}; # fake the rendering
889 do { Dumper(@_); return } if $dumploaded;
891 eval "require Data::Dumper"
893 print "Sorry, Data::Dumper is not available\n";
894 print "half hearted attempt:\n";
896 if (ref $it eq 'HASH') {
897 print " $_ => $it->{$_}\n" foreach sort keys %$it;
903 Data::Dumper->import;
904 $Data::Dumper::Sortkeys = 1;
909 ############################
910 # support for test writing
913 my $testct = shift || 1;
919 \@INC = qw(../lib ../ext/B/t);
920 require q(./test.pl);
923 plan tests => $testct;
929 sub OptreeCheck::wrap {
931 $code =~ s/(?:(\#.*?)\n)//gsm;
932 $code =~ s/\s+/ /mgs;
934 return unless $code =~ /\S/;
939 checkOptree(note => q{$comment},
942 expect => <<EOT_EOT, expect_nt => <<EONT_EONT);
944 paste your 'golden-example' here, then retest
947 paste your 'golden-example' here, then retest
954 sub OptreeCheck::gentest {
955 my ($code,$opts) = @_;
956 my $rendering = getRendering({code => $code});
957 my $testcode = OptreeCheck::wrap($code);
958 return unless $testcode;
960 # run the prog, capture 'reference' concise output
961 my $preamble = preamble(1);
962 my $got = runperl( prog => "$preamble $testcode", stderr => 1,
963 #switches => ["-I../ext/B/t", "-MOptreeCheck"],
966 # extract the 'reftext' ie the got 'block'
967 if ($got =~ m/got \'.*?\n(.*)\n\# \'\n\# expected/s) {
969 #and plug it into the test-src
971 $testcode =~ s/ThreadedRef/$goldentxt/;
973 $testcode =~ s/NonThreadRef/$goldentxt/;
975 my $b4 = q{expect => <<EOT_EOT, expect_nt => <<EONT_EONT};
976 my $af = q{expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'};
977 $testcode =~ s/$b4/$af/;
980 if ($internal_retest) {
981 $got = runperl( prog => "$preamble $testcode", stderr => 1,
982 #switches => ["-I../ext/B/t", "-MOptreeCheck"],
992 sub OptreeCheck::processExamples {
995 # gets array of paragraphs, which should be code-samples. Theyre
996 # turned into optreeCheck tests,
998 foreach my $file (@files) {
999 open (my $fh, $file) or die "cant open $file: $!\n";
1002 print preamble (scalar @chunks);
1003 foreach $t (@chunks) {
1004 print "\n\n=for gentest\n\n# chunk: $t=cut\n\n";
1005 print OptreeCheck::gentest ($t);
1010 # OK - now for the final insult to your good taste...
1012 if ($0 =~ /OptreeCheck\.pm/) {
1015 require './t/test.pl';
1017 # invoked as program. Work like former gentest.pl,
1018 # ie read files given as cmdline args,
1019 # convert them to usable test files.
1021 require Getopt::Std;
1022 Getopt::Std::getopts('') or
1023 die qq{ $0 sample-files* # no options
1025 expecting filenames as args. Each should have paragraphs,
1026 these are converted to checkOptree() tests, and printed to
1027 stdout. Redirect to file then edit for test. \n};
1029 OptreeCheck::processExamples(@ARGV);
1036 =head1 TEST DEVELOPMENT SUPPORT
1038 This optree regression testing framework needs tests in order to find
1039 bugs. To that end, OptreeCheck has support for developing new tests,
1040 according to the following model:
1042 1. write a set of sample code into a single file, one per
1043 paragraph. Add <=for gentest> blocks if you care to, or just look at
1044 f_map and f_sort in ext/B/t/ for examples.
1046 2. run OptreeCheck as a program on the file
1048 ./perl -Ilib ext/B/t/OptreeCheck.pm -w ext/B/t/f_map
1049 ./perl -Ilib ext/B/t/OptreeCheck.pm -w ext/B/t/f_sort
1051 gentest reads the sample code, runs each to generate a reference
1052 rendering, folds this rendering into an optreeCheck() statement,
1053 and prints it to stdout.
1055 3. run the output file as above, redirect to files, then rerun on
1056 same build (for sanity check), and on thread-opposite build. With
1057 editor in 1 window, and cmd in other, it's fairly easy to cut-paste
1058 the gots into the expects, easier than running step 2 on both
1059 builds then trying to sdiff them together.
1063 This code is purely for testing core. While checkOptree feels flexible
1064 enough to be stable, the whole selftest framework is subject to change