This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Bump version of B/t/OptreeCheck to 0.16
[perl5.git] / ext / B / t / OptreeCheck.pm
1 package OptreeCheck;
2 use parent 'Exporter';
3 use strict;
4 use warnings;
5 use vars qw($TODO $Level $using_open);
6 require "test.pl";
7
8 our $VERSION = '0.16';
9
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 tempfile);
13
14
15 # The hints flags will differ if ${^OPEN} is set.
16 # The approach taken is to put the hints-with-open in the golden results, and
17 # flag that they need to be taken out if ${^OPEN} is set.
18
19 if (((caller 0)[10]||{})->{'open<'}) {
20     $using_open = 1;
21 }
22
23 =head1 NAME
24
25 OptreeCheck - check optrees as rendered by B::Concise
26
27 =head1 SYNOPSIS
28
29 OptreeCheck supports 'golden-sample' regression testing of perl's
30 parser, optimizer, bytecode generator, via a single function:
31 checkOptree(%in).
32
33 It invokes B::Concise upon the sample code, checks that the rendering
34 'agrees' with the golden sample, and reports mismatches.
35
36 Additionally, the module processes @ARGV (which is typically unused in
37 the Core test harness), and thus provides a means to run the tests in
38 various modes.
39
40 =head1 EXAMPLE
41
42   # your test file
43   use OptreeCheck;
44   plan tests => 1;
45
46   checkOptree (
47     name   => "test-name',      # optional, made from others if not given
48
49     # code-under-test: must provide 1 of them
50     code   => sub {my $a},      # coderef, or source (wrapped and evald)
51     prog   => 'sort @a',        # run in subprocess, aka -MO=Concise
52     bcopts => '-exec',          # $opt or \@opts, passed to BC::compile
53
54     errs   => 'Name "main::a" used only once: possible typo at -e line 1.',
55                                 # str, regex, [str+] [regex+],
56
57     # various test options
58     # errs   => '.*',           # match against any emitted errs, -w warnings
59     # skip => 1,                # skips test
60     # todo => 'excuse',         # anticipated failures
61     # fail => 1                 # force fail (by redirecting result)
62
63     # the 'golden-sample's, (must provide both)
64
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
69  EOT_EOT
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
73  EONT_EONT
74
75  __END__
76
77 =head2 Failure Reports
78
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
81
82  $> PERL_CORE=1 ./perl ext/B/t/optree_check.t  testmode=cross
83  ...
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
88  # 2  <#> gvsv[*b] s
89  # 3  <$> const[IV 42] s
90  # 4  <2> add[t3] sK/2
91  # 5  <#> gvsv[*a] s
92  # 6  <2> sassign sKS/2
93  # 7  <1> leavesub[1 ref] K/REFC,1
94  # '
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
102  # $)/
103  # got:          '2  <#> gvsv[*b] s'
104  # want:  (?^:2  <\$> gvsv\(\*b\) s)
105  # got:          '3  <$> const[IV 42] s'
106  # want:  (?^:3  <\$> const\(IV 42\) s)
107  # got:          '5  <#> gvsv[*a] s'
108  # want:  (?^:5  <\$> gvsv\(\*a\) s)
109  # remainder:
110  # 2  <#> gvsv[*b] s
111  # 3  <$> const[IV 42] s
112  # 5  <#> gvsv[*a] s
113  # these lines not matched:
114  # 2  <#> gvsv[*b] s
115  # 3  <$> const[IV 42] s
116  # 5  <#> gvsv[*a] s
117
118 Errors are reported 3 different ways;
119
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.
124
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
128 unhelpful.
129
130 =head1 TestCase Overview
131
132 checkOptree(%tc) constructs a testcase object from %tc, and then calls
133 methods which eventually call test.pl's like() to produce test
134 results.
135
136 =head2 getRendering
137
138 getRendering() runs code or prog or progfile through B::Concise, and
139 captures its rendering.  Errors emitted during rendering are checked
140 against expected errors, and are reported as diagnostics by default,
141 or as failures if 'report=fail' cmdline-option is given.
142
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};
147
148 =head2 mkCheckRex
149
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.
153
154 The regex includes 'workarounds' which accommodate expected rendering
155 variations. These include:
156
157   string constants              # avoid injection
158   line numbers, etc             # args of nexstate()
159   hexadecimal-numbers
160
161   pad-slot-assignments          # for 5.8 compat, and testmode=cross
162   (map|grep)(start|while)       # for 5.8 compat
163
164 =head2 mylike
165
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.
169
170 =head1 checkOptree API and Operation
171
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
175 prototype object.
176
177 =head2 name => STRING
178
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
181 it manually.
182
183 =head2 code or prog or progfile
184
185 Either code or prog or progfile must be present.
186
187 =head2 prog => $perl_source_string
188
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:
191
192     './perl -w -MO=Concise,$bcopts_massaged -e $src'
193
194 =head2 progfile => $perl_script
195
196 progfile => $file provides a file containing a snippet of code which is
197 run as per the prog => $src example above.
198
199 =head2 code => $perl_source_string || CODEREF
200
201 The $code arg is passed to B::Concise::compile(), and run in-process.
202 If $code is a string, it's first wrapped and eval'd into a $coderef.
203 In either case, $coderef is then passed to B::Concise::compile():
204
205     $subref = eval "sub{$code}";
206     $render = B::Concise::compile($subref)->();
207
208 =head2 expect and expect_nt
209
210 expect and expect_nt args are the B<golden-sample> renderings, and are
211 sampled from known-ok threaded and un-threaded bleadperl (5.9.1) builds.
212 They're both required, and the correct one is selected for the platform
213 being tested, and saved into the synthesized property B<wanted>.
214
215 Individual sample lines may be suffixed with whitespace followed
216 by (<|<=|==|>=|>)5.nnnn (up to two times) to
217 select that line only for the listed perl
218 version; the whitespace and conditional are stripped.
219
220 =head2 bcopts => $bcopts || [ @bcopts ]
221
222 When getRendering() runs, it passes bcopts into B::Concise::compile().
223 The bcopts arg can be a single string, or an array of strings.
224
225 =head2 errs => $err_str_regex || [ @err_str_regexs ] 
226
227 getRendering() processes the code or prog or progfile arg under warnings,
228 and both parsing and optree-traversal errors are collected.  These are
229 validated against the one or more errors you specify.
230
231 =head1 testcase modifier properties
232
233 These properties are set as %tc parameters to change test behavior.
234
235 =head2 skip => 'reason'
236
237 invokes skip('reason'), causing test to skip.
238
239 =head2 todo => 'reason'
240
241 invokes todo('reason')
242
243 =head2 fail => 1
244
245 For code arguments, this option causes getRendering to redirect the
246 rendering operation to STDERR, which causes the regex match to fail.
247
248 =head2 noanchors => 1
249
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.
252
253
254 =head1 Synthesized object properties
255
256 These properties are added into the test object during execution.
257
258 =head2 wanted
259
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,
262 thus saving space.
263
264 =head2 cross => 1
265
266 This tag is added if testmode=cross is passed in as argument.
267 It causes test-harness to purposely use the wrong string.
268
269
270 =head2 checkErrs
271
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.
275
276 =cut
277
278 use Config;
279 use Carp;
280 use B::Concise qw(walk_output);
281
282 BEGIN {
283     $SIG{__WARN__} = sub {
284         my $err = shift;
285         $err =~ m/Subroutine re::(un)?install redefined/ and return;
286     };
287 }
288
289 sub import {
290     my $pkg = shift;
291     $pkg->export_to_level(1,'checkOptree', @EXPORT);
292     getCmdLine();       # process @ARGV
293 }
294
295
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
299
300 our %gOpts =    # values are replaced at runtime !!
301     (
302      # scalar values are help string
303      selftest   => 'self-tests mkCheckRex vs the reference rendering',
304
305      fail       => 'force all test to fail, print to stdout',
306      dump       => 'dump cmdline arg processing',
307      noanchors  => 'dont anchor match rex',
308
309      # array values are one-of selections, with 1st value as default
310      #  array: 2nd value is used as help-str, 1st val (still) default
311      help       => [0, 'provides help and exits', 0],
312      testmode   => [qw/ native cross both /],
313
314      # fixup for VMS, cygwin, which don't have stderr b4 stdout
315      rxnoorder  => [1, 'if 1, dont req match on -e lines, and -banner',0],
316      strip      => [1, 'if 1, catch errs and remove from renderings',0],
317      stripv     => 'if strip&&1, be verbose about it',
318      errs       => 'expected compile errs, array if several',
319     );
320
321
322 # Not sure if this is too much cheating. Officially we say that
323 # $Config::Config{usethreads} is true if some sort of threading is in
324 # use, in which case we ought to be able to use it in place of the ||
325 # below.  However, it is now possible to Configure perl with "threads"
326 # but neither ithreads or 5005threads, which forces the re-entrant
327 # APIs, but no perl user visible threading.
328
329 # This seems to have the side effect that most of perl doesn't think
330 # that it's threaded, hence the ops aren't threaded either.  Not sure
331 # if this is actually a "supported" configuration, but given that
332 # ponie uses it, it's going to be used by something official at least
333 # in the interim. So it's nice for tests to all pass.
334
335 our $threaded = 1
336   if $Config::Config{useithreads} || $Config::Config{use5005threads};
337 our $platform = ($threaded) ? "threaded" : "plain";
338 our $thrstat = ($threaded)  ? "threaded" : "nonthreaded";
339
340 our %modes = (
341               both      => [ 'expect', 'expect_nt'],
342               native    => [ ($threaded) ? 'expect' : 'expect_nt'],
343               cross     => [ !($threaded) ? 'expect' : 'expect_nt'],
344               expect    => [ 'expect' ],
345               expect_nt => [ 'expect_nt' ],
346               );
347
348 our %msgs # announce cross-testing.
349     = (
350        # cross-platform
351        'expect_nt-threaded' => " (nT on T) ",
352        'expect-nonthreaded' => " (T on nT) ",
353        # native - nothing to say (must stay empty - used for $crosstesting)
354        'expect_nt-nonthreaded'  => '',
355        'expect-threaded'        => '',
356        );
357
358 #######
359 sub getCmdLine {        # import assistant
360     # offer help
361     print(qq{\n$0 accepts args to update these state-vars:
362              turn on a flag by typing its name,
363              select a value from list by typing name=val.\n    },
364           mydumper(\%gOpts))
365         if grep /help/, @ARGV;
366
367     # replace values for each key !! MUST MARK UP %gOpts
368     foreach my $opt (keys %gOpts) {
369
370         # scan ARGV for known params
371         if (ref $gOpts{$opt} eq 'ARRAY') {
372
373             # $opt is a One-Of construct
374             # replace with valid selection from the list
375
376             # uhh this WORKS. but it's inscrutable
377             # grep s/$opt=(\w+)/grep {$_ eq $1} @ARGV and $gOpts{$opt}=$1/e, @ARGV;
378             my $tval;  # temp
379             if (grep s/$opt=(\w+)/$tval=$1/e, @ARGV) {
380                 # check val before accepting
381                 my @allowed = @{$gOpts{$opt}};
382                 if (grep { $_ eq $tval } @allowed) {
383                     $gOpts{$opt} = $tval;
384                 }
385                 else {die "invalid value: '$tval' for $opt\n"}
386             }
387
388             # take 1st val as default
389             $gOpts{$opt} = ${$gOpts{$opt}}[0]
390                 if ref $gOpts{$opt} eq 'ARRAY';
391         }
392         else { # handle scalars
393
394             # if 'opt' is present, true
395             $gOpts{$opt} = (grep /^$opt/, @ARGV) ? 1 : 0;
396
397             # override with 'foo' if 'opt=foo' appears
398             grep s/$opt=(.*)/$gOpts{$opt}=$1/e, @ARGV;
399         }
400      }
401     print("$0 heres current state:\n", mydumper(\%gOpts))
402         if $gOpts{help} or $gOpts{dump};
403
404     exit if $gOpts{help};
405 }
406 # the above arg-handling cruft should be replaced by a Getopt call
407
408 ##############################
409 # the API (1 function)
410
411 sub checkOptree {
412     my $tc = newTestCases(@_);  # ctor
413     my ($rendering);
414
415     print "checkOptree args: ",mydumper($tc) if $tc->{dump};
416     SKIP: {
417         if ($tc->{skip}) {
418             skip("$tc->{skip} $tc->{name}",
419                     ($gOpts{selftest}
420                         ? 1
421                         : 1 + @{$modes{$gOpts{testmode}}}
422                         )
423             );
424         }
425
426         return runSelftest($tc) if $gOpts{selftest};
427
428         $tc->getRendering();    # get the actual output
429         $tc->checkErrs();
430
431         local $Level = $Level + 2;
432       TODO:
433         foreach my $want (@{$modes{$gOpts{testmode}}}) {
434             local $TODO = $tc->{todo} if $tc->{todo};
435
436             $tc->{cross} = $msgs{"$want-$thrstat"};
437
438             $tc->mkCheckRex($want);
439             $tc->mylike();
440         }
441     }
442     return;
443 }
444
445 sub newTestCases {
446     # make test objects (currently 1) from args (passed to checkOptree)
447     my $tc = bless { @_ }, __PACKAGE__
448         or die "test cases are hashes";
449
450     $tc->label();
451
452     # cpy globals into each test
453     foreach my $k (keys %gOpts) {
454         if ($gOpts{$k}) {
455             $tc->{$k} = $gOpts{$k} unless defined $tc->{$k};
456         }
457     }
458     if ($tc->{errs}) {
459         $tc->{errs} = [$tc->{errs}] unless ref $tc->{errs} eq 'ARRAY';
460     }
461     return $tc;
462 }
463
464 sub label {
465     # may help get/keep test output consistent
466     my ($tc) = @_;
467     return $tc->{name} if $tc->{name};
468
469     my $buf = (ref $tc->{bcopts}) 
470         ? join(',', @{$tc->{bcopts}}) : $tc->{bcopts};
471
472     foreach (qw( note prog code )) {
473         $buf .= " $_: $tc->{$_}" if $tc->{$_} and not ref $tc->{$_};
474     }
475     return $tc->{name} = $buf;
476 }
477
478 #################
479 # render and its helpers
480
481 sub getRendering {
482     my $tc = shift;
483     fail("getRendering: code or prog or progfile is required")
484         unless $tc->{code} or $tc->{prog} or $tc->{progfile};
485
486     my @opts = get_bcopts($tc);
487     my $rendering = ''; # suppress "Use of uninitialized value in open"
488     my @errs;           # collect errs via 
489
490
491     if ($tc->{prog}) {
492         $rendering = runperl( switches => ['-w',join(',',"-MO=Concise",@opts)],
493                               prog => $tc->{prog}, stderr => 1,
494                               ); # verbose => 1);
495     } elsif ($tc->{progfile}) {
496         $rendering = runperl( switches => ['-w',join(',',"-MO=Concise",@opts)],
497                               progfile => $tc->{progfile}, stderr => 1,
498                               ); # verbose => 1);
499     } else {
500         my $code = $tc->{code};
501         unless (ref $code eq 'CODE') {
502             # treat as source, and wrap into subref 
503             #  in caller's package ( to test arg-fixup, comment next line)
504             my $pkg = '{ package '.caller(1) .';';
505             {
506                 BEGIN { $^H = 0 }
507                 no warnings;
508                 $code = eval "$pkg sub { $code } }";
509             }
510             # return errors
511             if ($@) { chomp $@; push @errs, $@ }
512         }
513         # set walk-output b4 compiling, which writes 'announce' line
514         walk_output(\$rendering);
515
516         my $opwalker = B::Concise::compile(@opts, $code);
517         die "bad BC::compile retval" unless ref $opwalker eq 'CODE';
518
519       B::Concise::reset_sequence();
520         $opwalker->();
521
522         # kludge error into rendering if its empty.
523         $rendering = $@ if $@ and ! $rendering;
524     }
525     # separate banner, other stuff whose printing order isnt guaranteed
526     if ($tc->{strip}) {
527         $rendering =~ s/(B::Concise::compile.*?\n)//;
528         print "stripped from rendering <$1>\n" if $1 and $tc->{stripv};
529
530         #while ($rendering =~ s/^(.*?(-e) line \d+\.)\n//g) {
531         while ($rendering =~ s/^(.*?(-e|\(eval \d+\).*?) line \d+\.)\n//g) {
532             print "stripped <$1> $2\n" if $tc->{stripv};
533             push @errs, $1;
534         }
535         $rendering =~ s/-e syntax OK\n//;
536         $rendering =~ s/-e had compilation errors\.\n//;
537     }
538     $tc->{got}     = $rendering;
539     $tc->{goterrs} = \@errs if @errs;
540     return $rendering, @errs;
541 }
542
543 sub get_bcopts {
544     # collect concise passthru-options if any
545     my ($tc) = shift;
546     my @opts = ();
547     if ($tc->{bcopts}) {
548         @opts = (ref $tc->{bcopts} eq 'ARRAY')
549             ? @{$tc->{bcopts}} : ($tc->{bcopts});
550     }
551     return @opts;
552 }
553
554 sub checkErrs {
555     # check rendering errs against expected errors, reduce and report
556     my $tc = shift;
557
558     # check for agreement (order not important)
559     my (%goterrs, @missed);
560     @goterrs{@{$tc->{goterrs}}} = (1) x scalar @{$tc->{goterrs}}
561         if $tc->{goterrs};
562
563     foreach my $want (@{$tc->{errs}}) {
564         if (ref $want) {
565             my $seen;
566             foreach my $k (keys %goterrs) {
567                 next unless $k =~ $want;
568                 delete $goterrs{$k};
569                 ++$seen;
570             }
571             push @missed, $want unless $seen;
572         } else {
573             push @missed, $want unless defined delete $goterrs{$want};
574         }
575     }
576
577     @missed = sort @missed;
578     my @got = sort keys %goterrs;
579
580     if (@{$tc->{errs}}) {
581         is(@missed + @got, 0, "Only got expected errors for $tc->{name}")
582     } else {
583         # @missed must be 0 here.
584         is(scalar @got, 0, "Got no errors for $tc->{name}")
585     }
586     _diag(join "\n", "got unexpected:", @got) if @got;
587     _diag(join "\n", "missed expected:", @missed) if @missed;
588 }
589
590 =head1 mkCheckRex ($tc)
591
592 It selects the correct golden-sample from the test-case object, and
593 converts it into a Regexp which should match against the original
594 golden-sample (used in selftest, see below), and on the renderings
595 obtained by applying the code on the perl being tested.
596
597 The selection is driven by platform mostly, but also by test-mode,
598 which rather complicates the code.  This is worsened by the potential
599 need to make platform specific conversions on the reftext.
600
601 but is otherwise as strict as possible.  For example, it should *not*
602 match when opcode flags change, or when optimizations convert an op to
603 an ex-op.
604
605
606 =head2 match criteria
607
608 The selected golden-sample is massaged to eliminate various match
609 irrelevancies.  This is done so that the tests don't fail just because
610 you added a line to the top of the test file.  (Recall that the
611 renderings contain the program's line numbers).  Similar cleanups are
612 done on "strings", hex-constants, etc.
613
614 The need to massage is reflected in the 2 golden-sample approach of
615 the test-cases; we want the match to be as rigorous as possible, and
616 thats easier to achieve when matching against 1 input than 2.
617
618 Opcode arguments (text within braces) are disregarded for matching
619 purposes.  This loses some info in 'add[t5]', but greatly simplifies
620 matching 'nextstate(main 22 (eval 10):1)'.  Besides, we are testing
621 for regressions, not for complete accuracy.
622
623 The regex is anchored by default, but can be suppressed with
624 'noanchors', allowing 1-liner tests to succeed if opcode is found.
625
626 =cut
627
628 # needless complexity due to 'too much info' from B::Concise v.60
629 my $announce = 'B::Concise::compile\(CODE\(0x[0-9a-f]+\)\)';;
630
631 sub mkCheckRex {
632     # converts expected text into Regexp which should match against
633     # unaltered version.  also adjusts threaded => non-threaded
634     my ($tc, $want) = @_;
635
636     my $str = $tc->{expect} || $tc->{expect_nt};        # standard bias
637     $str = $tc->{$want} if $want && $tc->{$want};       # stated pref
638
639     die("no '$want' golden-sample found: $tc->{name}") unless $str;
640
641     $str =~ s/^\# //mg; # ease cut-paste testcase authoring
642
643     # strip out conditional lines
644
645     $str =~ s{^(.*?)   \s+(<|<=|==|>=|>)\s*(5\.\d+)
646                     (?:\s+(<|<=|==|>=|>)\s*(5\.\d+))? \ *\n}
647      {
648         my ($line, $cmp, $version, $cmp2, $v2) = ($1,$2,$3,$4,$5,$6);
649         my $repl = "";
650         if (  $cmp eq '<'  ? $] <  $version
651             : $cmp eq '<=' ? $] <= $version
652             : $cmp eq '==' ? $] == $version
653             : $cmp eq '>=' ? $] >= $version
654             : $cmp eq '>'  ? $] >  $version
655             : die("bad comparison '$cmp' in string [$str]\n")
656          and !$cmp2 || (
657               $cmp2 eq '<'  ? $] <  $v2
658             : $cmp2 eq '<=' ? $] <= $v2
659             : $cmp2 eq '==' ? $] == $v2
660             : $cmp2 eq '>=' ? $] >= $v2
661             : $cmp2 eq '>'  ? $] >  $v2
662             : die("bad comparison '$cmp2' in string [$str]\n")
663           )
664         ) {
665             $repl = "$line\n";
666         }
667         $repl;
668      }gemx;
669
670     $tc->{wantstr} = $str;
671
672     # make UNOP_AUX flag type literal
673     $str =~ s/<\+>/<\\+>/;
674     # make targ args wild
675     $str =~ s/\[t\d+\]/[t\\d+]/msg;
676
677     # escape bracing, etc.. manual \Q (doesn't escape '+')
678     $str =~ s/([\[\]()*.\$\@\#\|{}])/\\$1/msg;
679     # $str =~ s/(?<!\\)([\[\]\(\)*.\$\@\#\|{}])/\\$1/msg;
680
681     # treat dbstate like nextstate (no in-debugger false reports)
682     # Note also that there may be 1 level of () nexting, if there's an eval
683     # Seems easiest to explicitly match the eval, rather than trying to parse
684     # for full balancing and then substitute .*?
685     # In which case, we can continue to match for the eval in the rexexp built
686     # from the golden result.
687
688     $str =~ s!(?:next|db)state
689               \\\(                      # opening literal ( (backslash escaped)
690               [^()]*?                   # not ()
691               (\\\(eval\ \d+\\\)        # maybe /eval \d+/ in ()
692                [^()]*?                  # which might be followed by something
693               )?
694               \\\)                      # closing literal )
695              !'(?:next|db)state\\([^()]*?' .
696               ($1 && '\\(eval \\d+\\)[^()]*')   # Match the eval if present
697               . '\\)'!msgxe;
698     # widened for -terse mode
699     $str =~ s/(?:next|db)state/(?:next|db)state/msg;
700     if (!$using_open && $tc->{strip_open_hints}) {
701       $str =~ s[(                       # capture
702                  \(\?:next\|db\)state   # the regexp matching next/db state
703                  .*                     # all sorts of things follow it
704                  v                      # The opening v
705                 )
706                 (?:(:>,<,%,\\\{)                # hints when open.pm is in force
707                    |(:>,<,%))           # (two variations)
708                 (\ ->(?:-|[0-9a-z]+))?
709                 $
710                ]
711         [$1 . ($2 && ':\{') . $4]xegm;  # change to the hints without open.pm
712     }
713
714
715     # don't care about:
716     $str =~ s/:-?\d+,-?\d+/:-?\\d+,-?\\d+/msg;          # FAKE line numbers
717     $str =~ s/match\\\(.*?\\\)/match\(.*?\)/msg;        # match args
718     $str =~ s/(0x[0-9A-Fa-f]+)/0x[0-9A-Fa-f]+/msg;      # hexnum values
719     $str =~ s/".*?"/".*?"/msg;                          # quoted strings
720     $str =~ s/FAKE:(\w):\d+/FAKE:$1:\\d+/msg;           # parent pad index
721
722     $str =~ s/(\d refs?)/\\d+ refs?/msg;                # 1 ref, 2+ refs (plural)
723     $str =~ s/leavesub \[\d\]/leavesub [\\d]/msg;       # for -terse
724     #$str =~ s/(\s*)\n/\n/msg;                          # trailing spaces
725     
726     croak "whitespace only reftext found for '$want': $tc->{name}"
727         unless $str =~ /\w+/; # fail unless a real test
728     
729     # $str = '.*'       if 1;   # sanity test
730     # $str .= 'FAIL'    if 1;   # sanity test
731
732     # allow -eval, banner at beginning of anchored matches
733     $str = "(-e .*?)?(B::Concise::compile.*?)?\n" . $str
734         unless $tc->{noanchors} or $tc->{rxnoorder};
735     
736     my $qr = ($tc->{noanchors}) ? qr/$str/ms : qr/^$str$/ms ;
737
738     $tc->{rex}          = $qr;
739     $tc->{rexstr}       = $str;
740     $tc;
741 }
742
743 ##############
744 # compare and report
745
746 sub mylike {
747     # reworked mylike to use hash-obj
748     my $tc      = shift;
749     my $got     = $tc->{got};
750     my $want    = $tc->{rex};
751     my $cmnt    = $tc->{name};
752     my $cross   = $tc->{cross};
753
754     # bad is anticipated failure
755     my $bad = ($cross && $tc->{crossfail}) || (!$cross && $tc->{fail});
756
757     my $ok = $bad ? unlike ($got, $want, $cmnt) : like ($got, $want, $cmnt);
758
759     reduceDiffs ($tc) if not $ok;
760
761     return $ok;
762 }
763
764 sub reduceDiffs {
765     # isolate the real diffs and report them.
766     # i.e. these kinds of errs:
767     # 1. missing or extra ops.  this skews all following op-sequences
768     # 2. single op diff, the rest of the chain is unaltered
769     # in either case, std err report is inadequate;
770
771     my $tc      = shift;
772     my $got     = $tc->{got};
773     my @got     = split(/\n/, $got);
774     my $want    = $tc->{wantstr};
775     my @want    = split(/\n/, $want);
776
777     # split rexstr into units that should eat leading lines.
778     my @rexs = map qr/$_/, split (/\n/, $tc->{rexstr});
779
780     foreach my $rex (@rexs) {
781         my $exp = shift @want;
782         my $line = shift @got;
783         # remove matches, and report
784         unless ($got =~ s/^($rex\n)//ms) {
785             _diag("got:\t\t'$line'\nwant:\t $rex\n");
786             last;
787         }
788     }
789     _diag("remainder:\n$got");
790     _diag("these lines not matched:\n$got\n");
791 }
792
793 =head1 Global modes
794
795 Unusually, this module also processes @ARGV for command-line arguments
796 which set global modes.  These 'options' change the way the tests run,
797 essentially reusing the tests for different purposes.
798
799
800
801 Additionally, there's an experimental control-arg interface (i.e.
802 subject to change) which allows the user to set global modes.
803
804
805 =head1 Testing Method
806
807 At 1st, optreeCheck used one reference-text, but the differences
808 between Threaded and Non-threaded renderings meant that a single
809 reference (sampled from say, threaded) would be tricky and iterative
810 to convert for testing on a non-threaded build.  Worse, this conflicts
811 with making tests both strict and precise.
812
813 We now use 2 reference texts, the right one is used based upon the
814 build's threaded-ness.  This has several benefits:
815
816  1. native reference data allows closer/easier matching by regex.
817  2. samples can be eyeballed to grok T-nT differences.
818  3. data can help to validate mkCheckRex() operation.
819  4. can develop regexes which accommodate T-nT differences.
820  5. can test with both native and cross-converted regexes.
821
822 Cross-testing (expect_nt on threaded, expect on non-threaded) exposes
823 differences in B::Concise output, so mkCheckRex has code to do some
824 cross-test manipulations.  This area needs more work.
825
826 =head1 Test Modes
827
828 One consequence of a single-function API is difficulty controlling
829 test-mode.  I've chosen for now to use a package hash, %gOpts, to store
830 test-state.  These properties alter checkOptree() function, either
831 short-circuiting to selftest, or running a loop that runs the testcase
832 2^N times, varying conditions each time.  (current N is 2 only).
833
834 So Test-mode is controlled with cmdline args, also called options below.
835 Run with 'help' to see the test-state, and how to change it.
836
837 =head2  selftest
838
839 This argument invokes runSelftest(), which tests a regex against the
840 reference renderings that they're made from.  Failure of a regex match
841 its 'mold' is a strong indicator that mkCheckRex is buggy.
842
843 That said, selftest mode currently runs a cross-test too, they're not
844 completely orthogonal yet.  See below.
845
846 =head2 testmode=cross
847
848 Cross-testing is purposely creating a T-NT mismatch, looking at the
849 fallout, which helps to understand the T-NT differences.
850
851 The tweaking appears contrary to the 2-refs philosophy, but the tweaks
852 will be made in conversion-specific code, which (will) handles T->NT
853 and NT->T separately.  The tweaking is incomplete.
854
855 A reasonable 1st step is to add tags to indicate when TonNT or NTonT
856 is known to fail.  This needs an option to force failure, so the
857 test.pl reporting mechanics show results to aid the user.
858
859 =head2 testmode=native
860
861 This is normal mode.  Other valid values are: native, cross, both.
862
863 =head2 checkOptree Notes
864
865 Accepts test code, renders its optree using B::Concise, and matches
866 that rendering against a regex built from one of 2 reference
867 renderings %tc data.
868
869 The regex is built by mkCheckRex(\%tc), which scrubs %tc data to
870 remove match-irrelevancies, such as (args) and [args].  For example,
871 it strips leading '# ', making it easy to cut-paste new tests into
872 your test-file, run it, and cut-paste actual results into place.  You
873 then retest and reedit until all 'errors' are gone.  (now make sure you
874 haven't 'enshrined' a bug).
875
876 name: The test name.  May be augmented by a label, which is built from
877 important params, and which helps keep names in sync with whats being
878 tested.
879
880 =cut
881
882 sub runSelftest {
883     # tests the regex produced by mkCheckRex()
884     # by using on the expect* text it was created with
885     # failures indicate a code bug, 
886     # OR regexs plugged into the expect* text (which defeat conversions)
887     my $tc = shift;
888
889     for my $provenance (qw/ expect expect_nt /) {
890         #next unless $tc->{$provenance};
891
892         $tc->mkCheckRex($provenance);
893         $tc->{got} = $tc->{wantstr};    # fake the rendering
894         $tc->mylike();
895     }
896 }
897
898 my $dumploaded = 0;
899
900 sub mydumper {
901
902     do { Dumper(@_); return } if $dumploaded;
903
904     eval "require Data::Dumper"
905         or do{
906             print "Sorry, Data::Dumper is not available\n";
907             print "half hearted attempt:\n";
908             foreach my $it (@_) {
909                 if (ref $it eq 'HASH') {
910                     print " $_ => $it->{$_}\n" foreach sort keys %$it;
911                 }
912             }
913             return;
914         };
915
916     Data::Dumper->import;
917     $Data::Dumper::Sortkeys = 1;
918     $dumploaded++;
919     Dumper(@_);
920 }
921
922 ############################
923 # support for test writing
924
925 sub preamble {
926     my $testct = shift || 1;
927     return <<EO_HEADER;
928 #!perl
929
930 BEGIN {
931     chdir q(t);
932     \@INC = qw(../lib ../ext/B/t);
933     require q(./test.pl);
934 }
935 use OptreeCheck;
936 plan tests => $testct;
937
938 EO_HEADER
939
940 }
941
942 sub OptreeCheck::wrap {
943     my $code = shift;
944     $code =~ s/(?:(\#.*?)\n)//gsm;
945     $code =~ s/\s+/ /mgs;              
946     chomp $code;
947     return unless $code =~ /\S/;
948     my $comment = $1;
949     
950     my $testcode = qq{
951         
952 checkOptree(note   => q{$comment},
953             bcopts => q{-exec},
954             code   => q{$code},
955             expect => <<EOT_EOT, expect_nt => <<EONT_EONT);
956 ThreadedRef
957     paste your 'golden-example' here, then retest
958 EOT_EOT
959 NonThreadedRef
960     paste your 'golden-example' here, then retest
961 EONT_EONT
962     
963 };
964     return $testcode;
965 }
966
967 sub OptreeCheck::gentest {
968     my ($code,$opts) = @_;
969     my $rendering = getRendering({code => $code});
970     my $testcode = OptreeCheck::wrap($code);
971     return unless $testcode;
972
973     # run the prog, capture 'reference' concise output
974     my $preamble = preamble(1);
975     my $got = runperl( prog => "$preamble $testcode", stderr => 1,
976                        #switches => ["-I../ext/B/t", "-MOptreeCheck"], 
977                        );  #verbose => 1);
978     
979     # extract the 'reftext' ie the got 'block'
980     if ($got =~ m/got \'.*?\n(.*)\n\# \'\n\# expected/s) {
981         my $goldentxt = $1;
982         #and plug it into the test-src
983         if ($threaded) {
984             $testcode =~ s/ThreadedRef/$goldentxt/;
985         } else {
986             $testcode =~ s/NonThreadRef/$goldentxt/;
987         }
988         my $b4 = q{expect => <<EOT_EOT, expect_nt => <<EONT_EONT};
989         my $af = q{expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'};
990         $testcode =~ s/$b4/$af/;
991         
992         return $testcode;
993     }
994     return '';
995 }
996
997
998 sub OptreeCheck::processExamples {
999     my @files = @_;
1000
1001     # gets array of paragraphs, which should be code-samples.  They're
1002     # turned into optreeCheck tests,
1003
1004     foreach my $file (@files) {
1005         open (my $fh, '<', $file) or die "cant open $file: $!\n";
1006         $/ = "";
1007         my @chunks = <$fh>;
1008         print preamble (scalar @chunks);
1009         foreach my $t (@chunks) {
1010             print "\n\n=for gentest\n\n# chunk: $t=cut\n\n";
1011             print OptreeCheck::gentest ($t);
1012         }
1013     }
1014 }
1015
1016 # OK - now for the final insult to your good taste...  
1017
1018 if ($0 =~ /OptreeCheck\.pm/) {
1019
1020     #use lib 't';
1021     require './t/test.pl';
1022
1023     # invoked as program.  Work like former gentest.pl,
1024     # ie read files given as cmdline args,
1025     # convert them to usable test files.
1026
1027     require Getopt::Std;
1028     Getopt::Std::getopts('') or 
1029         die qq{ $0 sample-files*    # no options
1030
1031           expecting filenames as args.  Each should have paragraphs,
1032           these are converted to checkOptree() tests, and printed to
1033           stdout.  Redirect to file then edit for test. \n};
1034
1035   OptreeCheck::processExamples(@ARGV);
1036 }
1037
1038 1;
1039
1040 __END__
1041
1042 =head1 TEST DEVELOPMENT SUPPORT
1043
1044 This optree regression testing framework needs tests in order to find
1045 bugs.  To that end, OptreeCheck has support for developing new tests,
1046 according to the following model:
1047
1048  1. write a set of sample code into a single file, one per
1049     paragraph.  Add <=for gentest> blocks if you care to, or just look at
1050     f_map and f_sort in ext/B/t/ for examples.
1051
1052  2. run OptreeCheck as a program on the file
1053
1054    ./perl -Ilib ext/B/t/OptreeCheck.pm -w ext/B/t/f_map
1055    ./perl -Ilib ext/B/t/OptreeCheck.pm -w ext/B/t/f_sort
1056
1057    gentest reads the sample code, runs each to generate a reference
1058    rendering, folds this rendering into an optreeCheck() statement,
1059    and prints it to stdout.
1060
1061  3. run the output file as above, redirect to files, then rerun on
1062     same build (for sanity check), and on thread-opposite build.  With
1063     editor in 1 window, and cmd in other, it's fairly easy to cut-paste
1064     the gots into the expects, easier than running step 2 on both
1065     builds then trying to sdiff them together.
1066
1067 =head1 CAVEATS
1068
1069 This code is purely for testing core. While checkOptree feels flexible
1070 enough to be stable, the whole selftest framework is subject to change
1071 w/o notice.
1072
1073 =cut