ext/B/t/OptreeCheck.pm

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