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 strip_open_hints => 1,
39 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
40 # 7 <1> leavesub[1 ref] K/REFC,1 ->(end)
41 # - <@> lineseq KP ->7
42 # 1 <;> nextstate(foo bar) v:>,<,%,{ ->2
43 # 6 <2> sassign sKS/2 ->7
44 # 4 <2> add[t3] sK/2 ->5
45 # - <1> ex-rv2sv sK/1 ->3
46 # 2 <#> gvsv[*b] s ->3
47 # 3 <$> const[IV 42] s ->4
48 # - <1> ex-rv2sv sKRM*/1 ->6
49 # 5 <#> gvsv[*a] s ->6
51 # 7 <1> leavesub[1 ref] K/REFC,1 ->(end)
52 # - <@> lineseq KP ->7
53 # 1 <;> nextstate(main 60 optree_concise.t:122) v:>,<,%,{ ->2
54 # 6 <2> sassign sKS/2 ->7
55 # 4 <2> add[t1] sK/2 ->5
56 # - <1> ex-rv2sv sK/1 ->3
57 # 2 <$> gvsv(*b) s ->3
58 # 3 <$> const(IV 42) s ->4
59 # - <1> ex-rv2sv sKRM*/1 ->6
60 # 5 <$> gvsv(*a) s ->6
63 checkOptree ( name => 'canonical example w -exec',
65 code => sub{$a=$b+42},
66 strip_open_hints => 1,
67 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
68 # 1 <;> nextstate(main 61 optree_concise.t:139) v:>,<,%,{
70 # 3 <$> const[IV 42] s
74 # 7 <1> leavesub[1 ref] K/REFC,1
76 # 1 <;> nextstate(main 61 optree_concise.t:139) v:>,<,%,{
78 # 3 <$> const(IV 42) s
82 # 7 <1> leavesub[1 ref] K/REFC,1
85 #################################
86 pass("B::Concise OPTION TESTS");
88 checkOptree ( name => '-base3 sticky-exec',
90 code => sub{$a=$b+42},
91 strip_open_hints => 1,
92 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
93 1 <;> dbstate(main 24 optree_concise.t:132) v:>,<,%,{
99 21 <1> leavesub[1 ref] K/REFC,1
101 # 1 <;> nextstate(main 62 optree_concise.t:161) v:>,<,%,{
103 # 10 <$> const(IV 42) s
104 # 11 <2> add[t1] sK/2
106 # 20 <2> sassign sKS/2
107 # 21 <1> leavesub[1 ref] K/REFC,1
110 checkOptree ( name => 'sticky-base3, -basic over sticky-exec',
112 code => sub{$a=$b+42},
113 strip_open_hints => 1,
114 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
115 21 <1> leavesub[1 ref] K/REFC,1 ->(end)
116 - <@> lineseq KP ->21
117 1 <;> nextstate(main 32 optree_concise.t:164) v:>,<,%,{ ->2
118 20 <2> sassign sKS/2 ->21
119 11 <2> add[t3] sK/2 ->12
120 - <1> ex-rv2sv sK/1 ->10
121 2 <#> gvsv[*b] s ->10
122 10 <$> const[IV 42] s ->11
123 - <1> ex-rv2sv sKRM*/1 ->20
124 12 <#> gvsv[*a] s ->20
126 # 21 <1> leavesub[1 ref] K/REFC,1 ->(end)
127 # - <@> lineseq KP ->21
128 # 1 <;> nextstate(main 63 optree_concise.t:186) v:>,<,%,{ ->2
129 # 20 <2> sassign sKS/2 ->21
130 # 11 <2> add[t1] sK/2 ->12
131 # - <1> ex-rv2sv sK/1 ->10
132 # 2 <$> gvsv(*b) s ->10
133 # 10 <$> const(IV 42) s ->11
134 # - <1> ex-rv2sv sKRM*/1 ->20
135 # 12 <$> gvsv(*a) s ->20
138 checkOptree ( name => '-base4',
139 bcopts => [qw/ -basic -base4 /],
140 code => sub{$a=$b+42},
141 strip_open_hints => 1,
142 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
143 13 <1> leavesub[1 ref] K/REFC,1 ->(end)
144 - <@> lineseq KP ->13
145 1 <;> nextstate(main 26 optree_concise.t:145) v:>,<,%,{ ->2
146 12 <2> sassign sKS/2 ->13
147 10 <2> add[t3] sK/2 ->11
148 - <1> ex-rv2sv sK/1 ->3
150 3 <$> const[IV 42] s ->10
151 - <1> ex-rv2sv sKRM*/1 ->12
152 11 <#> gvsv[*a] s ->12
154 # 13 <1> leavesub[1 ref] K/REFC,1 ->(end)
155 # - <@> lineseq KP ->13
156 # 1 <;> nextstate(main 64 optree_concise.t:193) v:>,<,%,{ ->2
157 # 12 <2> sassign sKS/2 ->13
158 # 10 <2> add[t1] sK/2 ->11
159 # - <1> ex-rv2sv sK/1 ->3
160 # 2 <$> gvsv(*b) s ->3
161 # 3 <$> const(IV 42) s ->10
162 # - <1> ex-rv2sv sKRM*/1 ->12
163 # 11 <$> gvsv(*a) s ->12
166 checkOptree ( name => "restore -base36 default",
167 bcopts => [qw/ -basic -base36 /],
170 strip_open_hints => 1,
171 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
172 3 <1> leavesub[1 ref] K/REFC,1 ->(end)
174 1 <;> nextstate(main 27 optree_concise.t:161) v:>,<,% ->2
175 - <1> ex-rv2sv sK/1 ->-
178 # 3 <1> leavesub[1 ref] K/REFC,1 ->(end)
179 # - <@> lineseq KP ->3
180 # 1 <;> nextstate(main 65 optree_concise.t:210) v:>,<,% ->2
181 # - <1> ex-rv2sv sK/1 ->-
182 # 2 <$> gvsv(*a) s ->3
185 checkOptree ( name => "terse basic",
186 bcopts => [qw/ -basic -terse /],
188 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
189 UNOP (0x82b0918) leavesub [1]
190 LISTOP (0x82b08d8) lineseq
191 COP (0x82b0880) nextstate
192 UNOP (0x82b0860) null [15]
193 PADOP (0x82b0840) gvsv GV (0x82a818c) *a
195 # UNOP (0x8282310) leavesub [1]
196 # LISTOP (0x82822f0) lineseq
197 # COP (0x82822b8) nextstate
198 # UNOP (0x812fc20) null [15]
199 # SVOP (0x812fc00) gvsv GV (0x814692c) *a
202 checkOptree ( name => "sticky-terse exec",
203 bcopts => [qw/ -exec /],
205 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
206 COP (0x82b0d70) nextstate
207 PADOP (0x82b0d30) gvsv GV (0x82a818c) *a
208 UNOP (0x82b0e08) leavesub [1]
210 # COP (0x82828e0) nextstate
211 # SVOP (0x82828a0) gvsv GV (0x814692c) *a
212 # UNOP (0x8282938) leavesub [1]
215 pass("OPTIONS IN CMDLINE MODE");
217 checkOptree ( name => 'cmdline invoke -basic works',
219 errs => [ 'Useless use of sort in void context at -e line 1.',
220 'Name "main::a" used only once: possible typo at -e line 1.',
222 #bcopts => '-basic', # default
223 strip_open_hints => 1,
224 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
225 # 7 <@> leave[1 ref] vKP/REFC ->(end)
227 # 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ ->3
229 # 3 <0> pushmark s ->4
230 # 5 <1> rv2av[t2] lK/1 ->6
233 # 7 <@> leave[1 ref] vKP/REFC ->(end)
235 # 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ ->3
237 # 3 <0> pushmark s ->4
238 # 5 <1> rv2av[t1] lK/1 ->6
242 checkOptree ( name => 'cmdline invoke -exec works',
244 errs => [ 'Useless use of sort in void context at -e line 1.',
245 'Name "main::a" used only once: possible typo at -e line 1.',
248 strip_open_hints => 1,
249 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
251 2 <;> nextstate(main 1 -e:1) v:>,<,%,{
256 7 <@> leave[1 ref] vKP/REFC
259 # 2 <;> nextstate(main 1 -e:1) v:>,<,%,{
262 # 5 <1> rv2av[t1] lK/1
264 # 7 <@> leave[1 ref] vKP/REFC
270 ( name => 'cmdline self-strict compile err using prog',
271 prog => 'use strict; sort @a',
272 bcopts => [qw/ -basic -concise -exec /],
273 errs => 'Global symbol "@a" requires explicit package name at -e line 1.',
274 expect => 'nextstate',
275 expect_nt => 'nextstate',
276 noanchors => 1, # allow simple expectations to work
280 ( name => 'cmdline self-strict compile err using code',
281 code => 'use strict; sort @a',
282 bcopts => [qw/ -basic -concise -exec /],
283 errs => 'Global symbol "@a" requires explicit package name at .*? line 1.',
284 note => 'this test relys on a kludge which copies $@ to rendering when empty',
285 expect => 'Global symbol',
286 expect_nt => 'Global symbol',
287 noanchors => 1, # allow simple expectations to work
291 ( name => 'cmdline -basic -concise -exec works',
292 prog => 'our @a; sort @a',
293 bcopts => [qw/ -basic -concise -exec /],
294 errs => ['Useless use of sort in void context at -e line 1.'],
295 strip_open_hints => 1,
296 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
298 # 2 <;> nextstate(main 1 -e:1) v:>,<,%,{
300 # 4 <1> rv2av[t3] vK/OURINTR,1
301 # 5 <;> nextstate(main 2 -e:1) v:>,<,%,{
304 # 8 <1> rv2av[t5] lK/1
306 # a <@> leave[1 ref] vKP/REFC
309 # 2 <;> nextstate(main 1 -e:1) v:>,<,%,{
311 # 4 <1> rv2av[t2] vK/OURINTR,1
312 # 5 <;> nextstate(main 2 -e:1) v:>,<,%,{
315 # 8 <1> rv2av[t3] lK/1
317 # a <@> leave[1 ref] vKP/REFC
321 #################################
322 pass("B::Concise STYLE/CALLBACK TESTS");
324 use B::Concise qw( walk_output add_style set_style_standard add_callback );
326 # new relative style, added by set_up_relative_test()
328 ( "#hyphseq2 (*( (x( ;)x))*)<#classsym> "
329 . "#exname#arg(?([#targarglife])?)~#flags(?(/#privateb)?)(x(;~->#next)x) "
330 . "(x(;~=> #extra)x)\n" # new 'variable' used here
332 , " (*( )*) goto #seq\n"
333 , "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"
334 #. "(x(;~=> #extra)x)\n" # new 'variable' used here
337 sub set_up_relative_test {
338 # add a new style, and a callback which adds an 'extra' property
340 add_style ( "relative" => @stylespec );
341 #set_style_standard ( "relative" );
345 my ($h, $op, $format, $level, $style) = @_;
347 # callback marks up const ops
348 $h->{arg} .= ' CALLBACK' if $h->{name} eq 'const';
351 if ($lastnext and $$lastnext != $$op) {
352 $h->{goto} = ($h->{seq} eq '-')
353 ? 'unresolved' : $h->{seq};
356 # 2 style specific behaviors
357 if ($style eq 'relative') {
358 $h->{extra} = 'RELATIVE';
359 $h->{arg} .= ' RELATIVE' if $h->{name} eq 'leavesub';
361 elsif ($style eq 'scope') {
362 # supress printout entirely
363 $$format="" unless grep { $h->{name} eq $_ } @scopeops;
368 #################################
369 set_up_relative_test();
370 pass("set_up_relative_test, new callback installed");
372 checkOptree ( name => 'callback used, independent of style',
373 bcopts => [qw/ -concise -exec /],
374 code => sub{$a=$b+42},
375 strip_open_hints => 1,
376 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
377 1 <;> nextstate(main 76 optree_concise.t:337) v:>,<,%,{
379 3 <$> const[IV 42] CALLBACK s
383 7 <1> leavesub[1 ref] K/REFC,1
385 # 1 <;> nextstate(main 455 optree_concise.t:328) v:>,<,%,{
387 # 3 <$> const(IV 42) CALLBACK s
390 # 6 <2> sassign sKS/2
391 # 7 <1> leavesub[1 ref] K/REFC,1
394 checkOptree ( name => "new 'relative' style, -exec mode",
395 bcopts => [qw/ -basic -relative /],
396 code => sub{$a=$b+42},
399 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
400 7 <1> leavesub RELATIVE[1 ref] K ->(end) => RELATIVE
401 - <@> lineseq KP ->7 => RELATIVE
402 1 <;> nextstate(main 49 optree_concise.t:309) v ->2 => RELATIVE
403 6 <2> sassign sKS ->7 => RELATIVE
404 4 <2> add[t3] 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
411 # 7 <1> leavesub RELATIVE[1 ref] K ->(end) => RELATIVE
412 # - <@> lineseq KP ->7 => RELATIVE
413 # 1 <;> nextstate(main 77 optree_concise.t:353) v ->2 => RELATIVE
414 # 6 <2> sassign sKS ->7 => RELATIVE
415 # 4 <2> add[t1] sK ->5 => RELATIVE
416 # - <1> ex-rv2sv sK ->3 => RELATIVE
417 # 2 <$> gvsv(*b) s ->3 => RELATIVE
418 # 3 <$> const(IV 42) CALLBACK s ->4 => RELATIVE
419 # - <1> ex-rv2sv sKRM* ->6 => RELATIVE
420 # 5 <$> gvsv(*a) s ->6 => RELATIVE
423 checkOptree ( name => "both -exec -relative",
424 bcopts => [qw/ -exec -relative /],
425 code => sub{$a=$b+42},
427 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
428 1 <;> nextstate(main 50 optree_concise.t:326) v
430 3 <$> const[IV 42] CALLBACK s
434 7 <1> leavesub RELATIVE[1 ref] K
436 # 1 <;> nextstate(main 78 optree_concise.t:371) v
438 # 3 <$> const(IV 42) CALLBACK s
442 # 7 <1> leavesub RELATIVE[1 ref] K
445 #################################
447 @scopeops = qw( leavesub enter leave nextstate );
449 ( 'scope' # concise copy
450 , "#hyphseq2 (*( (x( ;)x))*)<#classsym> "
451 . "#exname#arg(?([#targarglife])?)~#flags(?(/#private)?)(x(;~->#next)x) "
452 , " (*( )*) goto #seq\n"
453 , "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"
456 checkOptree ( name => "both -exec -scope",
457 bcopts => [qw/ -exec -scope /],
458 code => sub{$a=$b+42},
459 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
460 1 <;> nextstate(main 50 optree_concise.t:337) v
461 7 <1> leavesub[1 ref] K/REFC,1
463 1 <;> nextstate(main 75 optree_concise.t:396) v
464 7 <1> leavesub[1 ref] K/REFC,1
468 checkOptree ( name => "both -basic -scope",
469 bcopts => [qw/ -basic -scope /],
470 code => sub{$a=$b+42},
471 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
472 7 <1> leavesub[1 ref] K/REFC,1 ->(end)
473 1 <;> nextstate(main 51 optree_concise.t:347) v ->2
475 7 <1> leavesub[1 ref] K/REFC,1 ->(end)
476 1 <;> nextstate(main 76 optree_concise.t:407) v ->2