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 our $threaded = 1 if $Config::Config{usethreads};
 191 our $platform = ($threaded) ? "threaded" : "plain";
 192 our $thrstat = ($threaded)  ? "threaded" : "nonthreaded";
 193
 194 our ($MatchRetry,$MatchRetryDebug);     # let mylike be generic
 195 # test.pl-ish hack
 196 *MatchRetry = \$gOpts{retry};           # but alias it into %gOpts
 197 *MatchRetryDebug = \$gOpts{retrydbg};   # but alias it into %gOpts
 198
 199 our %modes = (
 200               both      => [ 'expect', 'expect_nt'],
 201               native    => [ ($threaded) ? 'expect' : 'expect_nt'],
 202               cross     => [ !($threaded) ? 'expect' : 'expect_nt'],
 203               expect    => [ 'expect' ],
 204               expect_nt => [ 'expect_nt' ],
 205               );
 206
 207 our %msgs # announce cross-testing.
 208     = (
 209        # cross-platform
 210        'expect_nt-threaded' => " (Non-threaded-ref on Threaded-build)",
 211        'expect-nonthreaded' => " (Threaded-ref on Non-threaded-build)",
 212        # native - nothing to say
 213        'expect_nt-nonthreaded'  => '',
 214        'expect-threaded'        => '',
 215        );
 216
 217 #######
 218 sub getCmdLine {        # import assistant
 219     # offer help
 220     print(qq{\n$0 accepts args to update these state-vars:
 221              turn on a flag by typing its name,
 222              select a value from list by typing name=val.\n    },
 223           Dumper \%gOpts)
 224         if grep /help/, @ARGV;
 225
 226     # replace values for each key !! MUST MARK UP %gOpts
 227     foreach my $opt (keys %gOpts) {
 228
 229         # scan ARGV for known params
 230         if (ref $gOpts{$opt} eq 'ARRAY') {
 231
 232             # $opt is a One-Of construct
 233             # replace with valid selection from the list
 234
 235             # uhh this WORKS. but it's inscrutable
 236             # grep s/$opt=(\w+)/grep {$_ eq $1} @ARGV and $gOpts{$opt}=$1/e, @ARGV;
 237             my $tval;  # temp
 238             if (grep s/$opt=(\w+)/$tval=$1/e, @ARGV) {
 239                 # check val before accepting
 240                 my @allowed = @{$gOpts{$opt}};
 241                 if (grep { $_ eq $tval } @allowed) {
 242                     $gOpts{$opt} = $tval;
 243                 }
 244                 else {die "invalid value: '$tval' for $opt\n"}
 245             }
 246
 247             # take 1st val as default
 248             $gOpts{$opt} = ${$gOpts{$opt}}[0]
 249                 if ref $gOpts{$opt} eq 'ARRAY';
 250         }
 251         else { # handle scalars
 252
 253             # if 'opt' is present, true
 254             $gOpts{$opt} = (grep /$opt/, @ARGV) ? 1 : 0;
 255
 256             # override with 'foo' if 'opt=foo' appears
 257             grep s/$opt=(.*)/$gOpts{$opt}=$1/e, @ARGV;
 258         }
 259     }
 260     print("$0 heres current state:\n", Dumper \%gOpts)
 261         if $gOpts{help} or $gOpts{dump};
 262
 263     exit if $gOpts{help};
 264 }
 265
 266 ##################################
 267 # API
 268
 269 sub checkOptree {
 270     my %in = @_;
 271     my ($in, $res) = (\%in,0);   # set up privates.
 272
 273     print "checkOptree args: ",Dumper \%in if $in{dump};
 274     SKIP: {
 275         label(\%in);
 276         skip($in{name}, 1) if $in{skip};
 277         return runSelftest(\%in) if $gOpts{selftest};
 278
 279         my $rendering = getRendering(\%in);     # get the actual output
 280         fail("FORCED: $in{name}:\n$rendering") if $gOpts{fail}; # silly ?
 281
 282         # Test rendering against ..
 283       TODO:
 284         foreach $want (@{$modes{$gOpts{testmode}}}) {
 285             local $TODO = $in{todo} if $in{todo};
 286
 287             my ($rex,$txt,$rexstr) = mkCheckRex(\%in,$want);
 288             my $cross = $msgs{"$want-$thrstat"};
 289
 290             # bad is anticipated failure on cross testing ONLY
 291             my $bad = (0 or ( $cross && $in{crossfail})
 292                          or (!$cross && $in{fail})
 293                          or 0); # no undefs! pedant
 294
 295             # couldn't bear to pass \%in to likeyn
 296             $res = mylike ( # custom test mode stuff
 297                 [ !$bad,
 298                   $in{retry} || $gOpts{retry},
 299                   $in{debug} || $gOpts{retrydbg},
 300                   $rexstr,
 301                 ],
 302                 # remaining is std API
 303                 $rendering, qr/$rex/ms, "$cross $in{name} $in{label}")
 304             || 0;
 305             printhelp(\%in, $rendering, $rex);
 306         }
 307     }
 308     $res;
 309 }
 310
 311 #################
 312 # helpers
 313
 314 sub label {
 315     # may help get/keep test output consistent
 316     my ($in) = @_;
 317     return if $in->{name};
 318
 319     my $buf = (ref $in->{bcopts})
 320         ? join(',', @{$in->{bcopts}}) : $in->{bcopts};
 321
 322     foreach (qw( note prog code )) {
 323         $buf .= " $_: $in->{$_}" if $in->{$_} and not ref $in->{$_};
 324     }
 325     return $in->{label} = $buf;
 326 }
 327
 328 sub testCombo {
 329     # generate a set of test-cases from the options
 330     my $in = @_;
 331     my @cases;
 332     foreach $want (@{$modes{$gOpts{testmode}}}) {
 333         push @cases, [ %in ]
 334     }
 335     return @cases;
 336 }
 337
 338 sub runSelftest {
 339     # tests the test-cases offered (expect, expect_nt)
 340     # needs Unification with above.
 341     my ($in) = @_;
 342     my $ok;
 343     foreach $want (@{$modes{$gOpts{testmode}}}) {}
 344
 345     for my $provenance (qw/ expect expect_nt /) {
 346         next unless $in->{$provenance};
 347         my ($rex,$gospel) = mkCheckRex($in, $provenance);
 348         return unless $gospel;
 349
 350         my $cross = $msgs{"$provenance-$thrstat"};
 351         my $bad = (0 or ( $cross && $in->{crossfail})
 352                    or   (!$cross && $in->{fail})
 353                    or 0);
 354             # couldn't bear to pass \%in to likeyn
 355             $res = mylike ( [ !$bad,
 356                               $in->{retry} || $gOpts{retry},
 357                               $in->{debug} || $gOpts{retrydbg},
 358                               #label($in)
 359                               ],
 360                             $rendering, qr/$rex/ms, "$cross $in{name}")
 361                 || 0;
 362     }
 363     $ok;
 364 }
 365
 366 # use re;
 367 sub mylike {
 368     # note dependence on unlike()
 369     my ($control) = shift;
 370     my ($yes,$retry,$debug,$postmortem) = @$control; # or dies
 371     my ($got, $expected, $name, @mess) = @_; # pass thru mostly
 372
 373     die "unintended usage, expecting Regex". Dumper \@_
 374         unless ref $_[1] eq 'Regexp';
 375
 376     #ok($got=~/$expected/, "wow");
 377
 378     # same as A ^ B, but B has side effects
 379     my $ok = ( (!$yes   and unlike($got, $expected, $name, @mess))
 380                or ($yes and   like($got, $expected, $name, @mess)));
 381
 382     if (not $ok and $postmortem) {
 383         # split rexstr into units that should eat leading lines.
 384         my @rexs = map qr/^$_/, split (/\n/,$postmortem);
 385         foreach my $rex (@rexs) {
 386             #$got =~ s/($rex)/ate: $1/msg;      # noisy
 387             $got =~ s/($rex)\n//msg;            # remove matches
 388         }
 389         print "sequentially deconstructed, these are unmatched:\n$got\n";
 390     }
 391
 392     if (not $ok and $retry) {
 393         # redo, perhaps with use re debug - NOT ROBUST
 394         eval "use re 'debug'" if $debug;
 395         $ok = (!$yes   and unlike($got, $expected, "(RETRY) $name", @mess)
 396                or $yes and   like($got, $expected, "(RETRY) $name", @mess));
 397
 398         no re 'debug';
 399     }
 400     return $ok;
 401 }
 402
 403 sub getRendering {
 404     my ($in) = @_;
 405     die "getRendering: code or prog is required\n"
 406         unless $in->{code} or $in->{prog};
 407
 408     my @opts = get_bcopts($in);
 409     my $rendering = ''; # suppress "Use of uninitialized value in open"
 410
 411     if ($in->{prog}) {
 412         $rendering = runperl( switches => ['-w',join(',',"-MO=Concise",@opts)],
 413                               prog => $in->{prog}, stderr => 1,
 414                               ); #verbose => 1);
 415     } else {
 416         my $code = $in->{code};
 417         unless (ref $code eq 'CODE') {
 418             # treat as source, and wrap
 419             $code = eval "sub { $code }";
 420             die "$@ evaling code 'sub { $in->{code} }'\n"
 421                 unless ref $code eq 'CODE';
 422         }
 423         # set walk-output b4 compiling, which writes 'announce' line
 424         walk_output(\$rendering);
 425         if ($in->{fail}) {
 426             fail("forced failure: stdout follows");
 427             walk_output(\*STDOUT);
 428         }
 429         my $opwalker = B::Concise::compile(@opts, $code);
 430         die "bad BC::compile retval" unless ref $opwalker eq 'CODE';
 431
 432       B::Concise::reset_sequence();
 433         $opwalker->();
 434     }
 435     return $rendering;
 436 }
 437
 438 sub get_bcopts {
 439     # collect concise passthru-options if any
 440     my ($in) = shift;
 441     my @opts = ();
 442     if ($in->{bcopts}) {
 443         @opts = (ref $in->{bcopts} eq 'ARRAY')
 444             ? @{$in->{bcopts}} : ($in->{bcopts});
 445     }
 446     return @opts;
 447 }
 448
 449 # needless complexity due to 'too much info' from B::Concise v.60
 450 my $announce = 'B::Concise::compile\(CODE\(0x[0-9a-f]+\)\)';;
 451
 452 sub mkCheckRex {
 453     # converts expected text into Regexp which should match against
 454     # unaltered version.  also adjusts threaded => non-threaded
 455     my ($in, $want) = @_;
 456     eval "no re 'debug'";
 457
 458     my $str = $in->{expect} || $in->{expect_nt};        # standard bias
 459     $str = $in->{$want} if $want;                       # stated pref
 460
 461     die "no reftext found for $want: $in->{name}" unless $str;
 462     #fail("rex-str is empty, won't allow false positives") unless $str;
 463
 464     $str =~ s/^\# //mg;         # ease cut-paste testcase authoring
 465     my $reftxt = $str;          # extra return val !!
 466
 467     # convert all (args) and [args] to temp forms wo bracing
 468     $str =~ s/\[(.*?)\]/__CAPSQR$1__/msg;
 469     $str =~ s/\((.*?)\)/__CAPRND$1__/msg;
 470     $str =~ s/\((.*?)\)/__CAPRND$1__/msg; # nested () in nextstate
 471
 472     # escape bracing, etc.. manual \Q (doesnt escape '+')
 473     $str =~ s/([\[\]()*.\$\@\#\|{}])/\\$1/msg;
 474
 475     # now replace temp forms with original, preserving reference bracing
 476     $str =~ s/__CAPSQR(.*?)__\b/\\[$1\\]/msg; # \b is important
 477     $str =~ s/__CAPRND(.*?)__\b/\\($1\\)/msg;
 478     $str =~ s/__CAPRND(.*?)__\b/\\($1\\)/msg; # nested () in nextstate
 479
 480     # no 'invisible' failures in debugger
 481     $str =~ s/(?:next|db)state(\\\(.*?\\\))/(?:next|db)state(.*?)/msg;
 482
 483     # don't care about:
 484     $str =~ s/:-?\d+,-?\d+/:-?\\d+,-?\\d+/msg;          # FAKE line numbers
 485     $str =~ s/match\\\(.*?\\\)/match\(.*?\)/msg;        # match args
 486     $str =~ s/(0x[0-9A-Fa-f]+)/0x[0-9A-Fa-f]+/msg;      # hexnum values
 487     $str =~ s/".*?"/".*?"/msg;                          # quoted strings
 488
 489     croak "no reftext found for $want: $in->{name}"
 490         unless $str =~ /\w+/; # fail unless a real test
 491
 492     # $str = '.*'       if 1;   # sanity test
 493     # $str .= 'FAIL'    if 1;   # sanity test
 494
 495     # allow -eval, banner at beginning of anchored matches
 496     $str = "(-e .*?)?(B::Concise::compile.*?)?\n" . $str
 497         unless $in->{noanchors};
 498
 499     eval "use re 'debug'" if $debug;
 500     my $qr = ($in->{noanchors}) ? qr/$str/ms : qr/^$str$/ms ;
 501     no re 'debug';
 502
 503     return ($qr, $reftxt, $str) if wantarray;
 504     return $qr;
 505 }
 506
 507
 508 sub printhelp {
 509     # crufty - may be still useful
 510     my ($in, $rendering, $rex) = @_;
 511     print "<$rendering>\nVS\n<$rex>\n" if $gOpts{vbasic};
 512
 513     # save this output to afile, edit out 'ok's and 1..N
 514     # then perl -d afile, and add re 'debug' to suit.
 515     print("\$str = q%$rendering%;\n".
 516           "\$rex = qr%$rex%;\n\n".
 517           #"print \"\$str =~ m%\$rex%ms \";\n".
 518           "\$str =~ m{\$rex}ms or print \"doh\\n\";\n\n")
 519         if $in{rextract} or $gOpts{rextract};
 520 }
 521
 522
 523 #########################
 524 # support for test writing
 525
 526 sub preamble {
 527     my $testct = shift || 1;
 528     return <<EO_HEADER;
 529 #!perl
 530
 531 BEGIN {
 532     chdir q(t);
 533     \@INC = qw(../lib ../ext/B/t);
 534     require q(./test.pl);
 535 }
 536 use OptreeCheck;
 537 plan tests => $testct;
 538
 539 EO_HEADER
 540
 541 }
 542
 543 sub OptreeCheck::wrap {
 544     my $code = shift;
 545     $code =~ s/(?:(\#.*?)\n)//gsm;
 546     $code =~ s/\s+/ /mgs;
 547     chomp $code;
 548     return unless $code =~ /\S/;
 549     my $comment = $1;
 550
 551     my $testcode = qq{
 552
 553 checkOptree(note   => q{$comment},
 554             bcopts => q{-exec},
 555             code   => q{$code},
 556             expect => <<EOT_EOT, expect_nt => <<EONT_EONT);
 557 ThreadedRef
 558 EOT_EOT
 559 NonThreadRef
 560 EONT_EONT
 561
 562 };
 563     return $testcode;
 564 }
 565
 566 sub OptreeCheck::gentest {
 567     my ($code,$opts) = @_;
 568     my $rendering = getRendering({code => $code});
 569     my $testcode = OptreeCheck::wrap($code);
 570     return unless $testcode;
 571
 572     # run the prog, capture 'reference' concise output
 573     my $preamble = preamble(1);
 574     my $got = runperl( prog => "$preamble $testcode", stderr => 1,
 575                        #switches => ["-I../ext/B/t", "-MOptreeCheck"],
 576                        );  #verbose => 1);
 577
 578     # extract the 'reftext' ie the got 'block'
 579     if ($got =~ m/got \'.*?\n(.*)\n\# \'\n\# expected/s) {
 580         my $reftext = $1;
 581         #and plug it into the test-src
 582         if ($threaded) {
 583             $testcode =~ s/ThreadedRef/$reftext/;
 584         } else {
 585             $testcode =~ s/NonThreadRef/$reftext/;
 586         }
 587         my $b4 = q{expect => <<EOT_EOT, expect_nt => <<EONT_EONT};
 588         my $af = q{expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'};
 589         $testcode =~ s/$b4/$af/;
 590
 591         my $got;
 592         if ($internal_retest) {
 593             $got = runperl( prog => "$preamble $testcode", stderr => 1,
 594                             #switches => ["-I../ext/B/t", "-MOptreeCheck"],
 595                             verbose => 1);
 596             print "got: $got\n";
 597         }
 598         return $testcode;
 599     }
 600     return '';
 601 }
 602
 603
 604 sub OptreeCheck::processExamples {
 605     my @files = @_;
 606     # gets array of paragraphs, which should be tests.
 607
 608     foreach my $file (@files) {
 609         open (my $fh, $file) or die "cant open $file: $!\n";
 610         $/ = "";
 611         my @chunks = <$fh>;
 612         print preamble (scalar @chunks);
 613         foreach $t (@chunks) {
 614             print "\n\n=for gentest\n\n# chunk: $t=cut\n\n";
 615             print OptreeCheck::gentest ($t);
 616         }
 617     }
 618 }
 619
 620 # OK - now for the final insult to your good taste...
 621
 622 if ($0 =~ /OptreeCheck\.pm/) {
 623
 624     #use lib 't';
 625     require './t/test.pl';
 626
 627     # invoked as program.  Work like former gentest.pl,
 628     # ie read files given as cmdline args,
 629     # convert them to usable test files.
 630
 631     require Getopt::Std;
 632     Getopt::Std::getopts('') or
 633         die qq{ $0 sample-files*    # no options
 634
 635           expecting filenames as args.  Each should have paragraphs,
 636           these are converted to checkOptree() tests, and printed to
 637           stdout.  Redirect to file then edit for test. \n};
 638
 639   OptreeCheck::processExamples(@ARGV);
 640 }
 641
 642 1;
 643
 644 __END__
 645
 646 =head1 mkCheckRex
 647
 648 mkCheckRex receives the full testcase object, and constructs a regex.
 649 1st, it selects a reftxt from either the expect or expect_nt items.
 650
 651 Once selected, reftext is massaged & converted into a Regex that
 652 accepts 'good' concise renderings, with appropriate input variations,
 653 but is otherwise as strict as possible.  For example, it should *not*
 654 match when opcode flags change, or when optimizations convert an op to
 655 an ex-op.
 656
 657 =head2 match criteria
 658
 659 Opcode arguments (text within braces) are disregarded for matching
 660 purposes.  This loses some info in 'add[t5]', but greatly simplifys
 661 matching 'nextstate(main 22 (eval 10):1)'.  Besides, we are testing
 662 for regressions, not for complete accuracy.
 663
 664 The regex is anchored by default, but can be suppressed with
 665 'noanchors', allowing 1-liner tests to succeed if opcode is found.
 666
 667 =head1 TEST DEVELOPMENT SUPPORT
 668
 669 This optree regression testing framework needs tests in order to find
 670 bugs.  To that end, OptreeCheck has support for developing new tests,
 671 according to the following model:
 672
 673  1. write a set of sample code into a single file, one per
 674     paragraph.  f_map and f_sort in ext/B/t/ are examples.
 675
 676  2. run OptreeCheck as a program on the file
 677
 678    ./perl -Ilib ext/B/t/OptreeCheck.pm -w ext/B/t/f_map
 679    ./perl -Ilib ext/B/t/OptreeCheck.pm -w ext/B/t/f_sort
 680
 681    gentest reads the sample code, runs each to generate a reference
 682    rendering, folds this rendering into an optreeCheck() statement,
 683    and prints it to stdout.
 684
 685  3. run the output file as above, redirect to files, then rerun on
 686     same build (for sanity check), and on thread-opposite build.  With
 687     editor in 1 window, and cmd in other, it's fairly easy to cut-paste
 688     the gots into the expects, easier than running step 2 on both
 689     builds then trying to sdiff them together.
 690
 691 =head1 TODO
 692
 693 There's a considerable amount of cruft in the whole arg-handling setup.
 694 I'll replace / strip it before 5.10
 695
 696 Treat %in as a test object, interwork better with Test::*
 697
 698 Refactor mkCheckRex() and selfTest() to isolate the selftest,
 699 crosstest, etc selection mechanics.
 700
 701 improve retry, retrydbg, esp. it's control of eval "use re debug".
 702 This seems to work part of the time, but isn't stable enough.
 703
 704 =cut