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