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