This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
libperl leaks a THREAD_KEY each time it is reloaded
[perl5.git] / ext / B / t / OptreeCheck.pm
CommitLineData
cc02ea56
JC
1# non-package OptreeCheck.pm
2# pm allows 'use OptreeCheck', which also imports
3# no package decl means all functions defined into main
724aa791
JC
4# otherwise, it's like "require './test.pl'"
5
6=head1 NAME
7
5e251bf1 8OptreeCheck - check optrees as rendered by B::Concise
724aa791
JC
9
10=head1 SYNOPSIS
11
12OptreeCheck supports regression testing of perl's parser, optimizer,
5e251bf1
JC
13bytecode generator, via a single function: checkOptree(%args). It
14invokes B::Concise upon sample code, and checks that it 'agrees' with
15reference renderings.
16
17 checkOptree (
18 name => "test-name', # optional, (synth from others)
19
20 # 2 kinds of code-under-test: must provide 1
21 code => sub {my $a}, # coderef, or source (wrapped and evald)
22 prog => 'sort @a', # run in subprocess, aka -MO=Concise
23
24 bcopts => '-exec', # $opt or \@opts, passed to BC::compile
25 # errs => '.*', # match against any emitted errs, -w warnings
26 # skip => 1, # skips test
27 # todo => 'excuse', # anticipated failures
28 # fail => 1 # force fail (by redirecting result)
29 # debug => 1, # turns on regex debug for match test !!
30 # retry => 1 # retry with debug on test failure
31
32 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT' );
724aa791
JC
33 # 1 <;> nextstate(main 45 optree.t:23) v
34 # 2 <0> padsv[$a:45,46] M/LVINTRO
35 # 3 <1> leavesub[1 ref] K/REFC,1
36 EOT_EOT
37 # 1 <;> nextstate(main 45 optree.t:23) v
38 # 2 <0> padsv[$a:45,46] M/LVINTRO
39 # 3 <1> leavesub[1 ref] K/REFC,1
40 EONT_EONT
41
42=head1 checkOptree(%in) Overview
43
5e251bf1
JC
44optreeCheck() calls getRendering(), which runs code or prog through
45B::Concise, and captures its rendering.
724aa791 46
5e251bf1
JC
47It then calls mkCheckRex() to produce a regex which will match the
48expected rendering, and fail when it doesn't match.
49
50Finally, it compares the 2; like($rendering,/$regex/,$testname).
724aa791 51
724aa791
JC
52
53=head1 checkOptree(%Args) API
54
55Accepts %Args, with following requirements and actions:
56
cc02ea56 57Either code or prog must be present. prog is some source code, and is
5e251bf1
JC
58passed through via test.pl:runperl, to B::Concise like this: (bcopts
59are fixed up for cmdline)
724aa791
JC
60
61 './perl -w -MO=Concise,$bcopts_massaged -e $src'
62
63code is a subref, or $src, like above. If it's not a subref, it's
5e251bf1 64treated like source-code, is wrapped as a subroutine, and is passed to
cc02ea56 65B::Concise::compile().
724aa791
JC
66
67 $subref = eval "sub{$src}";
5e251bf1
JC
68 B::Concise::compile($subref).
69
70expect and expect_nt are the reference optree renderings. Theyre
71required, except when the code/prog compilation fails.
724aa791 72
cc02ea56 73I suppose I should also explain these more, but they seem obvious.
724aa791
JC
74
75 # prog => 'sort @a', # run in subprocess, aka -MO=Concise
cc02ea56
JC
76 # noanchors => 1, # no /^$/. needed for 1-liners like above
77
724aa791 78 # skip => 1, # skips test
cc02ea56
JC
79 # todo => 'excuse', # anticipated failures
80 # fail => 1 # fails (by redirecting result)
724aa791
JC
81 # debug => 1, # turns on regex debug for match test !!
82 # retry => 1 # retry with debug on test failure
83
cc02ea56 84=head1 Test Philosophy
724aa791
JC
85
862 platforms --> 2 reftexts: You want an accurate test, independent of
cc02ea56
JC
87which platform you're on. So, two refdata properties, 'expect' and
88'expect_nt', carry renderings taken from threaded and non-threaded
89builds. This has several benefits:
724aa791 90
cc02ea56
JC
91 1. native reference data allows closer matching by regex.
92 2. samples can be eyeballed to grok t-nt differences.
93 3. data can help to validate mkCheckRex() operation.
94 4. can develop regexes which accomodate t-nt differences.
95 5. can test with both native and cross+converted regexes.
724aa791
JC
96
97Cross-testing (expect_nt on threaded, expect on non-threaded) exposes
98differences in B::Concise output, so mkCheckRex has code to do some
99cross-test manipulations. This area needs more work.
100
101=head1 Test Modes
102
103One consequence of a single-function API is difficulty controlling
104test-mode. Ive chosen for now to use a package hash, %gOpts, to store
105test-state. These properties alter checkOptree() function, either
106short-circuiting to selftest, or running a loop that runs the testcase
1072^N times, varying conditions each time. (current N is 2 only).
108
109So Test-mode is controlled with cmdline args, also called options below.
110Run with 'help' to see the test-state, and how to change it.
111
112=head2 selftest
113
114This argument invokes runSelftest(), which tests a regex against the
115reference renderings that they're made from. Failure of a regex match
116its 'mold' is a strong indicator that mkCheckRex is buggy.
117
118That said, selftest mode currently runs a cross-test too, they're not
119completely orthogonal yet. See below.
120
121=head2 testmode=cross
122
123Cross-testing is purposely creating a T-NT mismatch, looking at the
124fallout, and tweaking the regex to deal with it. Thus tests lead to
125'provably' complete understanding of the differences.
126
127The tweaking appears contrary to the 2-refs philosophy, but the tweaks
128will be made in conversion-specific code, which (will) handles T->NT
129and NT->T separately. The tweaking is incomplete.
130
131A reasonable 1st step is to add tags to indicate when TonNT or NTonT
132is known to fail. This needs an option to force failure, so the
133test.pl reporting mechanics show results to aid the user.
134
135=head2 testmode=native
136
137This is normal mode. Other valid values are: native, cross, both.
138
139=head2 checkOptree Notes
140
141Accepts test code, renders its optree using B::Concise, and matches that
142rendering against a regex built from one of 2 reference-renderings %in data.
143
144The regex is built by mkCheckRex(\%in), which scrubs %in data to
145remove match-irrelevancies, such as (args) and [args]. For example,
146it strips leading '# ', making it easy to cut-paste new tests into
147your test-file, run it, and cut-paste actual results into place. You
148then retest and reedit until all 'errors' are gone. (now make sure you
149haven't 'enshrined' a bug).
150
151name: The test name. May be augmented by a label, which is built from
152important params, and which helps keep names in sync with whats being
cc02ea56 153tested.'
724aa791
JC
154
155=cut
156
157use Config;
158use Carp;
159use B::Concise qw(walk_output);
160use Data::Dumper;
161$Data::Dumper::Sortkeys = 1;
162
163BEGIN {
164 $SIG{__WARN__} = sub {
165 my $err = shift;
166 $err =~ m/Subroutine re::(un)?install redefined/ and return;
167 };
168}
169
170# but wait - more skullduggery !
171sub OptreeCheck::import { &getCmdLine; } # process @ARGV
172
173# %gOpts params comprise a global test-state. Initial values here are
174# HELP strings, they MUST BE REPLACED by runtime values before use, as
175# is done by getCmdLine(), via import
176
177our %gOpts = # values are replaced at runtime !!
178 (
179 # scalar values are help string
180 rextract => 'writes src-code todo same Optree matching',
181 vbasic => 'prints $str and $rex',
182 retry => 'retry failures after turning on re debug',
183 retrydbg => 'retry failures after turning on re debug',
184 selftest => 'self-tests mkCheckRex vs the reference rendering',
185 selfdbg => 'redo failing selftests with re debug',
186 xtest => 'extended thread/non-thread testing',
187 fail => 'force all test to fail, print to stdout',
188 dump => 'dump cmdline arg prcessing',
189 rexpedant => 'try tighter regex, still buggy',
cc02ea56 190 noanchors => 'dont anchor match rex',
724aa791
JC
191 help => 0, # 1 ends in die
192
193 # array values are one-of selections, with 1st value as default
724aa791 194 testmode => [qw/ native cross both /],
5e251bf1
JC
195
196 # fixup for VMS, cygwin, which dont have stderr b4 stdout
197 # 2nd value is used as help-str, 1st val (still) default
198
199 rxnoorder => [1, 'if 1, dont req match on -e lines, and -banner',0],
200 strip => [1, 'if 1, catch errs and remove from renderings',0],
201 stripv => 'if strip&&1, be verbose about it',
202 errs => 'expected compile errs',
724aa791
JC
203 );
204
205
54cf8e17
NC
206# Not sure if this is too much cheating. Officially we say that
207# $Config::Config{usethreads} is true if some sort of threading is in use,
208# in which case we ought to be able to use it in place of the || below.
209# However, it is now possible to Configure perl with "threads" but neither
210# ithreads or 5005threads, which forces the re-entrant APIs, but no perl
211# user visible threading. This seems to have the side effect that most of perl
212# doesn't think that it's threaded, hence the ops aren't threaded either.
213# Not sure if this is actually a "supported" configuration, but given that
214# ponie uses it, it's going to be used by something official at least in the
215# interim. So it's nice for tests to all pass.
216our $threaded = 1
217 if $Config::Config{useithreads} || $Config::Config{use5005threads};
724aa791
JC
218our $platform = ($threaded) ? "threaded" : "plain";
219our $thrstat = ($threaded) ? "threaded" : "nonthreaded";
220
221our ($MatchRetry,$MatchRetryDebug); # let mylike be generic
222# test.pl-ish hack
223*MatchRetry = \$gOpts{retry}; # but alias it into %gOpts
224*MatchRetryDebug = \$gOpts{retrydbg}; # but alias it into %gOpts
225
226our %modes = (
227 both => [ 'expect', 'expect_nt'],
228 native => [ ($threaded) ? 'expect' : 'expect_nt'],
229 cross => [ !($threaded) ? 'expect' : 'expect_nt'],
230 expect => [ 'expect' ],
231 expect_nt => [ 'expect_nt' ],
cc02ea56 232 );
724aa791
JC
233
234our %msgs # announce cross-testing.
235 = (
236 # cross-platform
237 'expect_nt-threaded' => " (Non-threaded-ref on Threaded-build)",
238 'expect-nonthreaded' => " (Threaded-ref on Non-threaded-build)",
239 # native - nothing to say
240 'expect_nt-nonthreaded' => '',
241 'expect-threaded' => '',
242 );
243
244#######
245sub getCmdLine { # import assistant
246 # offer help
247 print(qq{\n$0 accepts args to update these state-vars:
248 turn on a flag by typing its name,
249 select a value from list by typing name=val.\n },
250 Dumper \%gOpts)
251 if grep /help/, @ARGV;
252
253 # replace values for each key !! MUST MARK UP %gOpts
254 foreach my $opt (keys %gOpts) {
255
256 # scan ARGV for known params
257 if (ref $gOpts{$opt} eq 'ARRAY') {
258
259 # $opt is a One-Of construct
260 # replace with valid selection from the list
261
262 # uhh this WORKS. but it's inscrutable
263 # grep s/$opt=(\w+)/grep {$_ eq $1} @ARGV and $gOpts{$opt}=$1/e, @ARGV;
264 my $tval; # temp
265 if (grep s/$opt=(\w+)/$tval=$1/e, @ARGV) {
266 # check val before accepting
267 my @allowed = @{$gOpts{$opt}};
268 if (grep { $_ eq $tval } @allowed) {
269 $gOpts{$opt} = $tval;
270 }
271 else {die "invalid value: '$tval' for $opt\n"}
272 }
273
274 # take 1st val as default
275 $gOpts{$opt} = ${$gOpts{$opt}}[0]
276 if ref $gOpts{$opt} eq 'ARRAY';
277 }
278 else { # handle scalars
279
280 # if 'opt' is present, true
281 $gOpts{$opt} = (grep /$opt/, @ARGV) ? 1 : 0;
282
283 # override with 'foo' if 'opt=foo' appears
284 grep s/$opt=(.*)/$gOpts{$opt}=$1/e, @ARGV;
285 }
5e251bf1 286 }
724aa791
JC
287 print("$0 heres current state:\n", Dumper \%gOpts)
288 if $gOpts{help} or $gOpts{dump};
289
290 exit if $gOpts{help};
291}
5e251bf1 292# the above arg-handling cruft should be replaced by a Getopt call
724aa791
JC
293
294##################################
295# API
296
297sub checkOptree {
298 my %in = @_;
299 my ($in, $res) = (\%in,0); # set up privates.
300
301 print "checkOptree args: ",Dumper \%in if $in{dump};
302 SKIP: {
cc02ea56 303 label(\%in);
724aa791 304 skip($in{name}, 1) if $in{skip};
5e251bf1
JC
305
306 # cpy globals into each test
307 foreach $k (keys %gOpts) {
308 if ($gOpts{$k}) {
309 $in{$k} = $gOpts{$k} unless $in{$k};
310 }
311 }
312 #die "no reftext found for $want: $in->{name}" unless $str;
313
724aa791
JC
314 return runSelftest(\%in) if $gOpts{selftest};
315
5e251bf1
JC
316 my ($rendering,@errs) = getRendering(\%in); # get the actual output
317
318 if ($in->{errs}) {
319 if (@errs) {
320 like ("@errs", qr/$in->{errs}\s*/, "$in->{name} - matched expected errs");
321 next;
322 }
323 }
724aa791
JC
324 fail("FORCED: $in{name}:\n$rendering") if $gOpts{fail}; # silly ?
325
326 # Test rendering against ..
cc02ea56 327 TODO:
724aa791 328 foreach $want (@{$modes{$gOpts{testmode}}}) {
cc02ea56 329 local $TODO = $in{todo} if $in{todo};
724aa791 330
cc02ea56 331 my ($rex,$txt,$rexstr) = mkCheckRex(\%in,$want);
724aa791
JC
332 my $cross = $msgs{"$want-$thrstat"};
333
334 # bad is anticipated failure on cross testing ONLY
335 my $bad = (0 or ( $cross && $in{crossfail})
336 or (!$cross && $in{fail})
cc02ea56 337 or 0); # no undefs! pedant
724aa791
JC
338
339 # couldn't bear to pass \%in to likeyn
340 $res = mylike ( # custom test mode stuff
341 [ !$bad,
cc02ea56
JC
342 $in{retry} || $gOpts{retry},
343 $in{debug} || $gOpts{retrydbg},
344 $rexstr,
724aa791
JC
345 ],
346 # remaining is std API
cc02ea56 347 $rendering, qr/$rex/ms, "$cross $in{name} $in{label}")
724aa791
JC
348 || 0;
349 printhelp(\%in, $rendering, $rex);
350 }
351 }
352 $res;
353}
354
355#################
356# helpers
357
358sub label {
359 # may help get/keep test output consistent
360 my ($in) = @_;
cc02ea56
JC
361 return if $in->{name};
362
363 my $buf = (ref $in->{bcopts})
364 ? join(',', @{$in->{bcopts}}) : $in->{bcopts};
365
366 foreach (qw( note prog code )) {
367 $buf .= " $_: $in->{$_}" if $in->{$_} and not ref $in->{$_};
368 }
369 return $in->{label} = $buf;
724aa791
JC
370}
371
372sub testCombo {
373 # generate a set of test-cases from the options
374 my $in = @_;
375 my @cases;
376 foreach $want (@{$modes{$gOpts{testmode}}}) {
cc02ea56 377 push @cases, [ %in ]
724aa791
JC
378 }
379 return @cases;
380}
381
382sub runSelftest {
383 # tests the test-cases offered (expect, expect_nt)
384 # needs Unification with above.
385 my ($in) = @_;
386 my $ok;
387 foreach $want (@{$modes{$gOpts{testmode}}}) {}
388
389 for my $provenance (qw/ expect expect_nt /) {
390 next unless $in->{$provenance};
391 my ($rex,$gospel) = mkCheckRex($in, $provenance);
392 return unless $gospel;
393
394 my $cross = $msgs{"$provenance-$thrstat"};
395 my $bad = (0 or ( $cross && $in->{crossfail})
396 or (!$cross && $in->{fail})
397 or 0);
398 # couldn't bear to pass \%in to likeyn
399 $res = mylike ( [ !$bad,
400 $in->{retry} || $gOpts{retry},
cc02ea56
JC
401 $in->{debug} || $gOpts{retrydbg},
402 #label($in)
724aa791
JC
403 ],
404 $rendering, qr/$rex/ms, "$cross $in{name}")
405 || 0;
406 }
407 $ok;
408}
409
410# use re;
411sub mylike {
412 # note dependence on unlike()
413 my ($control) = shift;
cc02ea56 414 my ($yes,$retry,$debug,$postmortem) = @$control; # or dies
724aa791
JC
415 my ($got, $expected, $name, @mess) = @_; # pass thru mostly
416
417 die "unintended usage, expecting Regex". Dumper \@_
418 unless ref $_[1] eq 'Regexp';
419
cc02ea56
JC
420 #ok($got=~/$expected/, "wow");
421
724aa791
JC
422 # same as A ^ B, but B has side effects
423 my $ok = ( (!$yes and unlike($got, $expected, $name, @mess))
424 or ($yes and like($got, $expected, $name, @mess)));
425
cc02ea56
JC
426 if (not $ok and $postmortem) {
427 # split rexstr into units that should eat leading lines.
428 my @rexs = map qr/^$_/, split (/\n/,$postmortem);
429 foreach my $rex (@rexs) {
430 #$got =~ s/($rex)/ate: $1/msg; # noisy
431 $got =~ s/($rex)\n//msg; # remove matches
432 }
5e251bf1 433 print "these lines not matched:\n$got\n";
cc02ea56
JC
434 }
435
724aa791 436 if (not $ok and $retry) {
cc02ea56 437 # redo, perhaps with use re debug - NOT ROBUST
724aa791
JC
438 eval "use re 'debug'" if $debug;
439 $ok = (!$yes and unlike($got, $expected, "(RETRY) $name", @mess)
440 or $yes and like($got, $expected, "(RETRY) $name", @mess));
441
442 no re 'debug';
443 }
444 return $ok;
445}
446
447sub getRendering {
448 my ($in) = @_;
449 die "getRendering: code or prog is required\n"
450 unless $in->{code} or $in->{prog};
451
452 my @opts = get_bcopts($in);
453 my $rendering = ''; # suppress "Use of uninitialized value in open"
5e251bf1
JC
454 my @errs; # collect errs via
455
724aa791
JC
456
457 if ($in->{prog}) {
458 $rendering = runperl( switches => ['-w',join(',',"-MO=Concise",@opts)],
459 prog => $in->{prog}, stderr => 1,
5e251bf1 460 ); # verbose => 1);
724aa791
JC
461 } else {
462 my $code = $in->{code};
463 unless (ref $code eq 'CODE') {
464 # treat as source, and wrap
465 $code = eval "sub { $code }";
5e251bf1
JC
466 # return errors
467 push @errs, $@ if $@;
724aa791
JC
468 }
469 # set walk-output b4 compiling, which writes 'announce' line
470 walk_output(\$rendering);
471 if ($in->{fail}) {
472 fail("forced failure: stdout follows");
473 walk_output(\*STDOUT);
474 }
475 my $opwalker = B::Concise::compile(@opts, $code);
476 die "bad BC::compile retval" unless ref $opwalker eq 'CODE';
477
478 B::Concise::reset_sequence();
479 $opwalker->();
480 }
5e251bf1
JC
481 if ($in->{strip}) {
482 $rendering =~ s/(B::Concise::compile.*?\n)//;
483 print "stripped from rendering <$1>\n" if $1 and $in->{stripv};
484
485 while ($rendering =~ s/^(.*?-e line .*?\n)//g) {
486 print "stripped <$1>\n" if $in->{stripv};
487 push @errs, $1;
488 }
3731c1af
YST
489 $rendering =~ s/-e syntax OK\n//;
490 $rendering =~ s/-e had compilation errors\.\n//;
5e251bf1
JC
491 }
492 return $rendering, @errs;
724aa791
JC
493}
494
495sub get_bcopts {
496 # collect concise passthru-options if any
497 my ($in) = shift;
498 my @opts = ();
499 if ($in->{bcopts}) {
500 @opts = (ref $in->{bcopts} eq 'ARRAY')
501 ? @{$in->{bcopts}} : ($in->{bcopts});
502 }
503 return @opts;
504}
505
5e251bf1
JC
506=head1 mkCheckRex
507
508mkCheckRex receives the full testcase object, and constructs a regex.
5091st, it selects a reftxt from either the expect or expect_nt items.
510
511Once selected, the reftext is massaged & converted into a Regex that
512accepts 'good' concise renderings, with appropriate input variations,
513but is otherwise as strict as possible. For example, it should *not*
514match when opcode flags change, or when optimizations convert an op to
515an ex-op.
516
517selection is driven by platform mostly, but also by test-mode, which
518rather complicates the code. this is worsened by the potential need
519to make platform specific conversions on the reftext.
520
521=head2 match criteria
522
523Opcode arguments (text within braces) are disregarded for matching
524purposes. This loses some info in 'add[t5]', but greatly simplifys
525matching 'nextstate(main 22 (eval 10):1)'. Besides, we are testing
526for regressions, not for complete accuracy.
527
528The regex is anchored by default, but can be suppressed with
529'noanchors', allowing 1-liner tests to succeed if opcode is found.
530
531=cut
532
724aa791
JC
533# needless complexity due to 'too much info' from B::Concise v.60
534my $announce = 'B::Concise::compile\(CODE\(0x[0-9a-f]+\)\)';;
535
536sub mkCheckRex {
537 # converts expected text into Regexp which should match against
538 # unaltered version. also adjusts threaded => non-threaded
539 my ($in, $want) = @_;
540 eval "no re 'debug'";
541
542 my $str = $in->{expect} || $in->{expect_nt}; # standard bias
543 $str = $in->{$want} if $want; # stated pref
544
724aa791
JC
545 #fail("rex-str is empty, won't allow false positives") unless $str;
546
547 $str =~ s/^\# //mg; # ease cut-paste testcase authoring
548 my $reftxt = $str; # extra return val !!
549
cc02ea56
JC
550 # convert all (args) and [args] to temp forms wo bracing
551 $str =~ s/\[(.*?)\]/__CAPSQR$1__/msg;
552 $str =~ s/\((.*?)\)/__CAPRND$1__/msg;
553 $str =~ s/\((.*?)\)/__CAPRND$1__/msg; # nested () in nextstate
554
555 # escape bracing, etc.. manual \Q (doesnt escape '+')
556 $str =~ s/([\[\]()*.\$\@\#\|{}])/\\$1/msg;
557
558 # now replace temp forms with original, preserving reference bracing
559 $str =~ s/__CAPSQR(.*?)__\b/\\[$1\\]/msg; # \b is important
560 $str =~ s/__CAPRND(.*?)__\b/\\($1\\)/msg;
561 $str =~ s/__CAPRND(.*?)__\b/\\($1\\)/msg; # nested () in nextstate
562
563 # no 'invisible' failures in debugger
564 $str =~ s/(?:next|db)state(\\\(.*?\\\))/(?:next|db)state(.*?)/msg;
5e251bf1
JC
565 # widened for -terse mode
566 $str =~ s/(?:next|db)state/(?:next|db)state/msg;
567
cc02ea56
JC
568 # don't care about:
569 $str =~ s/:-?\d+,-?\d+/:-?\\d+,-?\\d+/msg; # FAKE line numbers
570 $str =~ s/match\\\(.*?\\\)/match\(.*?\)/msg; # match args
571 $str =~ s/(0x[0-9A-Fa-f]+)/0x[0-9A-Fa-f]+/msg; # hexnum values
572 $str =~ s/".*?"/".*?"/msg; # quoted strings
724aa791 573
5e251bf1
JC
574 $str =~ s/(\d refs?)/\\d refs?/msg;
575 $str =~ s/leavesub \[\d\]/leavesub [\\d]/msg; # for -terse
576
724aa791
JC
577 croak "no reftext found for $want: $in->{name}"
578 unless $str =~ /\w+/; # fail unless a real test
579
580 # $str = '.*' if 1; # sanity test
581 # $str .= 'FAIL' if 1; # sanity test
582
cc02ea56
JC
583 # allow -eval, banner at beginning of anchored matches
584 $str = "(-e .*?)?(B::Concise::compile.*?)?\n" . $str
5e251bf1 585 unless $in->{noanchors} or $in->{rxnoorder};
cc02ea56 586
724aa791 587 eval "use re 'debug'" if $debug;
cc02ea56 588 my $qr = ($in->{noanchors}) ? qr/$str/ms : qr/^$str$/ms ;
724aa791
JC
589 no re 'debug';
590
cc02ea56 591 return ($qr, $reftxt, $str) if wantarray;
724aa791
JC
592 return $qr;
593}
594
cc02ea56 595
724aa791 596sub printhelp {
cc02ea56 597 # crufty - may be still useful
724aa791 598 my ($in, $rendering, $rex) = @_;
cc02ea56 599 print "<$rendering>\nVS\n<$rex>\n" if $gOpts{vbasic};
724aa791
JC
600
601 # save this output to afile, edit out 'ok's and 1..N
602 # then perl -d afile, and add re 'debug' to suit.
cc02ea56
JC
603 print("\$str = q%$rendering%;\n".
604 "\$rex = qr%$rex%;\n\n".
605 #"print \"\$str =~ m%\$rex%ms \";\n".
724aa791
JC
606 "\$str =~ m{\$rex}ms or print \"doh\\n\";\n\n")
607 if $in{rextract} or $gOpts{rextract};
608}
609
cc02ea56
JC
610
611#########################
612# support for test writing
613
614sub preamble {
615 my $testct = shift || 1;
616 return <<EO_HEADER;
617#!perl
618
619BEGIN {
620 chdir q(t);
621 \@INC = qw(../lib ../ext/B/t);
622 require q(./test.pl);
623}
624use OptreeCheck;
625plan tests => $testct;
626
627EO_HEADER
628
629}
630
631sub OptreeCheck::wrap {
632 my $code = shift;
633 $code =~ s/(?:(\#.*?)\n)//gsm;
634 $code =~ s/\s+/ /mgs;
635 chomp $code;
636 return unless $code =~ /\S/;
637 my $comment = $1;
638
639 my $testcode = qq{
640
641checkOptree(note => q{$comment},
642 bcopts => q{-exec},
643 code => q{$code},
644 expect => <<EOT_EOT, expect_nt => <<EONT_EONT);
645ThreadedRef
646EOT_EOT
647NonThreadRef
648EONT_EONT
649
650};
651 return $testcode;
652}
653
654sub OptreeCheck::gentest {
655 my ($code,$opts) = @_;
656 my $rendering = getRendering({code => $code});
657 my $testcode = OptreeCheck::wrap($code);
658 return unless $testcode;
659
660 # run the prog, capture 'reference' concise output
661 my $preamble = preamble(1);
662 my $got = runperl( prog => "$preamble $testcode", stderr => 1,
663 #switches => ["-I../ext/B/t", "-MOptreeCheck"],
664 ); #verbose => 1);
665
666 # extract the 'reftext' ie the got 'block'
667 if ($got =~ m/got \'.*?\n(.*)\n\# \'\n\# expected/s) {
668 my $reftext = $1;
669 #and plug it into the test-src
670 if ($threaded) {
671 $testcode =~ s/ThreadedRef/$reftext/;
672 } else {
673 $testcode =~ s/NonThreadRef/$reftext/;
674 }
675 my $b4 = q{expect => <<EOT_EOT, expect_nt => <<EONT_EONT};
676 my $af = q{expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'};
677 $testcode =~ s/$b4/$af/;
678
679 my $got;
680 if ($internal_retest) {
681 $got = runperl( prog => "$preamble $testcode", stderr => 1,
682 #switches => ["-I../ext/B/t", "-MOptreeCheck"],
683 verbose => 1);
684 print "got: $got\n";
685 }
686 return $testcode;
687 }
688 return '';
689}
690
691
692sub OptreeCheck::processExamples {
693 my @files = @_;
694 # gets array of paragraphs, which should be tests.
695
696 foreach my $file (@files) {
697 open (my $fh, $file) or die "cant open $file: $!\n";
698 $/ = "";
699 my @chunks = <$fh>;
700 print preamble (scalar @chunks);
701 foreach $t (@chunks) {
702 print "\n\n=for gentest\n\n# chunk: $t=cut\n\n";
703 print OptreeCheck::gentest ($t);
704 }
705 }
706}
707
708# OK - now for the final insult to your good taste...
709
710if ($0 =~ /OptreeCheck\.pm/) {
711
712 #use lib 't';
713 require './t/test.pl';
714
715 # invoked as program. Work like former gentest.pl,
716 # ie read files given as cmdline args,
717 # convert them to usable test files.
718
719 require Getopt::Std;
720 Getopt::Std::getopts('') or
721 die qq{ $0 sample-files* # no options
722
723 expecting filenames as args. Each should have paragraphs,
724 these are converted to checkOptree() tests, and printed to
725 stdout. Redirect to file then edit for test. \n};
726
727 OptreeCheck::processExamples(@ARGV);
728}
729
724aa791
JC
7301;
731
732__END__
733
cc02ea56 734=head1 TEST DEVELOPMENT SUPPORT
724aa791 735
cc02ea56
JC
736This optree regression testing framework needs tests in order to find
737bugs. To that end, OptreeCheck has support for developing new tests,
738according to the following model:
724aa791 739
cc02ea56
JC
740 1. write a set of sample code into a single file, one per
741 paragraph. f_map and f_sort in ext/B/t/ are examples.
724aa791 742
cc02ea56 743 2. run OptreeCheck as a program on the file
724aa791 744
cc02ea56
JC
745 ./perl -Ilib ext/B/t/OptreeCheck.pm -w ext/B/t/f_map
746 ./perl -Ilib ext/B/t/OptreeCheck.pm -w ext/B/t/f_sort
724aa791 747
cc02ea56
JC
748 gentest reads the sample code, runs each to generate a reference
749 rendering, folds this rendering into an optreeCheck() statement,
750 and prints it to stdout.
724aa791 751
cc02ea56
JC
752 3. run the output file as above, redirect to files, then rerun on
753 same build (for sanity check), and on thread-opposite build. With
754 editor in 1 window, and cmd in other, it's fairly easy to cut-paste
755 the gots into the expects, easier than running step 2 on both
756 builds then trying to sdiff them together.
724aa791 757
cc02ea56 758=head1 TODO
724aa791 759
cc02ea56
JC
760There's a considerable amount of cruft in the whole arg-handling setup.
761I'll replace / strip it before 5.10
724aa791 762
cc02ea56 763Treat %in as a test object, interwork better with Test::*
724aa791 764
cc02ea56
JC
765Refactor mkCheckRex() and selfTest() to isolate the selftest,
766crosstest, etc selection mechanics.
724aa791 767
cc02ea56
JC
768improve retry, retrydbg, esp. it's control of eval "use re debug".
769This seems to work part of the time, but isn't stable enough.
724aa791 770
5e251bf1
JC
771=head1 CAVEATS
772
773This code is purely for testing core. While checkOptree feels flexible
774enough to be stable, the whole selftest framework is subject to change
775w/o notice.
776
724aa791 777=cut