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