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