ext/B/t/OptreeCheck.pm

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