ext/B/t/OptreeCheck.pm

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