This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
ext/B/t/OptreeCheck.pm: Escape literal pattern '{'
[perl5.git] / ext / B / t / OptreeCheck.pm
CommitLineData
19e169bf 1package OptreeCheck;
0850687d 2use parent 'Exporter';
3feb66e7
NC
3use strict;
4use warnings;
be2b1c74 5use vars qw($TODO $Level $using_open);
19e169bf
JC
6require "test.pl";
7
a27615d6 8our $VERSION = '0.14';
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
f85f6494 12 require_ok runperl tempfile);
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 53
3f472914
NC
54 errs => 'Name "main::a" used only once: possible typo at -e line 1.',
55 # str, regex, [str+] [regex+],
19e169bf
JC
56
57 # various test options
5e251bf1
JC
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)
19e169bf
JC
62
63 # the 'golden-sample's, (must provide both)
5e251bf1 64
19e169bf 65 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT' ); # start HERE-DOCS
724aa791
JC
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
19e169bf
JC
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'
ed215d3c 104 # want: (?^:2 <\$> gvsv\(\*b\) s)
19e169bf 105 # got: '3 <$> const[IV 42] s'
ed215d3c 106 # want: (?^:3 <\$> const\(IV 42\) s)
19e169bf 107 # got: '5 <#> gvsv[*a] s'
ed215d3c 108 # want: (?^:5 <\$> gvsv\(\*a\) s)
19e169bf
JC
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
f85f6494
SH
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.
19e169bf
JC
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
1ebd3007 183=head2 code or prog or progfile
19e169bf 184
f85f6494 185Either code or prog or progfile must be present.
19e169bf
JC
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:
724aa791 191
19e169bf 192 './perl -w -MO=Concise,$bcopts_massaged -e $src'
724aa791 193
f85f6494
SH
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
19e169bf 199=head2 code => $perl_source_string || CODEREF
5e251bf1 200
19e169bf
JC
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():
724aa791 204
19e169bf
JC
205 $subref = eval "sub{$code}";
206 $render = B::Concise::compile($subref)->();
724aa791 207
19e169bf 208=head2 expect and expect_nt
724aa791 209
19e169bf
JC
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>.
724aa791 214
82aeefe1 215Individual sample lines may be suffixed with whitespace followed
82b84d04
FC
216by (<|<=|==|>=|>)5.nnnn (up to two times) to
217select that line only for the listed perl
82aeefe1
DM
218version; the whitespace and conditional are stripped.
219
19e169bf 220=head2 bcopts => $bcopts || [ @bcopts ]
724aa791 221
19e169bf 222When getRendering() runs, it passes bcopts into B::Concise::compile().
3c4b39be 223The bcopts arg can be a single string, or an array of strings.
724aa791 224
19e169bf 225=head2 errs => $err_str_regex || [ @err_str_regexs ]
724aa791 226
f85f6494
SH
227getRendering() processes the code or prog or progfile arg under warnings,
228and both parsing and optree-traversal errors are collected. These are
19e169bf 229validated against the one or more errors you specify.
5e251bf1 230
19e169bf 231=head1 testcase modifier properties
724aa791 232
19e169bf 233These properties are set as %tc parameters to change test behavior.
724aa791 234
19e169bf 235=head2 skip => 'reason'
cc02ea56 236
19e169bf 237invokes skip('reason'), causing test to skip.
724aa791 238
19e169bf 239=head2 todo => 'reason'
724aa791 240
19e169bf 241invokes todo('reason')
724aa791 242
19e169bf 243=head2 fail => 1
724aa791 244
19e169bf
JC
245For code arguments, this option causes getRendering to redirect the
246rendering operation to STDERR, which causes the regex match to fail.
724aa791 247
19e169bf 248=head2 noanchors => 1
724aa791 249
19e169bf
JC
250If set, this relaxes the regex check, which is normally pretty strict.
251It's used primarily to validate checkOptree via tests in optree_check.
724aa791 252
724aa791 253
19e169bf 254=head1 Synthesized object properties
724aa791 255
19e169bf 256These properties are added into the test object during execution.
724aa791 257
19e169bf 258=head2 wanted
724aa791 259
19e169bf
JC
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.
724aa791 263
19e169bf 264=head2 cross => 1
724aa791 265
19e169bf
JC
266This tag is added if testmode=cross is passed in as argument.
267It causes test-harness to purposely use the wrong string.
724aa791 268
724aa791 269
19e169bf
JC
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
724aa791
JC
276=cut
277
278use Config;
279use Carp;
280use B::Concise qw(walk_output);
724aa791
JC
281
282BEGIN {
283 $SIG{__WARN__} = sub {
284 my $err = shift;
285 $err =~ m/Subroutine re::(un)?install redefined/ and return;
286 };
287}
288
19e169bf
JC
289sub import {
290 my $pkg = shift;
291 $pkg->export_to_level(1,'checkOptree', @EXPORT);
292 getCmdLine(); # process @ARGV
293}
294
724aa791
JC
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
724aa791 303 selftest => 'self-tests mkCheckRex vs the reference rendering',
19e169bf 304
724aa791 305 fail => 'force all test to fail, print to stdout',
b7b1e41b 306 dump => 'dump cmdline arg processing',
cc02ea56 307 noanchors => 'dont anchor match rex',
724aa791
JC
308
309 # array values are one-of selections, with 1st value as default
19e169bf
JC
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 /],
5e251bf1 313
98ccfbbf 314 # fixup for VMS, cygwin, which don't have stderr b4 stdout
5e251bf1
JC
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',
19e169bf 318 errs => 'expected compile errs, array if several',
724aa791
JC
319 );
320
321
54cf8e17 322# Not sure if this is too much cheating. Officially we say that
19e169bf
JC
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
54cf8e17
NC
335our $threaded = 1
336 if $Config::Config{useithreads} || $Config::Config{use5005threads};
724aa791
JC
337our $platform = ($threaded) ? "threaded" : "plain";
338our $thrstat = ($threaded) ? "threaded" : "nonthreaded";
339
724aa791
JC
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' ],
cc02ea56 346 );
724aa791
JC
347
348our %msgs # announce cross-testing.
349 = (
350 # cross-platform
19e169bf
JC
351 'expect_nt-threaded' => " (nT on T) ",
352 'expect-nonthreaded' => " (T on nT) ",
353 # native - nothing to say (must stay empty - used for $crosstesting)
724aa791
JC
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 },
19e169bf 364 mydumper(\%gOpts))
724aa791
JC
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
19e169bf 395 $gOpts{$opt} = (grep /^$opt/, @ARGV) ? 1 : 0;
724aa791
JC
396
397 # override with 'foo' if 'opt=foo' appears
398 grep s/$opt=(.*)/$gOpts{$opt}=$1/e, @ARGV;
399 }
5e251bf1 400 }
19e169bf 401 print("$0 heres current state:\n", mydumper(\%gOpts))
724aa791
JC
402 if $gOpts{help} or $gOpts{dump};
403
404 exit if $gOpts{help};
405}
5e251bf1 406# the above arg-handling cruft should be replaced by a Getopt call
724aa791 407
19e169bf
JC
408##############################
409# the API (1 function)
724aa791
JC
410
411sub checkOptree {
19e169bf
JC
412 my $tc = newTestCases(@_); # ctor
413 my ($rendering);
724aa791 414
19e169bf 415 print "checkOptree args: ",mydumper($tc) if $tc->{dump};
724aa791 416 SKIP: {
82aeefe1
DM
417 if ($tc->{skip}) {
418 skip("$tc->{skip} $tc->{name}",
419 ($gOpts{selftest}
420 ? 1
421 : 1 + @{$modes{$gOpts{testmode}}}
422 )
423 );
424 }
5e251bf1 425
19e169bf 426 return runSelftest($tc) if $gOpts{selftest};
724aa791 427
19e169bf
JC
428 $tc->getRendering(); # get the actual output
429 $tc->checkErrs();
5e251bf1 430
be2b1c74 431 local $Level = $Level + 2;
cc02ea56 432 TODO:
3feb66e7 433 foreach my $want (@{$modes{$gOpts{testmode}}}) {
19e169bf
JC
434 local $TODO = $tc->{todo} if $tc->{todo};
435
436 $tc->{cross} = $msgs{"$want-$thrstat"};
437
438 $tc->mkCheckRex($want);
439 $tc->mylike();
724aa791
JC
440 }
441 }
3feb66e7 442 return;
724aa791
JC
443}
444
19e169bf
JC
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";
cc02ea56 449
19e169bf 450 $tc->label();
724aa791 451
19e169bf 452 # cpy globals into each test
3feb66e7 453 foreach my $k (keys %gOpts) {
19e169bf
JC
454 if ($gOpts{$k}) {
455 $tc->{$k} = $gOpts{$k} unless defined $tc->{$k};
456 }
724aa791 457 }
19e169bf 458 if ($tc->{errs}) {
3f472914 459 $tc->{errs} = [$tc->{errs}] unless ref $tc->{errs} eq 'ARRAY';
724aa791 460 }
19e169bf 461 return $tc;
724aa791
JC
462}
463
19e169bf
JC
464sub label {
465 # may help get/keep test output consistent
466 my ($tc) = @_;
467 return $tc->{name} if $tc->{name};
cc02ea56 468
19e169bf
JC
469 my $buf = (ref $tc->{bcopts})
470 ? join(',', @{$tc->{bcopts}}) : $tc->{bcopts};
cc02ea56 471
19e169bf
JC
472 foreach (qw( note prog code )) {
473 $buf .= " $_: $tc->{$_}" if $tc->{$_} and not ref $tc->{$_};
724aa791 474 }
19e169bf 475 return $tc->{name} = $buf;
724aa791
JC
476}
477
19e169bf
JC
478#################
479# render and its helpers
480
724aa791 481sub getRendering {
19e169bf 482 my $tc = shift;
f85f6494
SH
483 fail("getRendering: code or prog or progfile is required")
484 unless $tc->{code} or $tc->{prog} or $tc->{progfile};
724aa791 485
19e169bf 486 my @opts = get_bcopts($tc);
724aa791 487 my $rendering = ''; # suppress "Use of uninitialized value in open"
5e251bf1
JC
488 my @errs; # collect errs via
489
724aa791 490
19e169bf 491 if ($tc->{prog}) {
724aa791 492 $rendering = runperl( switches => ['-w',join(',',"-MO=Concise",@opts)],
19e169bf 493 prog => $tc->{prog}, stderr => 1,
5e251bf1 494 ); # verbose => 1);
f85f6494
SH
495 } elsif ($tc->{progfile}) {
496 $rendering = runperl( switches => ['-w',join(',',"-MO=Concise",@opts)],
497 progfile => $tc->{progfile}, stderr => 1,
498 ); # verbose => 1);
724aa791 499 } else {
19e169bf 500 my $code = $tc->{code};
724aa791 501 unless (ref $code eq 'CODE') {
19e169bf
JC
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) .';';
3feb66e7 505 {
d1718a7c 506 BEGIN { $^H = 0 }
3feb66e7
NC
507 no warnings;
508 $code = eval "$pkg sub { $code } }";
509 }
5e251bf1 510 # return errors
19e169bf 511 if ($@) { chomp $@; push @errs, $@ }
724aa791
JC
512 }
513 # set walk-output b4 compiling, which writes 'announce' line
514 walk_output(\$rendering);
ab7e0f54 515
724aa791
JC
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->();
19e169bf
JC
521
522 # kludge error into rendering if its empty.
523 $rendering = $@ if $@ and ! $rendering;
724aa791 524 }
19e169bf
JC
525 # separate banner, other stuff whose printing order isnt guaranteed
526 if ($tc->{strip}) {
5e251bf1 527 $rendering =~ s/(B::Concise::compile.*?\n)//;
19e169bf 528 print "stripped from rendering <$1>\n" if $1 and $tc->{stripv};
5e251bf1 529
19e169bf
JC
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};
5e251bf1
JC
533 push @errs, $1;
534 }
3731c1af
YST
535 $rendering =~ s/-e syntax OK\n//;
536 $rendering =~ s/-e had compilation errors\.\n//;
5e251bf1 537 }
19e169bf
JC
538 $tc->{got} = $rendering;
539 $tc->{goterrs} = \@errs if @errs;
5e251bf1 540 return $rendering, @errs;
724aa791
JC
541}
542
543sub get_bcopts {
544 # collect concise passthru-options if any
19e169bf 545 my ($tc) = shift;
724aa791 546 my @opts = ();
19e169bf
JC
547 if ($tc->{bcopts}) {
548 @opts = (ref $tc->{bcopts} eq 'ARRAY')
549 ? @{$tc->{bcopts}} : ($tc->{bcopts});
724aa791
JC
550 }
551 return @opts;
552}
553
19e169bf
JC
554sub checkErrs {
555 # check rendering errs against expected errors, reduce and report
556 my $tc = shift;
557
3f472914
NC
558 # check for agreement (order not important)
559 my (%goterrs, @missed);
25b57a7e
NC
560 @goterrs{@{$tc->{goterrs}}} = (1) x scalar @{$tc->{goterrs}}
561 if $tc->{goterrs};
562
3f472914
NC
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};
19e169bf
JC
574 }
575 }
19e169bf 576
3857d07c
NC
577 @missed = sort @missed;
578 my @got = sort keys %goterrs;
25b57a7e 579
3df2ec53
NC
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}")
19e169bf 585 }
3df2ec53
NC
586 _diag(join "\n", "got unexpected:", @got) if @got;
587 _diag(join "\n", "missed expected:", @missed) if @missed;
19e169bf
JC
588}
589
590=head1 mkCheckRex ($tc)
5e251bf1 591
19e169bf
JC
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.
5e251bf1 600
5e251bf1
JC
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
5e251bf1
JC
605
606=head2 match criteria
607
19e169bf 608The selected golden-sample is massaged to eliminate various match
98ccfbbf 609irrelevancies. This is done so that the tests don't fail just because
19e169bf
JC
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
5e251bf1 618Opcode arguments (text within braces) are disregarded for matching
3c4b39be 619purposes. This loses some info in 'add[t5]', but greatly simplifies
5e251bf1
JC
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
724aa791
JC
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
19e169bf 634 my ($tc, $want) = @_;
724aa791 635
19e169bf
JC
636 my $str = $tc->{expect} || $tc->{expect_nt}; # standard bias
637 $str = $tc->{$want} if $want && $tc->{$want}; # stated pref
724aa791 638
19e169bf 639 die("no '$want' golden-sample found: $tc->{name}") unless $str;
724aa791 640
19e169bf
JC
641 $str =~ s/^\# //mg; # ease cut-paste testcase authoring
642
82aeefe1
DM
643 # strip out conditional lines
644
82b84d04
FC
645 $str =~ s{^(.*?) \s+(<|<=|==|>=|>)\s*(5\.\d+)
646 (?:\s+(<|<=|==|>=|>)\s*(5\.\d+))? \ *\n}
82aeefe1 647 {
82b84d04 648 my ($line, $cmp, $version, $cmp2, $v2) = ($1,$2,$3,$4,$5,$6);
82aeefe1
DM
649 my $repl = "";
650 if ( $cmp eq '<' ? $] < $version
651 : $cmp eq '<=' ? $] <= $version
652 : $cmp eq '==' ? $] == $version
653 : $cmp eq '>=' ? $] >= $version
654 : $cmp eq '>' ? $] > $version
92dfa259 655 : die("bad comparison '$cmp' in string [$str]\n")
82b84d04
FC
656 and !$cmp2 || (
657 $cmp2 eq '<' ? $] < $v2
658 : $cmp2 eq '<=' ? $] <= $v2
659 : $cmp2 eq '==' ? $] == $v2
660 : $cmp2 eq '>=' ? $] >= $v2
661 : $cmp2 eq '>' ? $] > $v2
92dfa259 662 : die("bad comparison '$cmp2' in string [$str]\n")
82b84d04 663 )
82aeefe1
DM
664 ) {
665 $repl = "$line\n";
666 }
667 $repl;
82b84d04 668 }gemx;
82aeefe1 669
19e169bf 670 $tc->{wantstr} = $str;
724aa791 671
fedf30e1
DM
672 # make UNOP_AUX flag type literal
673 $str =~ s/<\+>/<\\+>/;
ab7e0f54
JC
674 # make targ args wild
675 $str =~ s/\[t\d+\]/[t\\d+]/msg;
676
b7b1e41b 677 # escape bracing, etc.. manual \Q (doesn't escape '+')
cc02ea56 678 $str =~ s/([\[\]()*.\$\@\#\|{}])/\\$1/msg;
ab7e0f54 679 # $str =~ s/(?<!\\)([\[\]\(\)*.\$\@\#\|{}])/\\$1/msg;
cc02ea56 680
19e169bf 681 # treat dbstate like nextstate (no in-debugger false reports)
be2b1c74
NC
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;
5e251bf1
JC
698 # widened for -terse mode
699 $str =~ s/(?:next|db)state/(?:next|db)state/msg;
be2b1c74
NC
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 )
a27615d6 706 (?:(:>,<,%,\\\{) # hints when open.pm is in force
be2b1c74 707 |(:>,<,%)) # (two variations)
aa0b6d22 708 (\ ->(?:-|[0-9a-z]+))?
be2b1c74
NC
709 $
710 ]
a27615d6 711 [$1 . ($2 && ':\{') . $4]xegm; # change to the hints without open.pm
e412117e
NC
712 }
713
5e251bf1 714
cc02ea56
JC
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
9cf14a5a 720 $str =~ s/FAKE:(\w):\d+/FAKE:$1:\\d+/msg; # parent pad index
724aa791 721
19e169bf 722 $str =~ s/(\d refs?)/\\d+ refs?/msg; # 1 ref, 2+ refs (plural)
5e251bf1 723 $str =~ s/leavesub \[\d\]/leavesub [\\d]/msg; # for -terse
19e169bf
JC
724 #$str =~ s/(\s*)\n/\n/msg; # trailing spaces
725
332878e1 726 croak "whitespace only reftext found for '$want': $tc->{name}"
724aa791 727 unless $str =~ /\w+/; # fail unless a real test
ab7e0f54 728
724aa791
JC
729 # $str = '.*' if 1; # sanity test
730 # $str .= 'FAIL' if 1; # sanity test
731
cc02ea56
JC
732 # allow -eval, banner at beginning of anchored matches
733 $str = "(-e .*?)?(B::Concise::compile.*?)?\n" . $str
19e169bf 734 unless $tc->{noanchors} or $tc->{rxnoorder};
cc02ea56 735
19e169bf 736 my $qr = ($tc->{noanchors}) ? qr/$str/ms : qr/^$str$/ms ;
724aa791 737
19e169bf
JC
738 $tc->{rex} = $qr;
739 $tc->{rexstr} = $str;
740 $tc;
724aa791
JC
741}
742
19e169bf
JC
743##############
744# compare and report
cc02ea56 745
19e169bf
JC
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
19e169bf 754 # bad is anticipated failure
b2d32ffb 755 my $bad = ($cross && $tc->{crossfail}) || (!$cross && $tc->{fail});
19e169bf 756
b2d32ffb 757 my $ok = $bad ? unlike ($got, $want, $cmnt) : like ($got, $want, $cmnt);
19e169bf
JC
758
759 reduceDiffs ($tc) if not $ok;
760
19e169bf
JC
761 return $ok;
762}
724aa791 763
19e169bf
JC
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");
724aa791
JC
790}
791
19e169bf
JC
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.
cc02ea56 797
19e169bf
JC
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.
3c4b39be 818 4. can develop regexes which accommodate T-nT differences.
19e169bf
JC
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";
3feb66e7 907 foreach my $it (@_) {
19e169bf
JC
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############################
cc02ea56
JC
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
19e169bf 956 paste your 'golden-example' here, then retest
cc02ea56 957EOT_EOT
19e169bf
JC
958NonThreadedRef
959 paste your 'golden-example' here, then retest
cc02ea56
JC
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) {
19e169bf 980 my $goldentxt = $1;
cc02ea56
JC
981 #and plug it into the test-src
982 if ($threaded) {
19e169bf 983 $testcode =~ s/ThreadedRef/$goldentxt/;
cc02ea56 984 } else {
19e169bf 985 $testcode =~ s/NonThreadRef/$goldentxt/;
cc02ea56
JC
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
cc02ea56
JC
991 return $testcode;
992 }
993 return '';
994}
995
996
997sub OptreeCheck::processExamples {
998 my @files = @_;
19e169bf 999
1c2e8cca 1000 # gets array of paragraphs, which should be code-samples. They're
19e169bf 1001 # turned into optreeCheck tests,
cc02ea56
JC
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);
3feb66e7 1008 foreach my $t (@chunks) {
cc02ea56
JC
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
724aa791
JC
10371;
1038
1039__END__
1040
cc02ea56 1041=head1 TEST DEVELOPMENT SUPPORT
724aa791 1042
cc02ea56
JC
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:
724aa791 1046
cc02ea56 1047 1. write a set of sample code into a single file, one per
19e169bf
JC
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.
724aa791 1050
cc02ea56 1051 2. run OptreeCheck as a program on the file
724aa791 1052
cc02ea56
JC
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
724aa791 1055
cc02ea56
JC
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.
724aa791 1059
cc02ea56
JC
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.
724aa791 1065
5e251bf1
JC
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
724aa791 1072=cut