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