6 @INC = ('.', '../lib', '../ext/B/t');
12 if (($Config::Config{'extensions'} !~ /\bB\b/) ){
13 print "1..0 # Skip -- Perl configured without B module\n";
16 # require 'test.pl'; # now done by OptreeCheck
19 # import checkOptree(), and %gOpts (containing test state)
20 use OptreeCheck; # ALSO DOES @ARGV HANDLING !!!!!!
26 skip "no perlio in this build", $tests unless $Config::Config{useperlio};
28 $SIG{__WARN__} = sub {
30 $err =~ m/Subroutine re::(un)?install redefined/ and return;
32 #################################
33 pass("CANONICAL B::Concise EXAMPLE");
35 checkOptree ( name => 'canonical example w -basic',
37 code => sub{$a=$b+42},
38 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
39 # 7 <1> leavesub[1 ref] K/REFC,1 ->(end)
40 # - <@> lineseq KP ->7
41 # 1 <;> nextstate(foo bar) v ->2
42 # 6 <2> sassign sKS/2 ->7
43 # 4 <2> add[t3] sK/2 ->5
44 # - <1> ex-rv2sv sK/1 ->3
45 # 2 <#> gvsv[*b] s ->3
46 # 3 <$> const[IV 42] s ->4
47 # - <1> ex-rv2sv sKRM*/1 ->6
48 # 5 <#> gvsv[*a] s ->6
50 # 7 <1> leavesub[1 ref] K/REFC,1 ->(end)
51 # - <@> lineseq KP ->7
52 # 1 <;> nextstate(main 60 optree_concise.t:122) v ->2
53 # 6 <2> sassign sKS/2 ->7
54 # 4 <2> add[t1] sK/2 ->5
55 # - <1> ex-rv2sv sK/1 ->3
56 # 2 <$> gvsv(*b) s ->3
57 # 3 <$> const(IV 42) s ->4
58 # - <1> ex-rv2sv sKRM*/1 ->6
59 # 5 <$> gvsv(*a) s ->6
62 checkOptree ( name => 'canonical example w -exec',
64 code => sub{$a=$b+42},
65 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
66 # 1 <;> nextstate(main 61 optree_concise.t:139) v
68 # 3 <$> const[IV 42] s
72 # 7 <1> leavesub[1 ref] K/REFC,1
74 # 1 <;> nextstate(main 61 optree_concise.t:139) v
76 # 3 <$> const(IV 42) s
80 # 7 <1> leavesub[1 ref] K/REFC,1
83 #################################
84 pass("B::Concise OPTION TESTS");
86 checkOptree ( name => '-base3 sticky-exec',
88 code => sub{$a=$b+42},
89 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
90 1 <;> dbstate(main 24 optree_concise.t:132) v
96 21 <1> leavesub[1 ref] K/REFC,1
98 # 1 <;> nextstate(main 62 optree_concise.t:161) v
100 # 10 <$> const(IV 42) s
101 # 11 <2> add[t1] sK/2
103 # 20 <2> sassign sKS/2
104 # 21 <1> leavesub[1 ref] K/REFC,1
107 checkOptree ( name => 'sticky-base3, -basic over sticky-exec',
109 code => sub{$a=$b+42},
110 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
111 21 <1> leavesub[1 ref] K/REFC,1 ->(end)
112 - <@> lineseq KP ->21
113 1 <;> nextstate(main 32 optree_concise.t:164) v ->2
114 20 <2> sassign sKS/2 ->21
115 11 <2> add[t3] sK/2 ->12
116 - <1> ex-rv2sv sK/1 ->10
117 2 <#> gvsv[*b] s ->10
118 10 <$> const[IV 42] s ->11
119 - <1> ex-rv2sv sKRM*/1 ->20
120 12 <#> gvsv[*a] s ->20
122 # 21 <1> leavesub[1 ref] K/REFC,1 ->(end)
123 # - <@> lineseq KP ->21
124 # 1 <;> nextstate(main 63 optree_concise.t:186) v ->2
125 # 20 <2> sassign sKS/2 ->21
126 # 11 <2> add[t1] sK/2 ->12
127 # - <1> ex-rv2sv sK/1 ->10
128 # 2 <$> gvsv(*b) s ->10
129 # 10 <$> const(IV 42) s ->11
130 # - <1> ex-rv2sv sKRM*/1 ->20
131 # 12 <$> gvsv(*a) s ->20
134 checkOptree ( name => '-base4',
135 bcopts => [qw/ -basic -base4 /],
136 code => sub{$a=$b+42},
137 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
138 13 <1> leavesub[1 ref] K/REFC,1 ->(end)
139 - <@> lineseq KP ->13
140 1 <;> nextstate(main 26 optree_concise.t:145) v ->2
141 12 <2> sassign sKS/2 ->13
142 10 <2> add[t3] sK/2 ->11
143 - <1> ex-rv2sv sK/1 ->3
145 3 <$> const[IV 42] s ->10
146 - <1> ex-rv2sv sKRM*/1 ->12
147 11 <#> gvsv[*a] s ->12
149 # 13 <1> leavesub[1 ref] K/REFC,1 ->(end)
150 # - <@> lineseq KP ->13
151 # 1 <;> nextstate(main 64 optree_concise.t:193) v ->2
152 # 12 <2> sassign sKS/2 ->13
153 # 10 <2> add[t1] sK/2 ->11
154 # - <1> ex-rv2sv sK/1 ->3
155 # 2 <$> gvsv(*b) s ->3
156 # 3 <$> const(IV 42) s ->10
157 # - <1> ex-rv2sv sKRM*/1 ->12
158 # 11 <$> gvsv(*a) s ->12
161 checkOptree ( name => "restore -base36 default",
162 bcopts => [qw/ -basic -base36 /],
165 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
166 3 <1> leavesub[1 ref] K/REFC,1 ->(end)
168 1 <;> nextstate(main 27 optree_concise.t:161) v ->2
169 - <1> ex-rv2sv sK/1 ->-
172 # 3 <1> leavesub[1 ref] K/REFC,1 ->(end)
173 # - <@> lineseq KP ->3
174 # 1 <;> nextstate(main 65 optree_concise.t:210) v ->2
175 # - <1> ex-rv2sv sK/1 ->-
176 # 2 <$> gvsv(*a) s ->3
179 checkOptree ( name => "terse basic",
180 bcopts => [qw/ -basic -terse /],
182 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
183 UNOP (0x82b0918) leavesub [1]
184 LISTOP (0x82b08d8) lineseq
185 COP (0x82b0880) nextstate
186 UNOP (0x82b0860) null [15]
187 PADOP (0x82b0840) gvsv GV (0x82a818c) *a
189 # UNOP (0x8282310) leavesub [1]
190 # LISTOP (0x82822f0) lineseq
191 # COP (0x82822b8) nextstate
192 # UNOP (0x812fc20) null [15]
193 # SVOP (0x812fc00) gvsv GV (0x814692c) *a
196 checkOptree ( name => "sticky-terse exec",
197 bcopts => [qw/ -exec /],
199 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
200 COP (0x82b0d70) nextstate
201 PADOP (0x82b0d30) gvsv GV (0x82a818c) *a
202 UNOP (0x82b0e08) leavesub [1]
204 # COP (0x82828e0) nextstate
205 # SVOP (0x82828a0) gvsv GV (0x814692c) *a
206 # UNOP (0x8282938) leavesub [1]
209 pass("OPTIONS IN CMDLINE MODE");
211 checkOptree ( name => 'cmdline invoke -basic works',
213 errs => [ 'Useless use of sort in void context at -e line 1.',
214 'Name "main::a" used only once: possible typo at -e line 1.',
216 #bcopts => '-basic', # default
217 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
218 # 7 <@> leave[1 ref] vKP/REFC ->(end)
220 # 2 <;> nextstate(main 1 -e:1) v ->3
222 # 3 <0> pushmark s ->4
223 # 5 <1> rv2av[t2] lK/1 ->6
226 # 7 <@> leave[1 ref] vKP/REFC ->(end)
228 # 2 <;> nextstate(main 1 -e:1) v ->3
230 # 3 <0> pushmark s ->4
231 # 5 <1> rv2av[t1] lK/1 ->6
235 checkOptree ( name => 'cmdline invoke -exec works',
237 errs => [ 'Useless use of sort in void context at -e line 1.',
238 'Name "main::a" used only once: possible typo at -e line 1.',
241 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
243 2 <;> nextstate(main 1 -e:1) v
248 7 <@> leave[1 ref] vKP/REFC
251 # 2 <;> nextstate(main 1 -e:1) v
254 # 5 <1> rv2av[t1] lK/1
256 # 7 <@> leave[1 ref] vKP/REFC
262 ( name => 'cmdline self-strict compile err using prog',
263 prog => 'use strict; sort @a',
264 bcopts => [qw/ -basic -concise -exec /],
265 errs => 'Global symbol "@a" requires explicit package name at -e line 1.',
266 expect => 'nextstate',
267 expect_nt => 'nextstate',
268 noanchors => 1, # allow simple expectations to work
272 ( name => 'cmdline self-strict compile err using code',
273 code => 'use strict; sort @a',
274 bcopts => [qw/ -basic -concise -exec /],
275 errs => 'Global symbol "@a" requires explicit package name at .*? line 1.',
276 note => 'this test relys on a kludge which copies $@ to rendering when empty',
277 expect => 'Global symbol',
278 expect_nt => 'Global symbol',
279 noanchors => 1, # allow simple expectations to work
283 ( name => 'cmdline -basic -concise -exec works',
284 prog => 'our @a; sort @a',
285 bcopts => [qw/ -basic -concise -exec /],
286 errs => ['Useless use of sort in void context at -e line 1.'],
287 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
289 # 2 <;> nextstate(main 1 -e:1) v
291 # 4 <1> rv2av[t3] vK/OURINTR,1
292 # 5 <;> nextstate(main 2 -e:1) v
295 # 8 <1> rv2av[t5] lK/1
297 # a <@> leave[1 ref] vKP/REFC
300 # 2 <;> nextstate(main 1 -e:1) v
302 # 4 <1> rv2av[t2] vK/OURINTR,1
303 # 5 <;> nextstate(main 2 -e:1) v
306 # 8 <1> rv2av[t3] lK/1
308 # a <@> leave[1 ref] vKP/REFC
312 #################################
313 pass("B::Concise STYLE/CALLBACK TESTS");
315 use B::Concise qw( walk_output add_style set_style_standard add_callback );
317 # new relative style, added by set_up_relative_test()
319 ( "#hyphseq2 (*( (x( ;)x))*)<#classsym> "
320 . "#exname#arg(?([#targarglife])?)~#flags(?(/#privateb)?)(x(;~->#next)x) "
321 . "(x(;~=> #extra)x)\n" # new 'variable' used here
323 , " (*( )*) goto #seq\n"
324 , "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"
325 #. "(x(;~=> #extra)x)\n" # new 'variable' used here
328 sub set_up_relative_test {
329 # add a new style, and a callback which adds an 'extra' property
331 add_style ( "relative" => @stylespec );
332 #set_style_standard ( "relative" );
336 my ($h, $op, $format, $level, $style) = @_;
338 # callback marks up const ops
339 $h->{arg} .= ' CALLBACK' if $h->{name} eq 'const';
342 if ($lastnext and $$lastnext != $$op) {
343 $h->{goto} = ($h->{seq} eq '-')
344 ? 'unresolved' : $h->{seq};
347 # 2 style specific behaviors
348 if ($style eq 'relative') {
349 $h->{extra} = 'RELATIVE';
350 $h->{arg} .= ' RELATIVE' if $h->{name} eq 'leavesub';
352 elsif ($style eq 'scope') {
353 # supress printout entirely
354 $$format="" unless grep { $h->{name} eq $_ } @scopeops;
359 #################################
360 set_up_relative_test();
361 pass("set_up_relative_test, new callback installed");
363 checkOptree ( name => 'callback used, independent of style',
364 bcopts => [qw/ -concise -exec /],
365 code => sub{$a=$b+42},
366 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
367 1 <;> nextstate(main 76 optree_concise.t:337) v
369 3 <$> const[IV 42] CALLBACK s
373 7 <1> leavesub[1 ref] K/REFC,1
375 # 1 <;> nextstate(main 455 optree_concise.t:328) v
377 # 3 <$> const(IV 42) CALLBACK s
380 # 6 <2> sassign sKS/2
381 # 7 <1> leavesub[1 ref] K/REFC,1
384 checkOptree ( name => "new 'relative' style, -exec mode",
385 bcopts => [qw/ -basic -relative /],
386 code => sub{$a=$b+42},
389 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
390 7 <1> leavesub RELATIVE[1 ref] K ->(end) => RELATIVE
391 - <@> lineseq KP ->7 => RELATIVE
392 1 <;> nextstate(main 49 optree_concise.t:309) v ->2 => RELATIVE
393 6 <2> sassign sKS ->7 => RELATIVE
394 4 <2> add[t3] sK ->5 => RELATIVE
395 - <1> ex-rv2sv sK ->3 => RELATIVE
396 2 <#> gvsv[*b] s ->3 => RELATIVE
397 3 <$> const[IV 42] CALLBACK s ->4 => RELATIVE
398 - <1> ex-rv2sv sKRM* ->6 => RELATIVE
399 5 <#> gvsv[*a] s ->6 => RELATIVE
401 # 7 <1> leavesub RELATIVE[1 ref] K ->(end) => RELATIVE
402 # - <@> lineseq KP ->7 => RELATIVE
403 # 1 <;> nextstate(main 77 optree_concise.t:353) v ->2 => RELATIVE
404 # 6 <2> sassign sKS ->7 => RELATIVE
405 # 4 <2> add[t1] sK ->5 => RELATIVE
406 # - <1> ex-rv2sv sK ->3 => RELATIVE
407 # 2 <$> gvsv(*b) s ->3 => RELATIVE
408 # 3 <$> const(IV 42) CALLBACK s ->4 => RELATIVE
409 # - <1> ex-rv2sv sKRM* ->6 => RELATIVE
410 # 5 <$> gvsv(*a) s ->6 => RELATIVE
413 checkOptree ( name => "both -exec -relative",
414 bcopts => [qw/ -exec -relative /],
415 code => sub{$a=$b+42},
417 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
418 1 <;> nextstate(main 50 optree_concise.t:326) v
420 3 <$> const[IV 42] CALLBACK s
424 7 <1> leavesub RELATIVE[1 ref] K
426 # 1 <;> nextstate(main 78 optree_concise.t:371) v
428 # 3 <$> const(IV 42) CALLBACK s
432 # 7 <1> leavesub RELATIVE[1 ref] K
435 #################################
437 @scopeops = qw( leavesub enter leave nextstate );
439 ( 'scope' # concise copy
440 , "#hyphseq2 (*( (x( ;)x))*)<#classsym> "
441 . "#exname#arg(?([#targarglife])?)~#flags(?(/#private)?)(x(;~->#next)x) "
442 , " (*( )*) goto #seq\n"
443 , "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"
446 checkOptree ( name => "both -exec -scope",
447 bcopts => [qw/ -exec -scope /],
448 code => sub{$a=$b+42},
449 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
450 1 <;> nextstate(main 50 optree_concise.t:337) v
451 7 <1> leavesub[1 ref] K/REFC,1
453 1 <;> nextstate(main 75 optree_concise.t:396) v
454 7 <1> leavesub[1 ref] K/REFC,1
458 checkOptree ( name => "both -basic -scope",
459 bcopts => [qw/ -basic -scope /],
460 code => sub{$a=$b+42},
461 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
462 7 <1> leavesub[1 ref] K/REFC,1 ->(end)
463 1 <;> nextstate(main 51 optree_concise.t:347) v ->2
465 7 <1> leavesub[1 ref] K/REFC,1 ->(end)
466 1 <;> nextstate(main 76 optree_concise.t:407) v ->2