This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[MERGE] fixup add+use si_cxsubix field
[perl5.git] / ext / B / t / optree_concise.t
1 #!perl
2
3 BEGIN {
4     unshift @INC, 't';
5     require Config;
6     if (($Config::Config{'extensions'} !~ /\bB\b/) ){
7         print "1..0 # Skip -- Perl configured without B module\n";
8         exit 0;
9     }
10     if (!$Config::Config{useperlio}) {
11         print "1..0 # Skip -- need perlio to walk the optree\n";
12         exit 0;
13     }
14 }
15
16 # import checkOptree(), and %gOpts (containing test state)
17 use OptreeCheck;        # ALSO DOES @ARGV HANDLING !!!!!!
18 use Config;
19
20 plan tests => 41;
21
22 $SIG{__WARN__} = sub {
23     my $err = shift;
24     $err =~ m/Subroutine re::(un)?install redefined/ and return;
25 };
26 #################################
27 pass("CANONICAL B::Concise EXAMPLE");
28
29 checkOptree ( name      => 'canonical example w -basic',
30               bcopts    => '-basic',
31               code      =>  sub{$a=$b+42},
32               strip_open_hints => 1,
33               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
34 # 7  <1> leavesub[1 ref] K/REFC,1 ->(end)
35 # -     <@> lineseq KP ->7
36 # 1        <;> nextstate(foo bar) v:>,<,%,{ ->2
37 # 6        <2> sassign sKS/2 ->7
38 # 4           <2> add[t3] sK/2 ->5
39 # -              <1> ex-rv2sv sK/1 ->3
40 # 2                 <#> gvsv[*b] s ->3
41 # 3              <$> const[IV 42] s ->4
42 # -           <1> ex-rv2sv sKRM*/1 ->6
43 # 5              <#> gvsv[*a] s ->6
44 EOT_EOT
45 # 7  <1> leavesub[1 ref] K/REFC,1 ->(end)
46 # -     <@> lineseq KP ->7
47 # 1        <;> nextstate(main 60 optree_concise.t:122) v:>,<,%,{ ->2
48 # 6        <2> sassign sKS/2 ->7
49 # 4           <2> add[t1] sK/2 ->5
50 # -              <1> ex-rv2sv sK/1 ->3
51 # 2                 <$> gvsv(*b) s ->3
52 # 3              <$> const(IV 42) s ->4
53 # -           <1> ex-rv2sv sKRM*/1 ->6
54 # 5              <$> gvsv(*a) s ->6
55 EONT_EONT
56
57 checkOptree ( name      => 'canonical example w -exec',
58               bcopts    => '-exec',
59               code      => sub{$a=$b+42},
60               strip_open_hints => 1,
61               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
62 # 1  <;> nextstate(main 61 optree_concise.t:139) v:>,<,%,{
63 # 2  <#> gvsv[*b] s
64 # 3  <$> const[IV 42] s
65 # 4  <2> add[t3] sK/2
66 # 5  <#> gvsv[*a] s
67 # 6  <2> sassign sKS/2
68 # 7  <1> leavesub[1 ref] K/REFC,1
69 EOT_EOT
70 # 1  <;> nextstate(main 61 optree_concise.t:139) v:>,<,%,{
71 # 2  <$> gvsv(*b) s
72 # 3  <$> const(IV 42) s
73 # 4  <2> add[t1] sK/2
74 # 5  <$> gvsv(*a) s
75 # 6  <2> sassign sKS/2
76 # 7  <1> leavesub[1 ref] K/REFC,1
77 EONT_EONT
78
79 #################################
80 pass("B::Concise OPTION TESTS");
81
82 checkOptree ( name      => '-base3 sticky-exec',
83               bcopts    => '-base3',
84               code      => sub{$a=$b+42},
85               strip_open_hints => 1,
86               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
87 1  <;> dbstate(main 24 optree_concise.t:132) v:>,<,%,{
88 2  <#> gvsv[*b] s
89 10 <$> const[IV 42] s
90 11 <2> add[t3] sK/2
91 12 <#> gvsv[*a] s
92 20 <2> sassign sKS/2
93 21 <1> leavesub[1 ref] K/REFC,1
94 EOT_EOT
95 # 1  <;> nextstate(main 62 optree_concise.t:161) v:>,<,%,{
96 # 2  <$> gvsv(*b) s
97 # 10 <$> const(IV 42) s
98 # 11 <2> add[t1] sK/2
99 # 12 <$> gvsv(*a) s
100 # 20 <2> sassign sKS/2
101 # 21 <1> leavesub[1 ref] K/REFC,1
102 EONT_EONT
103
104 checkOptree ( name      => 'sticky-base3, -basic over sticky-exec',
105               bcopts    => '-basic',
106               code      => sub{$a=$b+42},
107               strip_open_hints => 1,
108               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
109 21 <1> leavesub[1 ref] K/REFC,1 ->(end)
110 -     <@> lineseq KP ->21
111 1        <;> nextstate(main 32 optree_concise.t:164) v:>,<,%,{ ->2
112 20       <2> sassign sKS/2 ->21
113 11          <2> add[t3] sK/2 ->12
114 -              <1> ex-rv2sv sK/1 ->10
115 2                 <#> gvsv[*b] s ->10
116 10             <$> const[IV 42] s ->11
117 -           <1> ex-rv2sv sKRM*/1 ->20
118 12             <#> gvsv[*a] s ->20
119 EOT_EOT
120 # 21 <1> leavesub[1 ref] K/REFC,1 ->(end)
121 # -     <@> lineseq KP ->21
122 # 1        <;> nextstate(main 63 optree_concise.t:186) v:>,<,%,{ ->2
123 # 20       <2> sassign sKS/2 ->21
124 # 11          <2> add[t1] sK/2 ->12
125 # -              <1> ex-rv2sv sK/1 ->10
126 # 2                 <$> gvsv(*b) s ->10
127 # 10             <$> const(IV 42) s ->11
128 # -           <1> ex-rv2sv sKRM*/1 ->20
129 # 12             <$> gvsv(*a) s ->20
130 EONT_EONT
131
132 checkOptree ( name      => '-base4',
133               bcopts    => [qw/ -basic -base4 /],
134               code      => sub{$a=$b+42},
135               strip_open_hints => 1,
136               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
137 13 <1> leavesub[1 ref] K/REFC,1 ->(end)
138 -     <@> lineseq KP ->13
139 1        <;> nextstate(main 26 optree_concise.t:145) v:>,<,%,{ ->2
140 12       <2> sassign sKS/2 ->13
141 10          <2> add[t3] sK/2 ->11
142 -              <1> ex-rv2sv sK/1 ->3
143 2                 <#> gvsv[*b] s ->3
144 3              <$> const[IV 42] s ->10
145 -           <1> ex-rv2sv sKRM*/1 ->12
146 11             <#> gvsv[*a] s ->12
147 EOT_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
158 EONT_EONT
159
160 checkOptree ( name      => "restore -base36 default",
161               bcopts    => [qw/ -basic -base36 /],
162               code      => sub{$a},
163               crossfail => 1,
164               strip_open_hints => 1,
165               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
166 3  <1> leavesub[1 ref] K/REFC,1 ->(end)
167 -     <@> lineseq KP ->3
168 1        <;> nextstate(main 27 optree_concise.t:161) v:>,<,% ->2
169 -        <1> ex-rv2sv sK/1 ->-
170 2           <#> gvsv[*a] s ->3
171 EOT_EOT
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
177 EONT_EONT
178
179 checkOptree ( name      => "terse basic",
180               bcopts    => [qw/ -basic -terse /],
181               code      => sub{$a},
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 [14] 
187             PADOP (0x82b0840) gvsv  GV (0x82a818c) *a 
188 EOT_EOT
189 # UNOP (0x8282310) leavesub [1] 
190 #     LISTOP (0x82822f0) lineseq 
191 #         COP (0x82822b8) nextstate 
192 #         UNOP (0x812fc20) null [14] 
193 #             SVOP (0x812fc00) gvsv  GV (0x814692c) *a 
194 EONT_EONT
195
196 checkOptree ( name      => "sticky-terse exec",
197               bcopts    => [qw/ -exec /],
198               code      => sub{$a},
199               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
200 COP (0x82b0d70) nextstate 
201 PADOP (0x82b0d30) gvsv  GV (0x82a818c) *a 
202 UNOP (0x82b0e08) leavesub [1] 
203 EOT_EOT
204 # COP (0x82828e0) nextstate 
205 # SVOP (0x82828a0) gvsv  GV (0x814692c) *a 
206 # UNOP (0x8282938) leavesub [1] 
207 EONT_EONT
208
209 pass("OPTIONS IN CMDLINE MODE");
210
211 checkOptree ( name => 'cmdline invoke -basic works',
212               prog => 'sort @a',
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.',
215                         ],
216               #bcopts   => '-basic', # default
217               strip_open_hints => 1,
218               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
219 # 7  <@> leave[1 ref] vKP/REFC ->(end)
220 # 1     <0> enter v ->2
221 # 2     <;> nextstate(main 1 -e:1) v:>,<,%,{ ->3
222 # 6     <@> sort vK ->7
223 # 3        <0> pushmark s ->4
224 # 5        <1> rv2av[t2] lK/1 ->6
225 # 4           <#> gv[*a] s ->5
226 EOT_EOT
227 # 7  <@> leave[1 ref] vKP/REFC ->(end)
228 # 1     <0> enter v ->2
229 # 2     <;> nextstate(main 1 -e:1) v:>,<,%,{ ->3
230 # 6     <@> sort vK ->7
231 # 3        <0> pushmark s ->4
232 # 5        <1> rv2av[t1] lK/1 ->6
233 # 4           <$> gv(*a) s ->5
234 EONT_EONT
235
236 checkOptree ( name => 'cmdline invoke -exec works',
237               prog => 'sort @a',
238               errs => [ 'Useless use of sort in void context at -e line 1.',
239                         'Name "main::a" used only once: possible typo at -e line 1.',
240                         ],
241               bcopts => '-exec',
242               strip_open_hints => 1,
243               expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
244 1  <0> enter v
245 2  <;> nextstate(main 1 -e:1) v:>,<,%,{
246 3  <0> pushmark s
247 4  <#> gv[*a] s
248 5  <1> rv2av[t2] lK/1
249 6  <@> sort vK
250 7  <@> leave[1 ref] vKP/REFC
251 EOT_EOT
252 # 1  <0> enter v
253 # 2  <;> nextstate(main 1 -e:1) v:>,<,%,{
254 # 3  <0> pushmark s
255 # 4  <$> gv(*a) s
256 # 5  <1> rv2av[t1] lK/1
257 # 6  <@> sort vK
258 # 7  <@> leave[1 ref] vKP/REFC
259 EONT_EONT
260
261 ;
262
263 checkOptree
264     ( name      => 'cmdline self-strict compile err using prog',
265       prog      => 'use strict; sort @a',
266       bcopts    => [qw/ -basic -concise -exec /],
267       errs      => 'Global symbol "@a" requires explicit package name (did you forget to declare "my @a"?) at -e line 1.',
268       expect    => 'nextstate',
269       expect_nt => 'nextstate',
270       noanchors => 1, # allow simple expectations to work
271       );
272
273 checkOptree
274     ( name      => 'cmdline self-strict compile err using code',
275       code      => 'use strict; sort @a',
276       bcopts    => [qw/ -basic -concise -exec /],
277       errs      => qr/Global symbol "\@a" requires explicit package (?x:
278                      )name \(did you forget to declare "my \@a"\?\) at (?x:
279                      ).*? line 1\./,
280       note      => 'this test relys on a kludge which copies $@ to rendering when empty',
281       expect    => 'Global symbol',
282       expect_nt => 'Global symbol',
283       noanchors => 1, # allow simple expectations to work
284       );
285
286 checkOptree
287     ( name      => 'cmdline -basic -concise -exec works',
288       prog      => 'our @a; sort @a',
289       bcopts    => [qw/ -basic -concise -exec /],
290       errs      => ['Useless use of sort in void context at -e line 1.'],
291       strip_open_hints => 1,
292       expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
293 # 1  <0> enter v
294 # 2  <;> nextstate(main 2 -e:1) v:>,<,%,{
295 # 3  <0> pushmark s
296 # 4  <#> gv[*a] s
297 # 5  <1> rv2av[t5] lK/1
298 # 6  <@> sort vK
299 # 7  <@> leave[1 ref] vKP/REFC
300 EOT_EOT
301 # 1  <0> enter v
302 # 2  <;> nextstate(main 2 -e:1) v:>,<,%,{
303 # 3  <0> pushmark s
304 # 4  <$> gv(*a) s
305 # 5  <1> rv2av[t3] lK/1
306 # 6  <@> sort vK
307 # 7  <@> leave[1 ref] vKP/REFC
308 EONT_EONT
309
310
311 #################################
312 pass("B::Concise STYLE/CALLBACK TESTS");
313
314 use 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"
323       , "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"
324       #. "(x(;~=> #extra)x)\n" # new 'variable' used here
325       );
326
327 sub 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
341             if ($lastnext and $$lastnext != $$op) {
342                 $h->{goto} = ($h->{seq} eq '-')
343                     ? 'unresolved' : $h->{seq};
344             }
345
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                 # suppress printout entirely
353                 $$format="" unless grep { $h->{name} eq $_ } @scopeops;
354             }
355         });
356 }
357
358 #################################
359 set_up_relative_test();
360 pass("set_up_relative_test, new callback installed");
361
362 checkOptree ( name      => 'callback used, independent of style',
363               bcopts    => [qw/ -concise -exec /],
364               code      => sub{$a=$b+42},
365               strip_open_hints => 1,
366               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
367 1  <;> nextstate(main 76 optree_concise.t:337) v:>,<,%,{
368 2  <#> gvsv[*b] s
369 3  <$> const[IV 42] CALLBACK s
370 4  <2> add[t3] sK/2
371 5  <#> gvsv[*a] s
372 6  <2> sassign sKS/2
373 7  <1> leavesub[1 ref] K/REFC,1
374 EOT_EOT
375 # 1  <;> nextstate(main 455 optree_concise.t:328) v:>,<,%,{
376 # 2  <$> gvsv(*b) s
377 # 3  <$> const(IV 42) CALLBACK s
378 # 4  <2> add[t1] sK/2
379 # 5  <$> gvsv(*a) s
380 # 6  <2> sassign sKS/2
381 # 7  <1> leavesub[1 ref] K/REFC,1
382 EONT_EONT
383
384 checkOptree ( name      => "new 'relative' style, -exec mode",
385               bcopts    => [qw/ -basic -relative /],
386               code      => sub{$a=$b+42},
387               crossfail => 1,
388               #retry    => 1,
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
400 EOT_EOT
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
411 EONT_EONT
412
413 checkOptree ( name      => "both -exec -relative",
414               bcopts    => [qw/ -exec -relative /],
415               code      => sub{$a=$b+42},
416               crossfail => 1,
417               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
418 1  <;> nextstate(main 50 optree_concise.t:326) v 
419 2  <#> gvsv[*b] s 
420 3  <$> const[IV 42] CALLBACK s 
421 4  <2> add[t3] sK 
422 5  <#> gvsv[*a] s 
423 6  <2> sassign sKS 
424 7  <1> leavesub RELATIVE[1 ref] K 
425 EOT_EOT
426 # 1  <;> nextstate(main 78 optree_concise.t:371) v 
427 # 2  <$> gvsv(*b) s 
428 # 3  <$> const(IV 42) CALLBACK s 
429 # 4  <2> add[t1] sK 
430 # 5  <$> gvsv(*a) s 
431 # 6  <2> sassign sKS 
432 # 7  <1> leavesub RELATIVE[1 ref] K 
433 EONT_EONT
434
435 #################################
436
437 @scopeops = qw( leavesub enter leave nextstate );
438 add_style
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])?)"
444          );
445
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 
452 EOT_EOT
453 1  <;> nextstate(main 75 optree_concise.t:396) v 
454 7  <1> leavesub[1 ref] K/REFC,1 
455 EONT_EONT
456
457
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 
464 EOT_EOT
465 7  <1> leavesub[1 ref] K/REFC,1 ->(end) 
466 1        <;> nextstate(main 76 optree_concise.t:407) v ->2 
467 EONT_EONT