ext/B/t/OptreeCheck.pm

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