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