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