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         if ($tc->{fail}) {
 518             fail("forced failure: stdout follows");
 519             walk_output(\*STDOUT);
 520         }
 521         my $opwalker = B::Concise::compile(@opts, $code);
 522         die "bad BC::compile retval" unless ref $opwalker eq 'CODE';
 523
 524       B::Concise::reset_sequence();
 525         $opwalker->();
 526
 527         # kludge error into rendering if its empty.
 528         $rendering = $@ if $@ and ! $rendering;
 529     }
 530     # separate banner, other stuff whose printing order isnt guaranteed
 531     if ($tc->{strip}) {
 532         $rendering =~ s/(B::Concise::compile.*?\n)//;
 533         print "stripped from rendering <$1>\n" if $1 and $tc->{stripv};
 534
 535         #while ($rendering =~ s/^(.*?(-e) line \d+\.)\n//g) {
 536         while ($rendering =~ s/^(.*?(-e|\(eval \d+\).*?) line \d+\.)\n//g) {
 537             print "stripped <$1> $2\n" if $tc->{stripv};
 538             push @errs, $1;
 539         }
 540         $rendering =~ s/-e syntax OK\n//;
 541         $rendering =~ s/-e had compilation errors\.\n//;
 542     }
 543     $tc->{got}     = $rendering;
 544     $tc->{goterrs} = \@errs if @errs;
 545     return $rendering, @errs;
 546 }
 547
 548 sub get_bcopts {
 549     # collect concise passthru-options if any
 550     my ($tc) = shift;
 551     my @opts = ();
 552     if ($tc->{bcopts}) {
 553         @opts = (ref $tc->{bcopts} eq 'ARRAY')
 554             ? @{$tc->{bcopts}} : ($tc->{bcopts});
 555     }
 556     return @opts;
 557 }
 558
 559 sub checkErrs {
 560     # check rendering errs against expected errors, reduce and report
 561     my $tc = shift;
 562
 563     # check for agreement, by hash (order less important)
 564     my (%goterrs, @got);
 565     @goterrs{@{$tc->{goterrs}}} = (1) x scalar @{$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     $tc->{goterrs} = \%goterrs;
 574
 575     # relook at altered
 576     if (%{$tc->{errs}} or %{$tc->{goterrs}}) {
 577         $tc->diag_or_fail();
 578     }
 579     fail("FORCED: $tc->{name}:\n$rendering") if $gOpts{fail}; # silly ?
 580 }
 581
 582 sub diag_or_fail {
 583     # help checkErrs
 584     my $tc = shift;
 585
 586     my @lines;
 587     push @lines, "got unexpected:", sort keys %{$tc->{goterrs}} if %{$tc->{goterrs}};
 588     push @lines, "missed expected:", sort keys %{$tc->{errs}}   if %{$tc->{errs}};
 589
 590     if (@lines) {
 591         unshift @lines, $tc->{name};
 592         my $report = join("\n", @lines);
 593
 594         if    ($gOpts{report} eq 'diag')        { _diag ($report) }
 595         elsif ($gOpts{report} eq 'fail')        { fail  ($report) }
 596         else                                    { print ($report) }
 597         next unless $gOpts{errcont}; # skip block
 598     }
 599 }
 600
 601 =head1 mkCheckRex ($tc)
 602
 603 It selects the correct golden-sample from the test-case object, and
 604 converts it into a Regexp which should match against the original
 605 golden-sample (used in selftest, see below), and on the renderings
 606 obtained by applying the code on the perl being tested.
 607
 608 The selection is driven by platform mostly, but also by test-mode,
 609 which rather complicates the code.  This is worsened by the potential
 610 need to make platform specific conversions on the reftext.
 611
 612 but is otherwise as strict as possible.  For example, it should *not*
 613 match when opcode flags change, or when optimizations convert an op to
 614 an ex-op.
 615
 616
 617 =head2 match criteria
 618
 619 The selected golden-sample is massaged to eliminate various match
 620 irrelevancies.  This is done so that the tests dont fail just because
 621 you added a line to the top of the test file.  (Recall that the
 622 renderings contain the program's line numbers).  Similar cleanups are
 623 done on "strings", hex-constants, etc.
 624
 625 The need to massage is reflected in the 2 golden-sample approach of
 626 the test-cases; we want the match to be as rigorous as possible, and
 627 thats easier to achieve when matching against 1 input than 2.
 628
 629 Opcode arguments (text within braces) are disregarded for matching
 630 purposes.  This loses some info in 'add[t5]', but greatly simplifies
 631 matching 'nextstate(main 22 (eval 10):1)'.  Besides, we are testing
 632 for regressions, not for complete accuracy.
 633
 634 The regex is anchored by default, but can be suppressed with
 635 'noanchors', allowing 1-liner tests to succeed if opcode is found.
 636
 637 =cut
 638
 639 # needless complexity due to 'too much info' from B::Concise v.60
 640 my $announce = 'B::Concise::compile\(CODE\(0x[0-9a-f]+\)\)';;
 641
 642 sub mkCheckRex {
 643     # converts expected text into Regexp which should match against
 644     # unaltered version.  also adjusts threaded => non-threaded
 645     my ($tc, $want) = @_;
 646     eval "no re 'debug'";
 647
 648     my $str = $tc->{expect} || $tc->{expect_nt};        # standard bias
 649     $str = $tc->{$want} if $want && $tc->{$want};       # stated pref
 650
 651     die("no '$want' golden-sample found: $tc->{name}") unless $str;
 652
 653     $str =~ s/^\# //mg; # ease cut-paste testcase authoring
 654
 655     if ($] < 5.009) {
 656         # add 5.8 private flags, which bleadperl (5.9.1) doesn't have/use/render
 657         # works because it adds no wildcards, which are butchered below..
 658         $str =~ s|(mapstart l?K\*?)|$1/2|mg;
 659         $str =~ s|(grepstart l?K\*?)|$1/2|msg;
 660         $str =~ s|(mapwhile.*? l?K)|$1/1|msg;
 661         $str =~ s|(grepwhile.*? l?K)|$1/1|msg;
 662     }
 663     $tc->{wantstr} = $str;
 664
 665     # convert all (args) and [args] to temp forms wo bracing
 666     $str =~ s/\[(.*?)\]/__CAPSQR$1__/msg;
 667     $str =~ s/\((.*?)\)/__CAPRND$1__/msg;
 668     $str =~ s/\((.*?)\)/__CAPRND$1__/msg; # nested () in nextstate
 669
 670     # escape bracing, etc.. manual \Q (doesnt escape '+')
 671     $str =~ s/([\[\]()*.\$\@\#\|{}])/\\$1/msg;
 672
 673     # now replace temp forms with original, preserving reference bracing
 674     $str =~ s/__CAPSQR(.*?)__\b/\\[$1\\]/msg; # \b is important
 675     $str =~ s/__CAPRND(.*?)__\b/\\($1\\)/msg;
 676     $str =~ s/__CAPRND(.*?)__\b/\\($1\\)/msg; # nested () in nextstate
 677
 678     # treat dbstate like nextstate (no in-debugger false reports)
 679     $str =~ s/(?:next|db)state(\\\(.*?\\\))/(?:next|db)state(.*?)/msg;
 680     # widened for -terse mode
 681     $str =~ s/(?:next|db)state/(?:next|db)state/msg;
 682
 683     # don't care about:
 684     $str =~ s/:-?\d+,-?\d+/:-?\\d+,-?\\d+/msg;          # FAKE line numbers
 685     $str =~ s/match\\\(.*?\\\)/match\(.*?\)/msg;        # match args
 686     $str =~ s/(0x[0-9A-Fa-f]+)/0x[0-9A-Fa-f]+/msg;      # hexnum values
 687     $str =~ s/".*?"/".*?"/msg;                          # quoted strings
 688
 689     $str =~ s/(\d refs?)/\\d+ refs?/msg;                # 1 ref, 2+ refs (plural)
 690     $str =~ s/leavesub \[\d\]/leavesub [\\d]/msg;       # for -terse
 691     #$str =~ s/(\s*)\n/\n/msg;                          # trailing spaces
 692
 693     # these fix up pad-slot assignment args
 694     if ($] < 5.009 or $tc->{cross}) {
 695         $str =~ s/\[t\d+\\]/\[t\\d+\\]/msg;     # pad slot assignments
 696     }
 697
 698     croak "no reftext found for $want: $tc->{name}"
 699         unless $str =~ /\w+/; # fail unless a real test
 700
 701     # $str = '.*'       if 1;   # sanity test
 702     # $str .= 'FAIL'    if 1;   # sanity test
 703
 704     # allow -eval, banner at beginning of anchored matches
 705     $str = "(-e .*?)?(B::Concise::compile.*?)?\n" . $str
 706         unless $tc->{noanchors} or $tc->{rxnoorder};
 707
 708     eval "use re 'debug'" if $debug;
 709     my $qr = ($tc->{noanchors}) ? qr/$str/ms : qr/^$str$/ms ;
 710     no re 'debug';
 711
 712     $tc->{rex}          = $qr;
 713     $tc->{rexstr}       = $str;
 714     $tc;
 715 }
 716
 717 ##############
 718 # compare and report
 719
 720 sub mylike {
 721     # reworked mylike to use hash-obj
 722     my $tc      = shift;
 723     my $got     = $tc->{got};
 724     my $want    = $tc->{rex};
 725     my $cmnt    = $tc->{name};
 726     my $cross   = $tc->{cross};
 727
 728     my $msgs    = $tc->{msgs};
 729     my $retry   = $tc->{retry}; # || $gopts{retry};
 730     my $debug   = $tc->{debug}; #|| $gopts{retrydbg};
 731
 732     # bad is anticipated failure
 733     my $bad = (0 or ( $cross && $tc->{crossfail})
 734                or (!$cross && $tc->{fail})
 735                or 0); # no undefs !
 736
 737     # same as A ^ B, but B has side effects
 738     my $ok = ( $bad  &&  unlike ($got, $want, $cmnt, @$msgs)
 739                or !$bad && like ($got, $want, $cmnt, @$msgs));
 740
 741     reduceDiffs ($tc) if not $ok;
 742
 743     if (not $ok and $retry) {
 744         # redo, perhaps with use re debug - NOT ROBUST
 745         eval "use re 'debug'" if $debug;
 746         $ok = ( $bad  &&  unlike ($got, $want, "(RETRY) $cmnt", @$msgs)
 747                 or !$bad && like ($got, $want, "(RETRY) $cmnt", @$msgs));
 748         eval "no re 'debug'";
 749     }
 750     return $ok;
 751 }
 752
 753 sub reduceDiffs {
 754     # isolate the real diffs and report them.
 755     # i.e. these kinds of errs:
 756     # 1. missing or extra ops.  this skews all following op-sequences
 757     # 2. single op diff, the rest of the chain is unaltered
 758     # in either case, std err report is inadequate;
 759
 760     my $tc      = shift;
 761     my $got     = $tc->{got};
 762     my @got     = split(/\n/, $got);
 763     my $want    = $tc->{wantstr};
 764     my @want    = split(/\n/, $want);
 765
 766     # split rexstr into units that should eat leading lines.
 767     my @rexs = map qr/$_/, split (/\n/, $tc->{rexstr});
 768
 769     foreach my $rex (@rexs) {
 770         my $exp = shift @want;
 771         my $line = shift @got;
 772         # remove matches, and report
 773         unless ($got =~ s/($rex\n)//msg) {
 774             _diag("got:\t\t'$line'\nwant:\t $rex\n");
 775         }
 776     }
 777     _diag("remainder:\n$got");
 778     _diag("these lines not matched:\n$got\n");
 779 }
 780
 781 =head1 Global modes
 782
 783 Unusually, this module also processes @ARGV for command-line arguments
 784 which set global modes.  These 'options' change the way the tests run,
 785 essentially reusing the tests for different purposes.
 786
 787
 788
 789 Additionally, there's an experimental control-arg interface (i.e.
 790 subject to change) which allows the user to set global modes.
 791
 792
 793 =head1 Testing Method
 794
 795 At 1st, optreeCheck used one reference-text, but the differences
 796 between Threaded and Non-threaded renderings meant that a single
 797 reference (sampled from say, threaded) would be tricky and iterative
 798 to convert for testing on a non-threaded build.  Worse, this conflicts
 799 with making tests both strict and precise.
 800
 801 We now use 2 reference texts, the right one is used based upon the
 802 build's threaded-ness.  This has several benefits:
 803
 804  1. native reference data allows closer/easier matching by regex.
 805  2. samples can be eyeballed to grok T-nT differences.
 806  3. data can help to validate mkCheckRex() operation.
 807  4. can develop regexes which accommodate T-nT differences.
 808  5. can test with both native and cross-converted regexes.
 809
 810 Cross-testing (expect_nt on threaded, expect on non-threaded) exposes
 811 differences in B::Concise output, so mkCheckRex has code to do some
 812 cross-test manipulations.  This area needs more work.
 813
 814 =head1 Test Modes
 815
 816 One consequence of a single-function API is difficulty controlling
 817 test-mode.  I've chosen for now to use a package hash, %gOpts, to store
 818 test-state.  These properties alter checkOptree() function, either
 819 short-circuiting to selftest, or running a loop that runs the testcase
 820 2^N times, varying conditions each time.  (current N is 2 only).
 821
 822 So Test-mode is controlled with cmdline args, also called options below.
 823 Run with 'help' to see the test-state, and how to change it.
 824
 825 =head2  selftest
 826
 827 This argument invokes runSelftest(), which tests a regex against the
 828 reference renderings that they're made from.  Failure of a regex match
 829 its 'mold' is a strong indicator that mkCheckRex is buggy.
 830
 831 That said, selftest mode currently runs a cross-test too, they're not
 832 completely orthogonal yet.  See below.
 833
 834 =head2 testmode=cross
 835
 836 Cross-testing is purposely creating a T-NT mismatch, looking at the
 837 fallout, which helps to understand the T-NT differences.
 838
 839 The tweaking appears contrary to the 2-refs philosophy, but the tweaks
 840 will be made in conversion-specific code, which (will) handles T->NT
 841 and NT->T separately.  The tweaking is incomplete.
 842
 843 A reasonable 1st step is to add tags to indicate when TonNT or NTonT
 844 is known to fail.  This needs an option to force failure, so the
 845 test.pl reporting mechanics show results to aid the user.
 846
 847 =head2 testmode=native
 848
 849 This is normal mode.  Other valid values are: native, cross, both.
 850
 851 =head2 checkOptree Notes
 852
 853 Accepts test code, renders its optree using B::Concise, and matches
 854 that rendering against a regex built from one of 2 reference
 855 renderings %tc data.
 856
 857 The regex is built by mkCheckRex(\%tc), which scrubs %tc data to
 858 remove match-irrelevancies, such as (args) and [args].  For example,
 859 it strips leading '# ', making it easy to cut-paste new tests into
 860 your test-file, run it, and cut-paste actual results into place.  You
 861 then retest and reedit until all 'errors' are gone.  (now make sure you
 862 haven't 'enshrined' a bug).
 863
 864 name: The test name.  May be augmented by a label, which is built from
 865 important params, and which helps keep names in sync with whats being
 866 tested.
 867
 868 =cut
 869
 870 sub runSelftest {
 871     # tests the regex produced by mkCheckRex()
 872     # by using on the expect* text it was created with
 873     # failures indicate a code bug,
 874     # OR regexs plugged into the expect* text (which defeat conversions)
 875     my $tc = shift;
 876
 877     for my $provenance (qw/ expect expect_nt /) {
 878         #next unless $tc->{$provenance};
 879
 880         $tc->mkCheckRex($provenance);
 881         $tc->{got} = $tc->{wantstr};    # fake the rendering
 882         $tc->mylike();
 883     }
 884 }
 885
 886 my $dumploaded = 0;
 887
 888 sub mydumper {
 889
 890     do { Dumper(@_); return } if $dumploaded;
 891
 892     eval "require Data::Dumper"
 893         or do{
 894             print "Sorry, Data::Dumper is not available\n";
 895             print "half hearted attempt:\n";
 896             foreach $it (@_) {
 897                 if (ref $it eq 'HASH') {
 898                     print " $_ => $it->{$_}\n" foreach sort keys %$it;
 899                 }
 900             }
 901             return;
 902         };
 903
 904     Data::Dumper->import;
 905     $Data::Dumper::Sortkeys = 1;
 906     $dumploaded++;
 907     Dumper(@_);
 908 }
 909
 910 ############################
 911 # support for test writing
 912
 913 sub preamble {
 914     my $testct = shift || 1;
 915     return <<EO_HEADER;
 916 #!perl
 917
 918 BEGIN {
 919     chdir q(t);
 920     \@INC = qw(../lib ../ext/B/t);
 921     require q(./test.pl);
 922 }
 923 use OptreeCheck;
 924 plan tests => $testct;
 925
 926 EO_HEADER
 927
 928 }
 929
 930 sub OptreeCheck::wrap {
 931     my $code = shift;
 932     $code =~ s/(?:(\#.*?)\n)//gsm;
 933     $code =~ s/\s+/ /mgs;
 934     chomp $code;
 935     return unless $code =~ /\S/;
 936     my $comment = $1;
 937
 938     my $testcode = qq{
 939
 940 checkOptree(note   => q{$comment},
 941             bcopts => q{-exec},
 942             code   => q{$code},
 943             expect => <<EOT_EOT, expect_nt => <<EONT_EONT);
 944 ThreadedRef
 945     paste your 'golden-example' here, then retest
 946 EOT_EOT
 947 NonThreadedRef
 948     paste your 'golden-example' here, then retest
 949 EONT_EONT
 950
 951 };
 952     return $testcode;
 953 }
 954
 955 sub OptreeCheck::gentest {
 956     my ($code,$opts) = @_;
 957     my $rendering = getRendering({code => $code});
 958     my $testcode = OptreeCheck::wrap($code);
 959     return unless $testcode;
 960
 961     # run the prog, capture 'reference' concise output
 962     my $preamble = preamble(1);
 963     my $got = runperl( prog => "$preamble $testcode", stderr => 1,
 964                        #switches => ["-I../ext/B/t", "-MOptreeCheck"],
 965                        );  #verbose => 1);
 966
 967     # extract the 'reftext' ie the got 'block'
 968     if ($got =~ m/got \'.*?\n(.*)\n\# \'\n\# expected/s) {
 969         my $goldentxt = $1;
 970         #and plug it into the test-src
 971         if ($threaded) {
 972             $testcode =~ s/ThreadedRef/$goldentxt/;
 973         } else {
 974             $testcode =~ s/NonThreadRef/$goldentxt/;
 975         }
 976         my $b4 = q{expect => <<EOT_EOT, expect_nt => <<EONT_EONT};
 977         my $af = q{expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'};
 978         $testcode =~ s/$b4/$af/;
 979
 980         my $got;
 981         if ($internal_retest) {
 982             $got = runperl( prog => "$preamble $testcode", stderr => 1,
 983                             #switches => ["-I../ext/B/t", "-MOptreeCheck"],
 984                             verbose => 1);
 985             print "got: $got\n";
 986         }
 987         return $testcode;
 988     }
 989     return '';
 990 }
 991
 992
 993 sub OptreeCheck::processExamples {
 994     my @files = @_;
 995
 996     # gets array of paragraphs, which should be code-samples.  Theyre
 997     # turned into optreeCheck tests,
 998
 999     foreach my $file (@files) {
1000         open (my $fh, $file) or die "cant open $file: $!\n";
1001         $/ = "";
1002         my @chunks = <$fh>;
1003         print preamble (scalar @chunks);
1004         foreach $t (@chunks) {
1005             print "\n\n=for gentest\n\n# chunk: $t=cut\n\n";
1006             print OptreeCheck::gentest ($t);
1007         }
1008     }
1009 }
1010
1011 # OK - now for the final insult to your good taste...
1012
1013 if ($0 =~ /OptreeCheck\.pm/) {
1014
1015     #use lib 't';
1016     require './t/test.pl';
1017
1018     # invoked as program.  Work like former gentest.pl,
1019     # ie read files given as cmdline args,
1020     # convert them to usable test files.
1021
1022     require Getopt::Std;
1023     Getopt::Std::getopts('') or
1024         die qq{ $0 sample-files*    # no options
1025
1026           expecting filenames as args.  Each should have paragraphs,
1027           these are converted to checkOptree() tests, and printed to
1028           stdout.  Redirect to file then edit for test. \n};
1029
1030   OptreeCheck::processExamples(@ARGV);
1031 }
1032
1033 1;
1034
1035 __END__
1036
1037 =head1 TEST DEVELOPMENT SUPPORT
1038
1039 This optree regression testing framework needs tests in order to find
1040 bugs.  To that end, OptreeCheck has support for developing new tests,
1041 according to the following model:
1042
1043  1. write a set of sample code into a single file, one per
1044     paragraph.  Add <=for gentest> blocks if you care to, or just look at
1045     f_map and f_sort in ext/B/t/ for examples.
1046
1047  2. run OptreeCheck as a program on the file
1048
1049    ./perl -Ilib ext/B/t/OptreeCheck.pm -w ext/B/t/f_map
1050    ./perl -Ilib ext/B/t/OptreeCheck.pm -w ext/B/t/f_sort
1051
1052    gentest reads the sample code, runs each to generate a reference
1053    rendering, folds this rendering into an optreeCheck() statement,
1054    and prints it to stdout.
1055
1056  3. run the output file as above, redirect to files, then rerun on
1057     same build (for sanity check), and on thread-opposite build.  With
1058     editor in 1 window, and cmd in other, it's fairly easy to cut-paste
1059     the gots into the expects, easier than running step 2 on both
1060     builds then trying to sdiff them together.
1061
1062 =head1 CAVEATS
1063
1064 This code is purely for testing core. While checkOptree feels flexible
1065 enough to be stable, the whole selftest framework is subject to change
1066 w/o notice.
1067
1068 =cut