This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
a099a97ec9d6d793b211d308a7b2e80a43b29d13
[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.13';
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)//msg) {
785             _diag("got:\t\t'$line'\nwant:\t $rex\n");
786         }
787     }
788     _diag("remainder:\n$got");
789     _diag("these lines not matched:\n$got\n");
790 }
791
792 =head1 Global modes
793
794 Unusually, this module also processes @ARGV for command-line arguments
795 which set global modes.  These 'options' change the way the tests run,
796 essentially reusing the tests for different purposes.
797
798
799
800 Additionally, there's an experimental control-arg interface (i.e.
801 subject to change) which allows the user to set global modes.
802
803
804 =head1 Testing Method
805
806 At 1st, optreeCheck used one reference-text, but the differences
807 between Threaded and Non-threaded renderings meant that a single
808 reference (sampled from say, threaded) would be tricky and iterative
809 to convert for testing on a non-threaded build.  Worse, this conflicts
810 with making tests both strict and precise.
811
812 We now use 2 reference texts, the right one is used based upon the
813 build's threaded-ness.  This has several benefits:
814
815  1. native reference data allows closer/easier matching by regex.
816  2. samples can be eyeballed to grok T-nT differences.
817  3. data can help to validate mkCheckRex() operation.
818  4. can develop regexes which accommodate T-nT differences.
819  5. can test with both native and cross-converted regexes.
820
821 Cross-testing (expect_nt on threaded, expect on non-threaded) exposes
822 differences in B::Concise output, so mkCheckRex has code to do some
823 cross-test manipulations.  This area needs more work.
824
825 =head1 Test Modes
826
827 One consequence of a single-function API is difficulty controlling
828 test-mode.  I've chosen for now to use a package hash, %gOpts, to store
829 test-state.  These properties alter checkOptree() function, either
830 short-circuiting to selftest, or running a loop that runs the testcase
831 2^N times, varying conditions each time.  (current N is 2 only).
832
833 So Test-mode is controlled with cmdline args, also called options below.
834 Run with 'help' to see the test-state, and how to change it.
835
836 =head2  selftest
837
838 This argument invokes runSelftest(), which tests a regex against the
839 reference renderings that they're made from.  Failure of a regex match
840 its 'mold' is a strong indicator that mkCheckRex is buggy.
841
842 That said, selftest mode currently runs a cross-test too, they're not
843 completely orthogonal yet.  See below.
844
845 =head2 testmode=cross
846
847 Cross-testing is purposely creating a T-NT mismatch, looking at the
848 fallout, which helps to understand the T-NT differences.
849
850 The tweaking appears contrary to the 2-refs philosophy, but the tweaks
851 will be made in conversion-specific code, which (will) handles T->NT
852 and NT->T separately.  The tweaking is incomplete.
853
854 A reasonable 1st step is to add tags to indicate when TonNT or NTonT
855 is known to fail.  This needs an option to force failure, so the
856 test.pl reporting mechanics show results to aid the user.
857
858 =head2 testmode=native
859
860 This is normal mode.  Other valid values are: native, cross, both.
861
862 =head2 checkOptree Notes
863
864 Accepts test code, renders its optree using B::Concise, and matches
865 that rendering against a regex built from one of 2 reference
866 renderings %tc data.
867
868 The regex is built by mkCheckRex(\%tc), which scrubs %tc data to
869 remove match-irrelevancies, such as (args) and [args].  For example,
870 it strips leading '# ', making it easy to cut-paste new tests into
871 your test-file, run it, and cut-paste actual results into place.  You
872 then retest and reedit until all 'errors' are gone.  (now make sure you
873 haven't 'enshrined' a bug).
874
875 name: The test name.  May be augmented by a label, which is built from
876 important params, and which helps keep names in sync with whats being
877 tested.
878
879 =cut
880
881 sub runSelftest {
882     # tests the regex produced by mkCheckRex()
883     # by using on the expect* text it was created with
884     # failures indicate a code bug, 
885     # OR regexs plugged into the expect* text (which defeat conversions)
886     my $tc = shift;
887
888     for my $provenance (qw/ expect expect_nt /) {
889         #next unless $tc->{$provenance};
890
891         $tc->mkCheckRex($provenance);
892         $tc->{got} = $tc->{wantstr};    # fake the rendering
893         $tc->mylike();
894     }
895 }
896
897 my $dumploaded = 0;
898
899 sub mydumper {
900
901     do { Dumper(@_); return } if $dumploaded;
902
903     eval "require Data::Dumper"
904         or do{
905             print "Sorry, Data::Dumper is not available\n";
906             print "half hearted attempt:\n";
907             foreach my $it (@_) {
908                 if (ref $it eq 'HASH') {
909                     print " $_ => $it->{$_}\n" foreach sort keys %$it;
910                 }
911             }
912             return;
913         };
914
915     Data::Dumper->import;
916     $Data::Dumper::Sortkeys = 1;
917     $dumploaded++;
918     Dumper(@_);
919 }
920
921 ############################
922 # support for test writing
923
924 sub preamble {
925     my $testct = shift || 1;
926     return <<EO_HEADER;
927 #!perl
928
929 BEGIN {
930     chdir q(t);
931     \@INC = qw(../lib ../ext/B/t);
932     require q(./test.pl);
933 }
934 use OptreeCheck;
935 plan tests => $testct;
936
937 EO_HEADER
938
939 }
940
941 sub OptreeCheck::wrap {
942     my $code = shift;
943     $code =~ s/(?:(\#.*?)\n)//gsm;
944     $code =~ s/\s+/ /mgs;              
945     chomp $code;
946     return unless $code =~ /\S/;
947     my $comment = $1;
948     
949     my $testcode = qq{
950         
951 checkOptree(note   => q{$comment},
952             bcopts => q{-exec},
953             code   => q{$code},
954             expect => <<EOT_EOT, expect_nt => <<EONT_EONT);
955 ThreadedRef
956     paste your 'golden-example' here, then retest
957 EOT_EOT
958 NonThreadedRef
959     paste your 'golden-example' here, then retest
960 EONT_EONT
961     
962 };
963     return $testcode;
964 }
965
966 sub OptreeCheck::gentest {
967     my ($code,$opts) = @_;
968     my $rendering = getRendering({code => $code});
969     my $testcode = OptreeCheck::wrap($code);
970     return unless $testcode;
971
972     # run the prog, capture 'reference' concise output
973     my $preamble = preamble(1);
974     my $got = runperl( prog => "$preamble $testcode", stderr => 1,
975                        #switches => ["-I../ext/B/t", "-MOptreeCheck"], 
976                        );  #verbose => 1);
977     
978     # extract the 'reftext' ie the got 'block'
979     if ($got =~ m/got \'.*?\n(.*)\n\# \'\n\# expected/s) {
980         my $goldentxt = $1;
981         #and plug it into the test-src
982         if ($threaded) {
983             $testcode =~ s/ThreadedRef/$goldentxt/;
984         } else {
985             $testcode =~ s/NonThreadRef/$goldentxt/;
986         }
987         my $b4 = q{expect => <<EOT_EOT, expect_nt => <<EONT_EONT};
988         my $af = q{expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'};
989         $testcode =~ s/$b4/$af/;
990         
991         return $testcode;
992     }
993     return '';
994 }
995
996
997 sub OptreeCheck::processExamples {
998     my @files = @_;
999
1000     # gets array of paragraphs, which should be code-samples.  They're
1001     # turned into optreeCheck tests,
1002
1003     foreach my $file (@files) {
1004         open (my $fh, $file) or die "cant open $file: $!\n";
1005         $/ = "";
1006         my @chunks = <$fh>;
1007         print preamble (scalar @chunks);
1008         foreach my $t (@chunks) {
1009             print "\n\n=for gentest\n\n# chunk: $t=cut\n\n";
1010             print OptreeCheck::gentest ($t);
1011         }
1012     }
1013 }
1014
1015 # OK - now for the final insult to your good taste...  
1016
1017 if ($0 =~ /OptreeCheck\.pm/) {
1018
1019     #use lib 't';
1020     require './t/test.pl';
1021
1022     # invoked as program.  Work like former gentest.pl,
1023     # ie read files given as cmdline args,
1024     # convert them to usable test files.
1025
1026     require Getopt::Std;
1027     Getopt::Std::getopts('') or 
1028         die qq{ $0 sample-files*    # no options
1029
1030           expecting filenames as args.  Each should have paragraphs,
1031           these are converted to checkOptree() tests, and printed to
1032           stdout.  Redirect to file then edit for test. \n};
1033
1034   OptreeCheck::processExamples(@ARGV);
1035 }
1036
1037 1;
1038
1039 __END__
1040
1041 =head1 TEST DEVELOPMENT SUPPORT
1042
1043 This optree regression testing framework needs tests in order to find
1044 bugs.  To that end, OptreeCheck has support for developing new tests,
1045 according to the following model:
1046
1047  1. write a set of sample code into a single file, one per
1048     paragraph.  Add <=for gentest> blocks if you care to, or just look at
1049     f_map and f_sort in ext/B/t/ for examples.
1050
1051  2. run OptreeCheck as a program on the file
1052
1053    ./perl -Ilib ext/B/t/OptreeCheck.pm -w ext/B/t/f_map
1054    ./perl -Ilib ext/B/t/OptreeCheck.pm -w ext/B/t/f_sort
1055
1056    gentest reads the sample code, runs each to generate a reference
1057    rendering, folds this rendering into an optreeCheck() statement,
1058    and prints it to stdout.
1059
1060  3. run the output file as above, redirect to files, then rerun on
1061     same build (for sanity check), and on thread-opposite build.  With
1062     editor in 1 window, and cmd in other, it's fairly easy to cut-paste
1063     the gots into the expects, easier than running step 2 on both
1064     builds then trying to sdiff them together.
1065
1066 =head1 CAVEATS
1067
1068 This code is purely for testing core. While checkOptree feels flexible
1069 enough to be stable, the whole selftest framework is subject to change
1070 w/o notice.
1071
1072 =cut