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