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