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