Re: [patch] decrufting OptreeCheck stuff
[p5sagit/p5-mst-13.2.git] / ext / B / t / optree_concise.t
CommitLineData
724aa791 1#!perl
2
3BEGIN {
5638aaac 4 if ($ENV{PERL_CORE}){
5 chdir('t') if -d 't';
6 @INC = ('.', '../lib', '../ext/B/t');
7 } else {
8 unshift @INC, 't';
9 push @INC, "../../t";
10 }
9cd8f857 11 require Config;
12 if (($Config::Config{'extensions'} !~ /\bB\b/) ){
13 print "1..0 # Skip -- Perl configured without B module\n";
14 exit 0;
15 }
19e169bf 16 # require 'test.pl'; # now done by OptreeCheck
724aa791 17}
18
19# import checkOptree(), and %gOpts (containing test state)
20use OptreeCheck; # ALSO DOES @ARGV HANDLING !!!!!!
2ce64696 21use Config;
724aa791 22
19e169bf 23plan tests => 23;
2ce64696 24SKIP: {
4837be01 25skip "no perlio in this build", 24 unless $Config::Config{useperlio};
724aa791 26
27$SIG{__WARN__} = sub {
28 my $err = shift;
29 $err =~ m/Subroutine re::(un)?install redefined/ and return;
30};
31#################################
32pass("CANONICAL B::Concise EXAMPLE");
33
34checkOptree ( name => 'canonical example w -basic',
35 bcopts => '-basic',
36 code => sub{$a=$b+42},
37 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
19e169bf 38# 7 <1> leavesub[1 ref] K/REFC,1 ->(end)
724aa791 39# - <@> lineseq KP ->7
40# 1 <;> nextstate(foo bar) v ->2
41# 6 <2> sassign sKS/2 ->7
19e169bf 42# 4 <2> add[t3] sK/2 ->5
724aa791 43# - <1> ex-rv2sv sK/1 ->3
44# 2 <#> gvsv[*b] s ->3
45# 3 <$> const[IV 42] s ->4
46# - <1> ex-rv2sv sKRM*/1 ->6
47# 5 <#> gvsv[*a] s ->6
48EOT_EOT
49# 7 <1> leavesub[1 ref] K/REFC,1 ->(end)
50# - <@> lineseq KP ->7
51# 1 <;> nextstate(main 60 optree_concise.t:122) v ->2
52# 6 <2> sassign sKS/2 ->7
53# 4 <2> add[t1] sK/2 ->5
54# - <1> ex-rv2sv sK/1 ->3
55# 2 <$> gvsv(*b) s ->3
56# 3 <$> const(IV 42) s ->4
57# - <1> ex-rv2sv sKRM*/1 ->6
58# 5 <$> gvsv(*a) s ->6
59EONT_EONT
60
61checkOptree ( name => 'canonical example w -exec',
62 bcopts => '-exec',
63 code => sub{$a=$b+42},
64 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
724aa791 65# 1 <;> nextstate(main 61 optree_concise.t:139) v
66# 2 <#> gvsv[*b] s
67# 3 <$> const[IV 42] s
68# 4 <2> add[t3] sK/2
69# 5 <#> gvsv[*a] s
70# 6 <2> sassign sKS/2
71# 7 <1> leavesub[1 ref] K/REFC,1
72EOT_EOT
724aa791 73# 1 <;> nextstate(main 61 optree_concise.t:139) v
74# 2 <$> gvsv(*b) s
75# 3 <$> const(IV 42) s
76# 4 <2> add[t1] sK/2
77# 5 <$> gvsv(*a) s
78# 6 <2> sassign sKS/2
79# 7 <1> leavesub[1 ref] K/REFC,1
80EONT_EONT
81
724aa791 82#################################
83pass("B::Concise OPTION TESTS");
84
85checkOptree ( name => '-base3 sticky-exec',
86 bcopts => '-base3',
87 code => sub{$a=$b+42},
88 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
724aa791 891 <;> dbstate(main 24 optree_concise.t:132) v
902 <#> gvsv[*b] s
9110 <$> const[IV 42] s
9211 <2> add[t3] sK/2
9312 <#> gvsv[*a] s
9420 <2> sassign sKS/2
cc02ea56 9521 <1> leavesub[1 ref] K/REFC,1
724aa791 96EOT_EOT
724aa791 97# 1 <;> nextstate(main 62 optree_concise.t:161) v
98# 2 <$> gvsv(*b) s
99# 10 <$> const(IV 42) s
100# 11 <2> add[t1] sK/2
101# 12 <$> gvsv(*a) s
102# 20 <2> sassign sKS/2
103# 21 <1> leavesub[1 ref] K/REFC,1
104EONT_EONT
105
106checkOptree ( name => 'sticky-base3, -basic over sticky-exec',
107 bcopts => '-basic',
108 code => sub{$a=$b+42},
109 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
11021 <1> leavesub[1 ref] K/REFC,1 ->(end)
111- <@> lineseq KP ->21
1121 <;> nextstate(main 32 optree_concise.t:164) v ->2
11320 <2> sassign sKS/2 ->21
11411 <2> add[t3] sK/2 ->12
115- <1> ex-rv2sv sK/1 ->10
1162 <#> gvsv[*b] s ->10
11710 <$> const[IV 42] s ->11
118- <1> ex-rv2sv sKRM*/1 ->20
11912 <#> gvsv[*a] s ->20
120EOT_EOT
121# 21 <1> leavesub[1 ref] K/REFC,1 ->(end)
122# - <@> lineseq KP ->21
123# 1 <;> nextstate(main 63 optree_concise.t:186) v ->2
124# 20 <2> sassign sKS/2 ->21
125# 11 <2> add[t1] sK/2 ->12
126# - <1> ex-rv2sv sK/1 ->10
127# 2 <$> gvsv(*b) s ->10
128# 10 <$> const(IV 42) s ->11
129# - <1> ex-rv2sv sKRM*/1 ->20
130# 12 <$> gvsv(*a) s ->20
131EONT_EONT
132
133checkOptree ( name => '-base4',
134 bcopts => [qw/ -basic -base4 /],
135 code => sub{$a=$b+42},
136 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
13713 <1> leavesub[1 ref] K/REFC,1 ->(end)
138- <@> lineseq KP ->13
1391 <;> nextstate(main 26 optree_concise.t:145) v ->2
14012 <2> sassign sKS/2 ->13
14110 <2> add[t3] sK/2 ->11
142- <1> ex-rv2sv sK/1 ->3
1432 <#> gvsv[*b] s ->3
1443 <$> const[IV 42] s ->10
145- <1> ex-rv2sv sKRM*/1 ->12
14611 <#> gvsv[*a] s ->12
147EOT_EOT
148# 13 <1> leavesub[1 ref] K/REFC,1 ->(end)
149# - <@> lineseq KP ->13
150# 1 <;> nextstate(main 64 optree_concise.t:193) v ->2
151# 12 <2> sassign sKS/2 ->13
152# 10 <2> add[t1] sK/2 ->11
153# - <1> ex-rv2sv sK/1 ->3
154# 2 <$> gvsv(*b) s ->3
155# 3 <$> const(IV 42) s ->10
156# - <1> ex-rv2sv sKRM*/1 ->12
157# 11 <$> gvsv(*a) s ->12
158EONT_EONT
159
160checkOptree ( name => "restore -base36 default",
161 bcopts => [qw/ -basic -base36 /],
162 code => sub{$a},
163 crossfail => 1,
164 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
1653 <1> leavesub[1 ref] K/REFC,1 ->(end)
166- <@> lineseq KP ->3
1671 <;> nextstate(main 27 optree_concise.t:161) v ->2
168- <1> ex-rv2sv sK/1 ->-
1692 <#> gvsv[*a] s ->3
170EOT_EOT
171# 3 <1> leavesub[1 ref] K/REFC,1 ->(end)
172# - <@> lineseq KP ->3
173# 1 <;> nextstate(main 65 optree_concise.t:210) v ->2
174# - <1> ex-rv2sv sK/1 ->-
175# 2 <$> gvsv(*a) s ->3
176EONT_EONT
177
178checkOptree ( name => "terse basic",
179 bcopts => [qw/ -basic -terse /],
180 code => sub{$a},
181 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
182UNOP (0x82b0918) leavesub [1]
183 LISTOP (0x82b08d8) lineseq
184 COP (0x82b0880) nextstate
185 UNOP (0x82b0860) null [15]
186 PADOP (0x82b0840) gvsv GV (0x82a818c) *a
187EOT_EOT
188# UNOP (0x8282310) leavesub [1]
189# LISTOP (0x82822f0) lineseq
190# COP (0x82822b8) nextstate
191# UNOP (0x812fc20) null [15]
192# SVOP (0x812fc00) gvsv GV (0x814692c) *a
193EONT_EONT
194
195checkOptree ( name => "sticky-terse exec",
196 bcopts => [qw/ -exec /],
197 code => sub{$a},
198 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
724aa791 199COP (0x82b0d70) nextstate
200PADOP (0x82b0d30) gvsv GV (0x82a818c) *a
201UNOP (0x82b0e08) leavesub [1]
202EOT_EOT
724aa791 203# COP (0x82828e0) nextstate
204# SVOP (0x82828a0) gvsv GV (0x814692c) *a
205# UNOP (0x8282938) leavesub [1]
206EONT_EONT
207
208pass("OPTIONS IN CMDLINE MODE");
209
19e169bf 210checkOptree ( name => 'cmdline invoke -basic works',
211 prog => 'sort @a',
212 errs => [ 'Useless use of sort in void context at -e line 1.',
213 'Name "main::a" used only once: possible typo at -e line 1.',
214 ],
724aa791 215 #bcopts => '-basic', # default
216 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
217# 7 <@> leave[1 ref] vKP/REFC ->(end)
218# 1 <0> enter ->2
219# 2 <;> nextstate(main 1 -e:1) v ->3
220# 6 <@> sort vK ->7
221# 3 <0> pushmark s ->4
222# 5 <1> rv2av[t2] lK/1 ->6
223# 4 <#> gv[*a] s ->5
224EOT_EOT
225# 7 <@> leave[1 ref] vKP/REFC ->(end)
226# 1 <0> enter ->2
227# 2 <;> nextstate(main 1 -e:1) v ->3
228# 6 <@> sort vK ->7
229# 3 <0> pushmark s ->4
230# 5 <1> rv2av[t1] lK/1 ->6
231# 4 <$> gv(*a) s ->5
232EONT_EONT
233
19e169bf 234checkOptree ( name => 'cmdline invoke -exec works',
235 prog => 'sort @a',
236 errs => [ 'Useless use of sort in void context at -e line 1.',
237 'Name "main::a" used only once: possible typo at -e line 1.',
238 ],
239 bcopts => '-exec',
240 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
724aa791 2411 <0> enter
2422 <;> nextstate(main 1 -e:1) v
2433 <0> pushmark s
2444 <#> gv[*a] s
2455 <1> rv2av[t2] lK/1
2466 <@> sort vK
2477 <@> leave[1 ref] vKP/REFC
248EOT_EOT
249# 1 <0> enter
250# 2 <;> nextstate(main 1 -e:1) v
251# 3 <0> pushmark s
252# 4 <$> gv(*a) s
253# 5 <1> rv2av[t1] lK/1
254# 6 <@> sort vK
255# 7 <@> leave[1 ref] vKP/REFC
256EONT_EONT
257
5e251bf1 258;
19e169bf 259
5e251bf1 260checkOptree
261 ( name => 'cmdline self-strict compile err using prog',
262 prog => 'use strict; sort @a',
263 bcopts => [qw/ -basic -concise -exec /],
19e169bf 264 errs => 'Global symbol "@a" requires explicit package name at -e line 1.',
265 expect => 'nextstate',
266 expect_nt => 'nextstate',
267 noanchors => 1, # allow simple expectations to work
5e251bf1 268 );
724aa791 269
5e251bf1 270checkOptree
271 ( name => 'cmdline self-strict compile err using code',
272 code => 'use strict; sort @a',
273 bcopts => [qw/ -basic -concise -exec /],
5e251bf1 274 errs => 'Global symbol "@a" requires explicit package name at .*? line 1.',
19e169bf 275 note => 'this test relys on a kludge which copies $@ to rendering when empty',
276 expect => 'Global symbol',
277 expect_nt => 'Global symbol',
278 noanchors => 1, # allow simple expectations to work
5e251bf1 279 );
280
281checkOptree
282 ( name => 'cmdline -basic -concise -exec works',
283 prog => 'our @a; sort @a',
284 bcopts => [qw/ -basic -concise -exec /],
19e169bf 285 errs => ['Useless use of sort in void context at -e line 1.'],
5e251bf1 286 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
724aa791 287# 1 <0> enter
288# 2 <;> nextstate(main 1 -e:1) v
289# 3 <#> gv[*a] s
290# 4 <1> rv2av[t3] vK/OURINTR,1
291# 5 <;> nextstate(main 2 -e:1) v
292# 6 <0> pushmark s
293# 7 <#> gv[*a] s
294# 8 <1> rv2av[t5] lK/1
295# 9 <@> sort vK
296# a <@> leave[1 ref] vKP/REFC
297EOT_EOT
298# 1 <0> enter
299# 2 <;> nextstate(main 1 -e:1) v
300# 3 <$> gv(*a) s
301# 4 <1> rv2av[t2] vK/OURINTR,1
302# 5 <;> nextstate(main 2 -e:1) v
303# 6 <0> pushmark s
304# 7 <$> gv(*a) s
305# 8 <1> rv2av[t3] lK/1
306# 9 <@> sort vK
307# a <@> leave[1 ref] vKP/REFC
308EONT_EONT
309
310
311#################################
312pass("B::Concise STYLE/CALLBACK TESTS");
313
314use B::Concise qw( walk_output add_style set_style_standard add_callback );
315
316# new relative style, added by set_up_relative_test()
317@stylespec =
318 ( "#hyphseq2 (*( (x( ;)x))*)<#classsym> "
319 . "#exname#arg(?([#targarglife])?)~#flags(?(/#privateb)?)(x(;~->#next)x) "
320 . "(x(;~=> #extra)x)\n" # new 'variable' used here
321
322 , " (*( )*) goto #seq\n"
cc02ea56 323 , "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"
724aa791 324 #. "(x(;~=> #extra)x)\n" # new 'variable' used here
325 );
326
327sub set_up_relative_test {
328 # add a new style, and a callback which adds an 'extra' property
329
330 add_style ( "relative" => @stylespec );
331 #set_style_standard ( "relative" );
332
333 add_callback
334 ( sub {
335 my ($h, $op, $format, $level, $style) = @_;
336
337 # callback marks up const ops
338 $h->{arg} .= ' CALLBACK' if $h->{name} eq 'const';
339 $h->{extra} = '';
340
cc02ea56 341 if ($lastnext and $$lastnext != $$op) {
342 $h->{goto} = ($h->{seq} eq '-')
343 ? 'unresolved' : $h->{seq};
344 }
345
724aa791 346 # 2 style specific behaviors
347 if ($style eq 'relative') {
348 $h->{extra} = 'RELATIVE';
349 $h->{arg} .= ' RELATIVE' if $h->{name} eq 'leavesub';
350 }
351 elsif ($style eq 'scope') {
352 # supress printout entirely
353 $$format="" unless grep { $h->{name} eq $_ } @scopeops;
354 }
355 });
356}
357
358#################################
359set_up_relative_test();
360pass("set_up_relative_test, new callback installed");
361
362checkOptree ( name => 'callback used, independent of style',
363 bcopts => [qw/ -concise -exec /],
364 code => sub{$a=$b+42},
365 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
724aa791 3661 <;> nextstate(main 76 optree_concise.t:337) v
3672 <#> gvsv[*b] s
3683 <$> const[IV 42] CALLBACK s
3694 <2> add[t3] sK/2
3705 <#> gvsv[*a] s
3716 <2> sassign sKS/2
3727 <1> leavesub[1 ref] K/REFC,1
373EOT_EOT
374# 1 <;> nextstate(main 455 optree_concise.t:328) v
375# 2 <$> gvsv(*b) s
376# 3 <$> const(IV 42) CALLBACK s
377# 4 <2> add[t1] sK/2
378# 5 <$> gvsv(*a) s
379# 6 <2> sassign sKS/2
380# 7 <1> leavesub[1 ref] K/REFC,1
381EONT_EONT
382
383checkOptree ( name => "new 'relative' style, -exec mode",
384 bcopts => [qw/ -basic -relative /],
385 code => sub{$a=$b+42},
386 crossfail => 1,
387 #retry => 1,
388 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
cc02ea56 3897 <1> leavesub RELATIVE[1 ref] K ->(end) => RELATIVE
390- <@> lineseq KP ->7 => RELATIVE
3911 <;> nextstate(main 49 optree_concise.t:309) v ->2 => RELATIVE
3926 <2> sassign sKS ->7 => RELATIVE
3934 <2> add[t3] sK ->5 => RELATIVE
394- <1> ex-rv2sv sK ->3 => RELATIVE
3952 <#> gvsv[*b] s ->3 => RELATIVE
3963 <$> const[IV 42] CALLBACK s ->4 => RELATIVE
397- <1> ex-rv2sv sKRM* ->6 => RELATIVE
3985 <#> gvsv[*a] s ->6 => RELATIVE
724aa791 399EOT_EOT
cc02ea56 400# 7 <1> leavesub RELATIVE[1 ref] K ->(end) => RELATIVE
401# - <@> lineseq KP ->7 => RELATIVE
402# 1 <;> nextstate(main 77 optree_concise.t:353) v ->2 => RELATIVE
403# 6 <2> sassign sKS ->7 => RELATIVE
404# 4 <2> add[t1] sK ->5 => RELATIVE
405# - <1> ex-rv2sv sK ->3 => RELATIVE
406# 2 <$> gvsv(*b) s ->3 => RELATIVE
407# 3 <$> const(IV 42) CALLBACK s ->4 => RELATIVE
408# - <1> ex-rv2sv sKRM* ->6 => RELATIVE
409# 5 <$> gvsv(*a) s ->6 => RELATIVE
724aa791 410EONT_EONT
411
412checkOptree ( name => "both -exec -relative",
413 bcopts => [qw/ -exec -relative /],
414 code => sub{$a=$b+42},
415 crossfail => 1,
416 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
724aa791 4171 <;> nextstate(main 50 optree_concise.t:326) v
4182 <#> gvsv[*b] s
4193 <$> const[IV 42] CALLBACK s
4204 <2> add[t3] sK
4215 <#> gvsv[*a] s
4226 <2> sassign sKS
4237 <1> leavesub RELATIVE[1 ref] K
424EOT_EOT
425# 1 <;> nextstate(main 78 optree_concise.t:371) v
426# 2 <$> gvsv(*b) s
427# 3 <$> const(IV 42) CALLBACK s
428# 4 <2> add[t1] sK
429# 5 <$> gvsv(*a) s
430# 6 <2> sassign sKS
431# 7 <1> leavesub RELATIVE[1 ref] K
432EONT_EONT
433
434#################################
435
436@scopeops = qw( leavesub enter leave nextstate );
437add_style
438 ( 'scope' # concise copy
439 , "#hyphseq2 (*( (x( ;)x))*)<#classsym> "
440 . "#exname#arg(?([#targarglife])?)~#flags(?(/#private)?)(x(;~->#next)x) "
441 , " (*( )*) goto #seq\n"
442 , "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"
443 );
444
445checkOptree ( name => "both -exec -scope",
446 bcopts => [qw/ -exec -scope /],
447 code => sub{$a=$b+42},
448 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
724aa791 4491 <;> nextstate(main 50 optree_concise.t:337) v
4507 <1> leavesub[1 ref] K/REFC,1
451EOT_EOT
724aa791 4521 <;> nextstate(main 75 optree_concise.t:396) v
4537 <1> leavesub[1 ref] K/REFC,1
454EONT_EONT
455
456
457checkOptree ( name => "both -basic -scope",
458 bcopts => [qw/ -basic -scope /],
459 code => sub{$a=$b+42},
460 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
4617 <1> leavesub[1 ref] K/REFC,1 ->(end)
4621 <;> nextstate(main 51 optree_concise.t:347) v ->2
463EOT_EOT
4647 <1> leavesub[1 ref] K/REFC,1 ->(end)
4651 <;> nextstate(main 76 optree_concise.t:407) v ->2
466EONT_EONT
467
2ce64696 468} #skip
724aa791 469