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.02';
   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 dont 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 dont 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