ext/B/t/OptreeCheck.pm

   1 # non-package OptreeCheck.pm
   2 # pm allows 'use OptreeCheck', which also imports
   3 # no package decl means all functions defined into main
   4 # otherwise, it's like "require './test.pl'"
   5
   6 =head1 NAME
   7
   8 OptreeCheck - check optrees
   9
  10 =head1 SYNOPSIS
  11
  12 OptreeCheck supports regression testing of perl's parser, optimizer,
  13 bytecode generator, via a single function: checkOptree(%args).'
  14
  15  checkOptree(name   => "your title here", # optional, (synth from others)
  16              bcopts => '-exec', # $opt or \@opts, passed to BC::compile
  17              code   => sub {my $a},     # coderef, or source (wrapped and evald)
  18              # prog   => 'sort @a',     # run in subprocess, aka -MO=Concise
  19              # skip => 1,               # skips test
  20              # todo => 'excuse',        # anticipated failures
  21              # fail => 1                # fails (by redirecting result)
  22              # debug => 1,              # turns on regex debug for match test !!
  23              # retry => 1               # retry with debug on test failure
  24              expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
  25  # 1  <;> nextstate(main 45 optree.t:23) v
  26  # 2  <0> padsv[$a:45,46] M/LVINTRO
  27  # 3  <1> leavesub[1 ref] K/REFC,1
  28  EOT_EOT
  29  # 1  <;> nextstate(main 45 optree.t:23) v
  30  # 2  <0> padsv[$a:45,46] M/LVINTRO
  31  # 3  <1> leavesub[1 ref] K/REFC,1
  32  EONT_EONT
  33
  34 =head1 checkOptree(%in) Overview
  35
  36 Calls getRendering(), which runs code or prog through B::Concise, and
  37 captures its rendering.
  38
  39 Calls mkCheckRex() to produce a regex which will match the expected
  40 rendering, and fail when it doesn't match.
  41
  42 Also calls like($rendering,/$regex/,$name), and thereby plugs into the
  43 test.pl framework.
  44
  45 =head1 checkOptree(%Args) API
  46
  47 Accepts %Args, with following requirements and actions:
  48
  49 expect and expect_nt are both: required, not empty, not whitespace.
  50 It's a fatal error otherwise, because false positives are BAD.
  51
  52 Either code or prog must be present.  prog is some source code, and is
  53 passed through via runperl, to B::Concise like this: (bcopts are fixed
  54 up for cmdline)
  55
  56     './perl -w -MO=Concise,$bcopts_massaged -e $src'
  57
  58 code is a subref, or $src, like above.  If it's not a subref, it's
  59 treated like source, but is wrapped as a subroutine, and passed to
  60 B::Concise::compile().
  61
  62     $subref = eval "sub{$src}";
  63
  64 I suppose I should also explain these more, but they seem obvious.
  65
  66     # prog   => 'sort @a',      # run in subprocess, aka -MO=Concise
  67     # noanchors => 1,           # no /^$/.  needed for 1-liners like above
  68
  69     # skip => 1,                # skips test
  70     # todo => 'excuse',         # anticipated failures
  71     # fail => 1                 # fails (by redirecting result)
  72     # debug => 1,               # turns on regex debug for match test !!
  73     # retry => 1                # retry with debug on test failure
  74
  75 =head1 Test Philosophy
  76
  77 2 platforms --> 2 reftexts: You want an accurate test, independent of
  78 which platform you're on.  So, two refdata properties, 'expect' and
  79 'expect_nt', carry renderings taken from threaded and non-threaded
  80 builds.  This has several benefits:
  81
  82  1. native reference data allows closer matching by regex.
  83  2. samples can be eyeballed to grok t-nt differences.
  84  3. data can help to validate mkCheckRex() operation.
  85  4. can develop regexes which accomodate t-nt differences.
  86  5. can test with both native and cross+converted regexes.
  87
  88 Cross-testing (expect_nt on threaded, expect on non-threaded) exposes
  89 differences in B::Concise output, so mkCheckRex has code to do some
  90 cross-test manipulations.  This area needs more work.
  91
  92 =head1 Test Modes
  93
  94 One consequence of a single-function API is difficulty controlling
  95 test-mode.  Ive chosen for now to use a package hash, %gOpts, to store
  96 test-state.  These properties alter checkOptree() function, either
  97 short-circuiting to selftest, or running a loop that runs the testcase
  98 2^N times, varying conditions each time.  (current N is 2 only).
  99
 100 So Test-mode is controlled with cmdline args, also called options below.
 101 Run with 'help' to see the test-state, and how to change it.
 102
 103 =head2  selftest
 104
 105 This argument invokes runSelftest(), which tests a regex against the
 106 reference renderings that they're made from.  Failure of a regex match
 107 its 'mold' is a strong indicator that mkCheckRex is buggy.
 108
 109 That said, selftest mode currently runs a cross-test too, they're not
 110 completely orthogonal yet.  See below.
 111
 112 =head2 testmode=cross
 113
 114 Cross-testing is purposely creating a T-NT mismatch, looking at the
 115 fallout, and tweaking the regex to deal with it.  Thus tests lead to
 116 'provably' complete understanding of the differences.
 117
 118 The tweaking appears contrary to the 2-refs philosophy, but the tweaks
 119 will be made in conversion-specific code, which (will) handles T->NT
 120 and NT->T separately.  The tweaking is incomplete.
 121
 122 A reasonable 1st step is to add tags to indicate when TonNT or NTonT
 123 is known to fail.  This needs an option to force failure, so the
 124 test.pl reporting mechanics show results to aid the user.
 125
 126 =head2 testmode=native
 127
 128 This is normal mode.  Other valid values are: native, cross, both.
 129
 130 =head2 checkOptree Notes
 131
 132 Accepts test code, renders its optree using B::Concise, and matches that
 133 rendering against a regex built from one of 2 reference-renderings %in data.
 134
 135 The regex is built by mkCheckRex(\%in), which scrubs %in data to
 136 remove match-irrelevancies, such as (args) and [args].  For example,
 137 it strips leading '# ', making it easy to cut-paste new tests into
 138 your test-file, run it, and cut-paste actual results into place.  You
 139 then retest and reedit until all 'errors' are gone.  (now make sure you
 140 haven't 'enshrined' a bug).
 141
 142 name: The test name.  May be augmented by a label, which is built from
 143 important params, and which helps keep names in sync with whats being
 144 tested.'
 145
 146 =cut
 147
 148 use Config;
 149 use Carp;
 150 use B::Concise qw(walk_output);
 151 use Data::Dumper;
 152 $Data::Dumper::Sortkeys = 1;
 153
 154 BEGIN {
 155     $SIG{__WARN__} = sub {
 156         my $err = shift;
 157         $err =~ m/Subroutine re::(un)?install redefined/ and return;
 158     };
 159 }
 160
 161 # but wait - more skullduggery !
 162 sub OptreeCheck::import {  &getCmdLine; }       # process @ARGV
 163
 164 # %gOpts params comprise a global test-state.  Initial values here are
 165 # HELP strings, they MUST BE REPLACED by runtime values before use, as
 166 # is done by getCmdLine(), via import
 167
 168 our %gOpts =    # values are replaced at runtime !!
 169     (
 170      # scalar values are help string
 171      rextract   => 'writes src-code todo same Optree matching',
 172      vbasic     => 'prints $str and $rex',
 173      retry      => 'retry failures after turning on re debug',
 174      retrydbg   => 'retry failures after turning on re debug',
 175      selftest   => 'self-tests mkCheckRex vs the reference rendering',
 176      selfdbg    => 'redo failing selftests with re debug',
 177      xtest      => 'extended thread/non-thread testing',
 178      fail       => 'force all test to fail, print to stdout',
 179      dump       => 'dump cmdline arg prcessing',
 180      rexpedant  => 'try tighter regex, still buggy',
 181      noanchors  => 'dont anchor match rex',
 182      help       => 0,   # 1 ends in die
 183
 184      # array values are one-of selections, with 1st value as default
 185      #   tbc: 1st value is help, 2nd is default
 186      testmode => [qw/ native cross both /],
 187     );
 188
 189
 190 # Not sure if this is too much cheating. Officially we say that
 191 # $Config::Config{usethreads} is true if some sort of threading is in use,
 192 # in which case we ought to be able to use it in place of the || below.
 193 # However, it is now possible to Configure perl with "threads" but neither
 194 # ithreads or 5005threads, which forces the re-entrant APIs, but no perl
 195 # user visible threading. This seems to have the side effect that most of perl
 196 # doesn't think that it's threaded, hence the ops aren't threaded either.
 197 # Not sure if this is actually a "supported" configuration, but given that
 198 # ponie uses it, it's going to be used by something official at least in the
 199 # interim. So it's nice for tests to all pass.
 200 our $threaded = 1
 201   if $Config::Config{useithreads} || $Config::Config{use5005threads};
 202 our $platform = ($threaded) ? "threaded" : "plain";
 203 our $thrstat = ($threaded)  ? "threaded" : "nonthreaded";
 204
 205 our ($MatchRetry,$MatchRetryDebug);     # let mylike be generic
 206 # test.pl-ish hack
 207 *MatchRetry = \$gOpts{retry};           # but alias it into %gOpts
 208 *MatchRetryDebug = \$gOpts{retrydbg};   # but alias it into %gOpts
 209
 210 our %modes = (
 211               both      => [ 'expect', 'expect_nt'],
 212               native    => [ ($threaded) ? 'expect' : 'expect_nt'],
 213               cross     => [ !($threaded) ? 'expect' : 'expect_nt'],
 214               expect    => [ 'expect' ],
 215               expect_nt => [ 'expect_nt' ],
 216               );
 217
 218 our %msgs # announce cross-testing.
 219     = (
 220        # cross-platform
 221        'expect_nt-threaded' => " (Non-threaded-ref on Threaded-build)",
 222        'expect-nonthreaded' => " (Threaded-ref on Non-threaded-build)",
 223        # native - nothing to say
 224        'expect_nt-nonthreaded'  => '',
 225        'expect-threaded'        => '',
 226        );
 227
 228 #######
 229 sub getCmdLine {        # import assistant
 230     # offer help
 231     print(qq{\n$0 accepts args to update these state-vars:
 232              turn on a flag by typing its name,
 233              select a value from list by typing name=val.\n    },
 234           Dumper \%gOpts)
 235         if grep /help/, @ARGV;
 236
 237     # replace values for each key !! MUST MARK UP %gOpts
 238     foreach my $opt (keys %gOpts) {
 239
 240         # scan ARGV for known params
 241         if (ref $gOpts{$opt} eq 'ARRAY') {
 242
 243             # $opt is a One-Of construct
 244             # replace with valid selection from the list
 245
 246             # uhh this WORKS. but it's inscrutable
 247             # grep s/$opt=(\w+)/grep {$_ eq $1} @ARGV and $gOpts{$opt}=$1/e, @ARGV;
 248             my $tval;  # temp
 249             if (grep s/$opt=(\w+)/$tval=$1/e, @ARGV) {
 250                 # check val before accepting
 251                 my @allowed = @{$gOpts{$opt}};
 252                 if (grep { $_ eq $tval } @allowed) {
 253                     $gOpts{$opt} = $tval;
 254                 }
 255                 else {die "invalid value: '$tval' for $opt\n"}
 256             }
 257
 258             # take 1st val as default
 259             $gOpts{$opt} = ${$gOpts{$opt}}[0]
 260                 if ref $gOpts{$opt} eq 'ARRAY';
 261         }
 262         else { # handle scalars
 263
 264             # if 'opt' is present, true
 265             $gOpts{$opt} = (grep /$opt/, @ARGV) ? 1 : 0;
 266
 267             # override with 'foo' if 'opt=foo' appears
 268             grep s/$opt=(.*)/$gOpts{$opt}=$1/e, @ARGV;
 269         }
 270     }
 271     print("$0 heres current state:\n", Dumper \%gOpts)
 272         if $gOpts{help} or $gOpts{dump};
 273
 274     exit if $gOpts{help};
 275 }
 276
 277 ##################################
 278 # API
 279
 280 sub checkOptree {
 281     my %in = @_;
 282     my ($in, $res) = (\%in,0);   # set up privates.
 283
 284     print "checkOptree args: ",Dumper \%in if $in{dump};
 285     SKIP: {
 286         label(\%in);
 287         skip($in{name}, 1) if $in{skip};
 288         return runSelftest(\%in) if $gOpts{selftest};
 289
 290         my $rendering = getRendering(\%in);     # get the actual output
 291         fail("FORCED: $in{name}:\n$rendering") if $gOpts{fail}; # silly ?
 292
 293         # Test rendering against ..
 294       TODO:
 295         foreach $want (@{$modes{$gOpts{testmode}}}) {
 296             local $TODO = $in{todo} if $in{todo};
 297
 298             my ($rex,$txt,$rexstr) = mkCheckRex(\%in,$want);
 299             my $cross = $msgs{"$want-$thrstat"};
 300
 301             # bad is anticipated failure on cross testing ONLY
 302             my $bad = (0 or ( $cross && $in{crossfail})
 303                          or (!$cross && $in{fail})
 304                          or 0); # no undefs! pedant
 305
 306             # couldn't bear to pass \%in to likeyn
 307             $res = mylike ( # custom test mode stuff
 308                 [ !$bad,
 309                   $in{retry} || $gOpts{retry},
 310                   $in{debug} || $gOpts{retrydbg},
 311                   $rexstr,
 312                 ],
 313                 # remaining is std API
 314                 $rendering, qr/$rex/ms, "$cross $in{name} $in{label}")
 315             || 0;
 316             printhelp(\%in, $rendering, $rex);
 317         }
 318     }
 319     $res;
 320 }
 321
 322 #################
 323 # helpers
 324
 325 sub label {
 326     # may help get/keep test output consistent
 327     my ($in) = @_;
 328     return if $in->{name};
 329
 330     my $buf = (ref $in->{bcopts})
 331         ? join(',', @{$in->{bcopts}}) : $in->{bcopts};
 332
 333     foreach (qw( note prog code )) {
 334         $buf .= " $_: $in->{$_}" if $in->{$_} and not ref $in->{$_};
 335     }
 336     return $in->{label} = $buf;
 337 }
 338
 339 sub testCombo {
 340     # generate a set of test-cases from the options
 341     my $in = @_;
 342     my @cases;
 343     foreach $want (@{$modes{$gOpts{testmode}}}) {
 344         push @cases, [ %in ]
 345     }
 346     return @cases;
 347 }
 348
 349 sub runSelftest {
 350     # tests the test-cases offered (expect, expect_nt)
 351     # needs Unification with above.
 352     my ($in) = @_;
 353     my $ok;
 354     foreach $want (@{$modes{$gOpts{testmode}}}) {}
 355
 356     for my $provenance (qw/ expect expect_nt /) {
 357         next unless $in->{$provenance};
 358         my ($rex,$gospel) = mkCheckRex($in, $provenance);
 359         return unless $gospel;
 360
 361         my $cross = $msgs{"$provenance-$thrstat"};
 362         my $bad = (0 or ( $cross && $in->{crossfail})
 363                    or   (!$cross && $in->{fail})
 364                    or 0);
 365             # couldn't bear to pass \%in to likeyn
 366             $res = mylike ( [ !$bad,
 367                               $in->{retry} || $gOpts{retry},
 368                               $in->{debug} || $gOpts{retrydbg},
 369                               #label($in)
 370                               ],
 371                             $rendering, qr/$rex/ms, "$cross $in{name}")
 372                 || 0;
 373     }
 374     $ok;
 375 }
 376
 377 # use re;
 378 sub mylike {
 379     # note dependence on unlike()
 380     my ($control) = shift;
 381     my ($yes,$retry,$debug,$postmortem) = @$control; # or dies
 382     my ($got, $expected, $name, @mess) = @_; # pass thru mostly
 383
 384     die "unintended usage, expecting Regex". Dumper \@_
 385         unless ref $_[1] eq 'Regexp';
 386
 387     #ok($got=~/$expected/, "wow");
 388
 389     # same as A ^ B, but B has side effects
 390     my $ok = ( (!$yes   and unlike($got, $expected, $name, @mess))
 391                or ($yes and   like($got, $expected, $name, @mess)));
 392
 393     if (not $ok and $postmortem) {
 394         # split rexstr into units that should eat leading lines.
 395         my @rexs = map qr/^$_/, split (/\n/,$postmortem);
 396         foreach my $rex (@rexs) {
 397             #$got =~ s/($rex)/ate: $1/msg;      # noisy
 398             $got =~ s/($rex)\n//msg;            # remove matches
 399         }
 400         print "sequentially deconstructed, these are unmatched:\n$got\n";
 401     }
 402
 403     if (not $ok and $retry) {
 404         # redo, perhaps with use re debug - NOT ROBUST
 405         eval "use re 'debug'" if $debug;
 406         $ok = (!$yes   and unlike($got, $expected, "(RETRY) $name", @mess)
 407                or $yes and   like($got, $expected, "(RETRY) $name", @mess));
 408
 409         no re 'debug';
 410     }
 411     return $ok;
 412 }
 413
 414 sub getRendering {
 415     my ($in) = @_;
 416     die "getRendering: code or prog is required\n"
 417         unless $in->{code} or $in->{prog};
 418
 419     my @opts = get_bcopts($in);
 420     my $rendering = ''; # suppress "Use of uninitialized value in open"
 421
 422     if ($in->{prog}) {
 423         $rendering = runperl( switches => ['-w',join(',',"-MO=Concise",@opts)],
 424                               prog => $in->{prog}, stderr => 1,
 425                               ); #verbose => 1);
 426     } else {
 427         my $code = $in->{code};
 428         unless (ref $code eq 'CODE') {
 429             # treat as source, and wrap
 430             $code = eval "sub { $code }";
 431             die "$@ evaling code 'sub { $in->{code} }'\n"
 432                 unless ref $code eq 'CODE';
 433         }
 434         # set walk-output b4 compiling, which writes 'announce' line
 435         walk_output(\$rendering);
 436         if ($in->{fail}) {
 437             fail("forced failure: stdout follows");
 438             walk_output(\*STDOUT);
 439         }
 440         my $opwalker = B::Concise::compile(@opts, $code);
 441         die "bad BC::compile retval" unless ref $opwalker eq 'CODE';
 442
 443       B::Concise::reset_sequence();
 444         $opwalker->();
 445     }
 446     return $rendering;
 447 }
 448
 449 sub get_bcopts {
 450     # collect concise passthru-options if any
 451     my ($in) = shift;
 452     my @opts = ();
 453     if ($in->{bcopts}) {
 454         @opts = (ref $in->{bcopts} eq 'ARRAY')
 455             ? @{$in->{bcopts}} : ($in->{bcopts});
 456     }
 457     return @opts;
 458 }
 459
 460 # needless complexity due to 'too much info' from B::Concise v.60
 461 my $announce = 'B::Concise::compile\(CODE\(0x[0-9a-f]+\)\)';;
 462
 463 sub mkCheckRex {
 464     # converts expected text into Regexp which should match against
 465     # unaltered version.  also adjusts threaded => non-threaded
 466     my ($in, $want) = @_;
 467     eval "no re 'debug'";
 468
 469     my $str = $in->{expect} || $in->{expect_nt};        # standard bias
 470     $str = $in->{$want} if $want;                       # stated pref
 471
 472     die "no reftext found for $want: $in->{name}" unless $str;
 473     #fail("rex-str is empty, won't allow false positives") unless $str;
 474
 475     $str =~ s/^\# //mg;         # ease cut-paste testcase authoring
 476     my $reftxt = $str;          # extra return val !!
 477
 478     # convert all (args) and [args] to temp forms wo bracing
 479     $str =~ s/\[(.*?)\]/__CAPSQR$1__/msg;
 480     $str =~ s/\((.*?)\)/__CAPRND$1__/msg;
 481     $str =~ s/\((.*?)\)/__CAPRND$1__/msg; # nested () in nextstate
 482
 483     # escape bracing, etc.. manual \Q (doesnt escape '+')
 484     $str =~ s/([\[\]()*.\$\@\#\|{}])/\\$1/msg;
 485
 486     # now replace temp forms with original, preserving reference bracing
 487     $str =~ s/__CAPSQR(.*?)__\b/\\[$1\\]/msg; # \b is important
 488     $str =~ s/__CAPRND(.*?)__\b/\\($1\\)/msg;
 489     $str =~ s/__CAPRND(.*?)__\b/\\($1\\)/msg; # nested () in nextstate
 490
 491     # no 'invisible' failures in debugger
 492     $str =~ s/(?:next|db)state(\\\(.*?\\\))/(?:next|db)state(.*?)/msg;
 493
 494     # don't care about:
 495     $str =~ s/:-?\d+,-?\d+/:-?\\d+,-?\\d+/msg;          # FAKE line numbers
 496     $str =~ s/match\\\(.*?\\\)/match\(.*?\)/msg;        # match args
 497     $str =~ s/(0x[0-9A-Fa-f]+)/0x[0-9A-Fa-f]+/msg;      # hexnum values
 498     $str =~ s/".*?"/".*?"/msg;                          # quoted strings
 499
 500     croak "no reftext found for $want: $in->{name}"
 501         unless $str =~ /\w+/; # fail unless a real test
 502
 503     # $str = '.*'       if 1;   # sanity test
 504     # $str .= 'FAIL'    if 1;   # sanity test
 505
 506     # allow -eval, banner at beginning of anchored matches
 507     $str = "(-e .*?)?(B::Concise::compile.*?)?\n" . $str
 508         unless $in->{noanchors};
 509
 510     eval "use re 'debug'" if $debug;
 511     my $qr = ($in->{noanchors}) ? qr/$str/ms : qr/^$str$/ms ;
 512     no re 'debug';
 513
 514     return ($qr, $reftxt, $str) if wantarray;
 515     return $qr;
 516 }
 517
 518
 519 sub printhelp {
 520     # crufty - may be still useful
 521     my ($in, $rendering, $rex) = @_;
 522     print "<$rendering>\nVS\n<$rex>\n" if $gOpts{vbasic};
 523
 524     # save this output to afile, edit out 'ok's and 1..N
 525     # then perl -d afile, and add re 'debug' to suit.
 526     print("\$str = q%$rendering%;\n".
 527           "\$rex = qr%$rex%;\n\n".
 528           #"print \"\$str =~ m%\$rex%ms \";\n".
 529           "\$str =~ m{\$rex}ms or print \"doh\\n\";\n\n")
 530         if $in{rextract} or $gOpts{rextract};
 531 }
 532
 533
 534 #########################
 535 # support for test writing
 536
 537 sub preamble {
 538     my $testct = shift || 1;
 539     return <<EO_HEADER;
 540 #!perl
 541
 542 BEGIN {
 543     chdir q(t);
 544     \@INC = qw(../lib ../ext/B/t);
 545     require q(./test.pl);
 546 }
 547 use OptreeCheck;
 548 plan tests => $testct;
 549
 550 EO_HEADER
 551
 552 }
 553
 554 sub OptreeCheck::wrap {
 555     my $code = shift;
 556     $code =~ s/(?:(\#.*?)\n)//gsm;
 557     $code =~ s/\s+/ /mgs;
 558     chomp $code;
 559     return unless $code =~ /\S/;
 560     my $comment = $1;
 561
 562     my $testcode = qq{
 563
 564 checkOptree(note   => q{$comment},
 565             bcopts => q{-exec},
 566             code   => q{$code},
 567             expect => <<EOT_EOT, expect_nt => <<EONT_EONT);
 568 ThreadedRef
 569 EOT_EOT
 570 NonThreadRef
 571 EONT_EONT
 572
 573 };
 574     return $testcode;
 575 }
 576
 577 sub OptreeCheck::gentest {
 578     my ($code,$opts) = @_;
 579     my $rendering = getRendering({code => $code});
 580     my $testcode = OptreeCheck::wrap($code);
 581     return unless $testcode;
 582
 583     # run the prog, capture 'reference' concise output
 584     my $preamble = preamble(1);
 585     my $got = runperl( prog => "$preamble $testcode", stderr => 1,
 586                        #switches => ["-I../ext/B/t", "-MOptreeCheck"],
 587                        );  #verbose => 1);
 588
 589     # extract the 'reftext' ie the got 'block'
 590     if ($got =~ m/got \'.*?\n(.*)\n\# \'\n\# expected/s) {
 591         my $reftext = $1;
 592         #and plug it into the test-src
 593         if ($threaded) {
 594             $testcode =~ s/ThreadedRef/$reftext/;
 595         } else {
 596             $testcode =~ s/NonThreadRef/$reftext/;
 597         }
 598         my $b4 = q{expect => <<EOT_EOT, expect_nt => <<EONT_EONT};
 599         my $af = q{expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'};
 600         $testcode =~ s/$b4/$af/;
 601
 602         my $got;
 603         if ($internal_retest) {
 604             $got = runperl( prog => "$preamble $testcode", stderr => 1,
 605                             #switches => ["-I../ext/B/t", "-MOptreeCheck"],
 606                             verbose => 1);
 607             print "got: $got\n";
 608         }
 609         return $testcode;
 610     }
 611     return '';
 612 }
 613
 614
 615 sub OptreeCheck::processExamples {
 616     my @files = @_;
 617     # gets array of paragraphs, which should be tests.
 618
 619     foreach my $file (@files) {
 620         open (my $fh, $file) or die "cant open $file: $!\n";
 621         $/ = "";
 622         my @chunks = <$fh>;
 623         print preamble (scalar @chunks);
 624         foreach $t (@chunks) {
 625             print "\n\n=for gentest\n\n# chunk: $t=cut\n\n";
 626             print OptreeCheck::gentest ($t);
 627         }
 628     }
 629 }
 630
 631 # OK - now for the final insult to your good taste...
 632
 633 if ($0 =~ /OptreeCheck\.pm/) {
 634
 635     #use lib 't';
 636     require './t/test.pl';
 637
 638     # invoked as program.  Work like former gentest.pl,
 639     # ie read files given as cmdline args,
 640     # convert them to usable test files.
 641
 642     require Getopt::Std;
 643     Getopt::Std::getopts('') or
 644         die qq{ $0 sample-files*    # no options
 645
 646           expecting filenames as args.  Each should have paragraphs,
 647           these are converted to checkOptree() tests, and printed to
 648           stdout.  Redirect to file then edit for test. \n};
 649
 650   OptreeCheck::processExamples(@ARGV);
 651 }
 652
 653 1;
 654
 655 __END__
 656
 657 =head1 mkCheckRex
 658
 659 mkCheckRex receives the full testcase object, and constructs a regex.
 660 1st, it selects a reftxt from either the expect or expect_nt items.
 661
 662 Once selected, reftext is massaged & converted into a Regex that
 663 accepts 'good' concise renderings, with appropriate input variations,
 664 but is otherwise as strict as possible.  For example, it should *not*
 665 match when opcode flags change, or when optimizations convert an op to
 666 an ex-op.
 667
 668 =head2 match criteria
 669
 670 Opcode arguments (text within braces) are disregarded for matching
 671 purposes.  This loses some info in 'add[t5]', but greatly simplifys
 672 matching 'nextstate(main 22 (eval 10):1)'.  Besides, we are testing
 673 for regressions, not for complete accuracy.
 674
 675 The regex is anchored by default, but can be suppressed with
 676 'noanchors', allowing 1-liner tests to succeed if opcode is found.
 677
 678 =head1 TEST DEVELOPMENT SUPPORT
 679
 680 This optree regression testing framework needs tests in order to find
 681 bugs.  To that end, OptreeCheck has support for developing new tests,
 682 according to the following model:
 683
 684  1. write a set of sample code into a single file, one per
 685     paragraph.  f_map and f_sort in ext/B/t/ are examples.
 686
 687  2. run OptreeCheck as a program on the file
 688
 689    ./perl -Ilib ext/B/t/OptreeCheck.pm -w ext/B/t/f_map
 690    ./perl -Ilib ext/B/t/OptreeCheck.pm -w ext/B/t/f_sort
 691
 692    gentest reads the sample code, runs each to generate a reference
 693    rendering, folds this rendering into an optreeCheck() statement,
 694    and prints it to stdout.
 695
 696  3. run the output file as above, redirect to files, then rerun on
 697     same build (for sanity check), and on thread-opposite build.  With
 698     editor in 1 window, and cmd in other, it's fairly easy to cut-paste
 699     the gots into the expects, easier than running step 2 on both
 700     builds then trying to sdiff them together.
 701
 702 =head1 TODO
 703
 704 There's a considerable amount of cruft in the whole arg-handling setup.
 705 I'll replace / strip it before 5.10
 706
 707 Treat %in as a test object, interwork better with Test::*
 708
 709 Refactor mkCheckRex() and selfTest() to isolate the selftest,
 710 crosstest, etc selection mechanics.
 711
 712 improve retry, retrydbg, esp. it's control of eval "use re debug".
 713 This seems to work part of the time, but isn't stable enough.
 714
 715 =cut