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