xref: /openbsd/gnu/usr.bin/perl/ext/B/t/optree_concise.t (revision a6445c1d) 
1#!perl
2
3BEGIN {
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)
17use OptreeCheck;	# ALSO DOES @ARGV HANDLING !!!!!!
18use Config;
19
20plan tests => 41;
21
22$SIG{__WARN__} = sub {
23    my $err = shift;
24    $err =~ m/Subroutine re::(un)?install redefined/ and return;
25};
26#################################
27pass("CANONICAL B::Concise EXAMPLE");
28
29checkOptree ( 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
44EOT_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
55EONT_EONT
56
57checkOptree ( 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
69EOT_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
77EONT_EONT
78
79#################################
80pass("B::Concise OPTION TESTS");
81
82checkOptree ( 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');
871  <;> dbstate(main 24 optree_concise.t:132) v:>,<,%,{
882  <#> gvsv[*b] s
8910 <$> const[IV 42] s
9011 <2> add[t3] sK/2
9112 <#> gvsv[*a] s
9220 <2> sassign sKS/2
9321 <1> leavesub[1 ref] K/REFC,1
94EOT_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
102EONT_EONT
103
104checkOptree ( 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');
10921 <1> leavesub[1 ref] K/REFC,1 ->(end)
110-     <@> lineseq KP ->21
1111        <;> nextstate(main 32 optree_concise.t:164) v:>,<,%,{ ->2
11220       <2> sassign sKS/2 ->21
11311          <2> add[t3] sK/2 ->12
114-              <1> ex-rv2sv sK/1 ->10
1152                 <#> gvsv[*b] s ->10
11610             <$> const[IV 42] s ->11
117-           <1> ex-rv2sv sKRM*/1 ->20
11812             <#> gvsv[*a] s ->20
119EOT_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
130EONT_EONT
131
132checkOptree ( 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');
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	      strip_open_hints => 1,
165	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
1663  <1> leavesub[1 ref] K/REFC,1 ->(end)
167-     <@> lineseq KP ->3
1681        <;> nextstate(main 27 optree_concise.t:161) v:>,<,% ->2
169-        <1> ex-rv2sv sK/1 ->-
1702           <#> gvsv[*a] s ->3
171EOT_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
177EONT_EONT
178
179checkOptree ( name	=> "terse basic",
180	      bcopts	=> [qw/ -basic -terse /],
181	      code	=> sub{$a},
182	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
183UNOP (0x82b0918) leavesub [1]
184    LISTOP (0x82b08d8) lineseq
185        COP (0x82b0880) nextstate
186        UNOP (0x82b0860) null [15]
187            PADOP (0x82b0840) gvsv  GV (0x82a818c) *a
188EOT_EOT
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
194EONT_EONT
195
196checkOptree ( name	=> "sticky-terse exec",
197	      bcopts	=> [qw/ -exec /],
198	      code	=> sub{$a},
199	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
200COP (0x82b0d70) nextstate
201PADOP (0x82b0d30) gvsv  GV (0x82a818c) *a
202UNOP (0x82b0e08) leavesub [1]
203EOT_EOT
204# COP (0x82828e0) nextstate
205# SVOP (0x82828a0) gvsv  GV (0x814692c) *a
206# UNOP (0x8282938) leavesub [1]
207EONT_EONT
208
209pass("OPTIONS IN CMDLINE MODE");
210
211checkOptree ( 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 ->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
226EOT_EOT
227# 7  <@> leave[1 ref] vKP/REFC ->(end)
228# 1     <0> enter ->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
234EONT_EONT
235
236checkOptree ( 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');
2441  <0> enter
2452  <;> nextstate(main 1 -e:1) v:>,<,%,{
2463  <0> pushmark s
2474  <#> gv[*a] s
2485  <1> rv2av[t2] lK/1
2496  <@> sort vK
2507  <@> leave[1 ref] vKP/REFC
251EOT_EOT
252# 1  <0> enter
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
259EONT_EONT
260
261;
262
263checkOptree
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 at -e line 1.',
268      expect	=> 'nextstate',
269      expect_nt	=> 'nextstate',
270      noanchors => 1, # allow simple expectations to work
271      );
272
273checkOptree
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 name at .*? line 1\./,
278      note	=> 'this test relys on a kludge which copies $@ to rendering when empty',
279      expect	=> 'Global symbol',
280      expect_nt	=> 'Global symbol',
281      noanchors => 1, # allow simple expectations to work
282      );
283
284checkOptree
285    ( name	=> 'cmdline -basic -concise -exec works',
286      prog	=> 'our @a; sort @a',
287      bcopts	=> [qw/ -basic -concise -exec /],
288      errs	=> ['Useless use of sort in void context at -e line 1.'],
289      strip_open_hints => 1,
290      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
291# 1  <0> enter
292# 2  <;> nextstate(main 1 -e:1) v:>,<,%,{
293# 3  <#> gv[*a] s
294# 4  <1> rv2av[t3] vK/OURINTR,1
295# 5  <;> nextstate(main 2 -e:1) v:>,<,%,{
296# 6  <0> pushmark s
297# 7  <#> gv[*a] s
298# 8  <1> rv2av[t5] lK/1
299# 9  <@> sort vK
300# a  <@> leave[1 ref] vKP/REFC
301EOT_EOT
302# 1  <0> enter
303# 2  <;> nextstate(main 1 -e:1) v:>,<,%,{
304# 3  <$> gv(*a) s
305# 4  <1> rv2av[t2] vK/OURINTR,1
306# 5  <;> nextstate(main 2 -e:1) v:>,<,%,{
307# 6  <0> pushmark s
308# 7  <$> gv(*a) s
309# 8  <1> rv2av[t3] lK/1
310# 9  <@> sort vK
311# a  <@> leave[1 ref] vKP/REFC
312EONT_EONT
313
314
315#################################
316pass("B::Concise STYLE/CALLBACK TESTS");
317
318use B::Concise qw( walk_output add_style set_style_standard add_callback );
319
320# new relative style, added by set_up_relative_test()
321@stylespec =
322    ( "#hyphseq2 (*(   (x( ;)x))*)<#classsym> "
323      . "#exname#arg(?([#targarglife])?)~#flags(?(/#privateb)?)(x(;~->#next)x) "
324      . "(x(;~=> #extra)x)\n" # new 'variable' used here
325
326      , "  (*(    )*)     goto #seq\n"
327      , "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"
328      #. "(x(;~=> #extra)x)\n" # new 'variable' used here
329      );
330
331sub set_up_relative_test {
332    # add a new style, and a callback which adds an 'extra' property
333
334    add_style ( "relative"	=> @stylespec );
335    #set_style_standard ( "relative" );
336
337    add_callback
338	( sub {
339	    my ($h, $op, $format, $level, $style) = @_;
340
341	    # callback marks up const ops
342	    $h->{arg} .= ' CALLBACK' if $h->{name} eq 'const';
343	    $h->{extra} = '';
344
345	    if ($lastnext and $$lastnext != $$op) {
346		$h->{goto} = ($h->{seq} eq '-')
347		    ? 'unresolved' : $h->{seq};
348	    }
349
350	    # 2 style specific behaviors
351	    if ($style eq 'relative') {
352		$h->{extra} = 'RELATIVE';
353		$h->{arg} .= ' RELATIVE' if $h->{name} eq 'leavesub';
354	    }
355	    elsif ($style eq 'scope') {
356		# suppress printout entirely
357		$$format="" unless grep { $h->{name} eq $_ } @scopeops;
358	    }
359	});
360}
361
362#################################
363set_up_relative_test();
364pass("set_up_relative_test, new callback installed");
365
366checkOptree ( name	=> 'callback used, independent of style',
367	      bcopts	=> [qw/ -concise -exec /],
368	      code	=> sub{$a=$b+42},
369	      strip_open_hints => 1,
370	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
3711  <;> nextstate(main 76 optree_concise.t:337) v:>,<,%,{
3722  <#> gvsv[*b] s
3733  <$> const[IV 42] CALLBACK s
3744  <2> add[t3] sK/2
3755  <#> gvsv[*a] s
3766  <2> sassign sKS/2
3777  <1> leavesub[1 ref] K/REFC,1
378EOT_EOT
379# 1  <;> nextstate(main 455 optree_concise.t:328) v:>,<,%,{
380# 2  <$> gvsv(*b) s
381# 3  <$> const(IV 42) CALLBACK s
382# 4  <2> add[t1] sK/2
383# 5  <$> gvsv(*a) s
384# 6  <2> sassign sKS/2
385# 7  <1> leavesub[1 ref] K/REFC,1
386EONT_EONT
387
388checkOptree ( name	=> "new 'relative' style, -exec mode",
389	      bcopts	=> [qw/ -basic -relative /],
390	      code	=> sub{$a=$b+42},
391	      crossfail	=> 1,
392	      #retry	=> 1,
393	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
3947  <1> leavesub RELATIVE[1 ref] K ->(end) => RELATIVE
395-     <@> lineseq KP ->7 => RELATIVE
3961        <;> nextstate(main 49 optree_concise.t:309) v ->2 => RELATIVE
3976        <2> sassign sKS ->7 => RELATIVE
3984           <2> add[t3] sK ->5 => RELATIVE
399-              <1> ex-rv2sv sK ->3 => RELATIVE
4002                 <#> gvsv[*b] s ->3 => RELATIVE
4013              <$> const[IV 42] CALLBACK s ->4 => RELATIVE
402-           <1> ex-rv2sv sKRM* ->6 => RELATIVE
4035              <#> gvsv[*a] s ->6 => RELATIVE
404EOT_EOT
405# 7  <1> leavesub RELATIVE[1 ref] K ->(end) => RELATIVE
406# -     <@> lineseq KP ->7 => RELATIVE
407# 1        <;> nextstate(main 77 optree_concise.t:353) v ->2 => RELATIVE
408# 6        <2> sassign sKS ->7 => RELATIVE
409# 4           <2> add[t1] sK ->5 => RELATIVE
410# -              <1> ex-rv2sv sK ->3 => RELATIVE
411# 2                 <$> gvsv(*b) s ->3 => RELATIVE
412# 3              <$> const(IV 42) CALLBACK s ->4 => RELATIVE
413# -           <1> ex-rv2sv sKRM* ->6 => RELATIVE
414# 5              <$> gvsv(*a) s ->6 => RELATIVE
415EONT_EONT
416
417checkOptree ( name	=> "both -exec -relative",
418	      bcopts	=> [qw/ -exec -relative /],
419	      code	=> sub{$a=$b+42},
420	      crossfail	=> 1,
421	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
4221  <;> nextstate(main 50 optree_concise.t:326) v
4232  <#> gvsv[*b] s
4243  <$> const[IV 42] CALLBACK s
4254  <2> add[t3] sK
4265  <#> gvsv[*a] s
4276  <2> sassign sKS
4287  <1> leavesub RELATIVE[1 ref] K
429EOT_EOT
430# 1  <;> nextstate(main 78 optree_concise.t:371) v
431# 2  <$> gvsv(*b) s
432# 3  <$> const(IV 42) CALLBACK s
433# 4  <2> add[t1] sK
434# 5  <$> gvsv(*a) s
435# 6  <2> sassign sKS
436# 7  <1> leavesub RELATIVE[1 ref] K
437EONT_EONT
438
439#################################
440
441@scopeops = qw( leavesub enter leave nextstate );
442add_style
443	( 'scope'  # concise copy
444	  , "#hyphseq2 (*(   (x( ;)x))*)<#classsym> "
445	  . "#exname#arg(?([#targarglife])?)~#flags(?(/#private)?)(x(;~->#next)x) "
446	  , "  (*(    )*)     goto #seq\n"
447	  , "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"
448	 );
449
450checkOptree ( name	=> "both -exec -scope",
451	      bcopts	=> [qw/ -exec -scope /],
452	      code	=> sub{$a=$b+42},
453	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
4541  <;> nextstate(main 50 optree_concise.t:337) v
4557  <1> leavesub[1 ref] K/REFC,1
456EOT_EOT
4571  <;> nextstate(main 75 optree_concise.t:396) v
4587  <1> leavesub[1 ref] K/REFC,1
459EONT_EONT
460
461
462checkOptree ( name	=> "both -basic -scope",
463	      bcopts	=> [qw/ -basic -scope /],
464	      code	=> sub{$a=$b+42},
465	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
4667  <1> leavesub[1 ref] K/REFC,1 ->(end)
4671        <;> nextstate(main 51 optree_concise.t:347) v ->2
468EOT_EOT
4697  <1> leavesub[1 ref] K/REFC,1 ->(end)
4701        <;> nextstate(main 76 optree_concise.t:407) v ->2
471EONT_EONT
472