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