xref: /openbsd/gnu/usr.bin/perl/ext/B/t/optree_concise.t (revision e0680481) 
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}
11
12# import checkOptree(), and %gOpts (containing test state)
13use OptreeCheck;	# ALSO DOES @ARGV HANDLING !!!!!!
14
15plan tests => 41;
16
17$SIG{__WARN__} = sub {
18    my $err = shift;
19    $err =~ m/Subroutine re::(un)?install redefined/ and return;
20};
21#################################
22pass("CANONICAL B::Concise EXAMPLE");
23
24checkOptree ( name	=> 'canonical example w -basic',
25	      bcopts	=> '-basic',
26	      code	=>  sub{$a=$b+42},
27	      strip_open_hints => 1,
28	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
29# 7  <1> leavesub[1 ref] K/REFC,1 ->(end)
30# -     <@> lineseq KP ->7
31# 1        <;> nextstate(foo bar) v:>,<,%,{ ->2
32# 6        <2> sassign sKS/2 ->7
33# 4           <2> add[t3] sK/2 ->5
34# -              <1> ex-rv2sv sK/1 ->3
35# 2                 <#> gvsv[*b] s ->3
36# 3              <$> const[IV 42] s ->4
37# -           <1> ex-rv2sv sKRM*/1 ->6
38# 5              <#> gvsv[*a] s ->6
39EOT_EOT
40# 7  <1> leavesub[1 ref] K/REFC,1 ->(end)
41# -     <@> lineseq KP ->7
42# 1        <;> nextstate(main 60 optree_concise.t:122) v:>,<,%,{ ->2
43# 6        <2> sassign sKS/2 ->7
44# 4           <2> add[t1] 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
50EONT_EONT
51
52checkOptree ( name	=> 'canonical example w -exec',
53	      bcopts	=> '-exec',
54	      code	=> sub{$a=$b+42},
55	      strip_open_hints => 1,
56	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
57# 1  <;> nextstate(main 61 optree_concise.t:139) v:>,<,%,{
58# 2  <#> gvsv[*b] s
59# 3  <$> const[IV 42] s
60# 4  <2> add[t3] sK/2
61# 5  <#> gvsv[*a] s
62# 6  <2> sassign sKS/2
63# 7  <1> leavesub[1 ref] K/REFC,1
64EOT_EOT
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[t1] sK/2
69# 5  <$> gvsv(*a) s
70# 6  <2> sassign sKS/2
71# 7  <1> leavesub[1 ref] K/REFC,1
72EONT_EONT
73
74#################################
75pass("B::Concise OPTION TESTS");
76
77checkOptree ( name	=> '-base3 sticky-exec',
78	      bcopts	=> '-base3',
79	      code	=> sub{$a=$b+42},
80	      strip_open_hints => 1,
81	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
821  <;> dbstate(main 24 optree_concise.t:132) v:>,<,%,{
832  <#> gvsv[*b] s
8410 <$> const[IV 42] s
8511 <2> add[t3] sK/2
8612 <#> gvsv[*a] s
8720 <2> sassign sKS/2
8821 <1> leavesub[1 ref] K/REFC,1
89EOT_EOT
90# 1  <;> nextstate(main 62 optree_concise.t:161) v:>,<,%,{
91# 2  <$> gvsv(*b) s
92# 10 <$> const(IV 42) s
93# 11 <2> add[t1] sK/2
94# 12 <$> gvsv(*a) s
95# 20 <2> sassign sKS/2
96# 21 <1> leavesub[1 ref] K/REFC,1
97EONT_EONT
98
99checkOptree ( name	=> 'sticky-base3, -basic over sticky-exec',
100	      bcopts	=> '-basic',
101	      code	=> sub{$a=$b+42},
102	      strip_open_hints => 1,
103	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
10421 <1> leavesub[1 ref] K/REFC,1 ->(end)
105-     <@> lineseq KP ->21
1061        <;> nextstate(main 32 optree_concise.t:164) v:>,<,%,{ ->2
10720       <2> sassign sKS/2 ->21
10811          <2> add[t3] sK/2 ->12
109-              <1> ex-rv2sv sK/1 ->10
1102                 <#> gvsv[*b] s ->10
11110             <$> const[IV 42] s ->11
112-           <1> ex-rv2sv sKRM*/1 ->20
11312             <#> gvsv[*a] s ->20
114EOT_EOT
115# 21 <1> leavesub[1 ref] K/REFC,1 ->(end)
116# -     <@> lineseq KP ->21
117# 1        <;> nextstate(main 63 optree_concise.t:186) v:>,<,%,{ ->2
118# 20       <2> sassign sKS/2 ->21
119# 11          <2> add[t1] 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
125EONT_EONT
126
127checkOptree ( name	=> '-base4',
128	      bcopts	=> [qw/ -basic -base4 /],
129	      code	=> sub{$a=$b+42},
130	      strip_open_hints => 1,
131	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
13213 <1> leavesub[1 ref] K/REFC,1 ->(end)
133-     <@> lineseq KP ->13
1341        <;> nextstate(main 26 optree_concise.t:145) v:>,<,%,{ ->2
13512       <2> sassign sKS/2 ->13
13610          <2> add[t3] sK/2 ->11
137-              <1> ex-rv2sv sK/1 ->3
1382                 <#> gvsv[*b] s ->3
1393              <$> const[IV 42] s ->10
140-           <1> ex-rv2sv sKRM*/1 ->12
14111             <#> gvsv[*a] s ->12
142EOT_EOT
143# 13 <1> leavesub[1 ref] K/REFC,1 ->(end)
144# -     <@> lineseq KP ->13
145# 1        <;> nextstate(main 64 optree_concise.t:193) v:>,<,%,{ ->2
146# 12       <2> sassign sKS/2 ->13
147# 10          <2> add[t1] sK/2 ->11
148# -              <1> ex-rv2sv sK/1 ->3
149# 2                 <$> gvsv(*b) s ->3
150# 3              <$> const(IV 42) s ->10
151# -           <1> ex-rv2sv sKRM*/1 ->12
152# 11             <$> gvsv(*a) s ->12
153EONT_EONT
154
155checkOptree ( name	=> "restore -base36 default",
156	      bcopts	=> [qw/ -basic -base36 /],
157	      code	=> sub{$a},
158	      crossfail	=> 1,
159	      strip_open_hints => 1,
160	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
1613  <1> leavesub[1 ref] K/REFC,1 ->(end)
162-     <@> lineseq KP ->3
1631        <;> nextstate(main 27 optree_concise.t:161) v:>,<,% ->2
164-        <1> ex-rv2sv sK/1 ->-
1652           <#> gvsv[*a] s ->3
166EOT_EOT
167# 3  <1> leavesub[1 ref] K/REFC,1 ->(end)
168# -     <@> lineseq KP ->3
169# 1        <;> nextstate(main 65 optree_concise.t:210) v:>,<,% ->2
170# -        <1> ex-rv2sv sK/1 ->-
171# 2           <$> gvsv(*a) s ->3
172EONT_EONT
173
174checkOptree ( name	=> "terse basic",
175	      bcopts	=> [qw/ -basic -terse /],
176	      code	=> sub{$a},
177	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
178UNOP (0x82b0918) leavesub [1]
179    LISTOP (0x82b08d8) lineseq
180        COP (0x82b0880) nextstate
181        UNOP (0x82b0860) null [15]
182            PADOP (0x82b0840) gvsv  GV (0x82a818c) *a
183EOT_EOT
184# UNOP (0x8282310) leavesub [1]
185#     LISTOP (0x82822f0) lineseq
186#         COP (0x82822b8) nextstate
187#         UNOP (0x812fc20) null [15]
188#             SVOP (0x812fc00) gvsv  GV (0x814692c) *a
189EONT_EONT
190
191checkOptree ( name	=> "sticky-terse exec",
192	      bcopts	=> [qw/ -exec /],
193	      code	=> sub{$a},
194	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
195COP (0x82b0d70) nextstate
196PADOP (0x82b0d30) gvsv  GV (0x82a818c) *a
197UNOP (0x82b0e08) leavesub [1]
198EOT_EOT
199# COP (0x82828e0) nextstate
200# SVOP (0x82828a0) gvsv  GV (0x814692c) *a
201# UNOP (0x8282938) leavesub [1]
202EONT_EONT
203
204pass("OPTIONS IN CMDLINE MODE");
205
206checkOptree ( name => 'cmdline invoke -basic works',
207	      prog => 'sort @a',
208	      errs => [ 'Useless use of sort in void context at -e line 1.',
209			'Name "main::a" used only once: possible typo at -e line 1.',
210			],
211	      #bcopts	=> '-basic', # default
212	      strip_open_hints => 1,
213	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
214# 7  <@> leave[1 ref] vKP/REFC ->(end)
215# 1     <0> enter v ->2
216# 2     <;> nextstate(main 1 -e:1) v:>,<,%,{ ->3
217# 6     <@> sort vK ->7
218# 3        <0> pushmark s ->4
219# 5        <1> rv2av[t2] lK/1 ->6
220# 4           <#> gv[*a] s ->5
221EOT_EOT
222# 7  <@> leave[1 ref] vKP/REFC ->(end)
223# 1     <0> enter v ->2
224# 2     <;> nextstate(main 1 -e:1) v:>,<,%,{ ->3
225# 6     <@> sort vK ->7
226# 3        <0> pushmark s ->4
227# 5        <1> rv2av[t1] lK/1 ->6
228# 4           <$> gv(*a) s ->5
229EONT_EONT
230
231checkOptree ( name => 'cmdline invoke -exec works',
232	      prog => 'sort @a',
233	      errs => [ 'Useless use of sort in void context at -e line 1.',
234			'Name "main::a" used only once: possible typo at -e line 1.',
235			],
236	      bcopts => '-exec',
237	      strip_open_hints => 1,
238	      expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
2391  <0> enter v
2402  <;> nextstate(main 1 -e:1) v:>,<,%,{
2413  <0> pushmark s
2424  <#> gv[*a] s
2435  <1> rv2av[t2] lK/1
2446  <@> sort vK
2457  <@> leave[1 ref] vKP/REFC
246EOT_EOT
247# 1  <0> enter v
248# 2  <;> nextstate(main 1 -e:1) v:>,<,%,{
249# 3  <0> pushmark s
250# 4  <$> gv(*a) s
251# 5  <1> rv2av[t1] lK/1
252# 6  <@> sort vK
253# 7  <@> leave[1 ref] vKP/REFC
254EONT_EONT
255
256;
257
258checkOptree
259    ( name	=> 'cmdline self-strict compile err using prog',
260      prog	=> 'use strict; sort @a',
261      bcopts	=> [qw/ -basic -concise -exec /],
262      errs	=> 'Global symbol "@a" requires explicit package name (did you forget to declare "my @a"?) at -e line 1.',
263      expect	=> 'nextstate',
264      expect_nt	=> 'nextstate',
265      noanchors => 1, # allow simple expectations to work
266      );
267
268checkOptree
269    ( name	=> 'cmdline self-strict compile err using code',
270      code	=> 'use strict; sort @a',
271      bcopts	=> [qw/ -basic -concise -exec /],
272      errs	=> qr/Global symbol "\@a" requires explicit package (?x:
273		     )name \(did you forget to declare "my \@a"\?\) at (?x:
274		     ).*? line 1\./,
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
279      );
280
281checkOptree
282    ( name	=> 'cmdline -basic -concise -exec works',
283      prog	=> 'our @a; sort @a',
284      bcopts	=> [qw/ -basic -concise -exec /],
285      errs	=> ['Useless use of sort in void context at -e line 1.'],
286      strip_open_hints => 1,
287      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
288# 1  <0> enter v
289# 2  <;> nextstate(main 2 -e:1) v:>,<,%,{
290# 3  <0> pushmark s
291# 4  <#> gv[*a] s
292# 5  <1> rv2av[t5] lK/1
293# 6  <@> sort vK
294# 7  <@> leave[1 ref] vKP/REFC
295EOT_EOT
296# 1  <0> enter v
297# 2  <;> nextstate(main 2 -e:1) v:>,<,%,{
298# 3  <0> pushmark s
299# 4  <$> gv(*a) s
300# 5  <1> rv2av[t3] lK/1
301# 6  <@> sort vK
302# 7  <@> leave[1 ref] vKP/REFC
303EONT_EONT
304
305
306#################################
307pass("B::Concise STYLE/CALLBACK TESTS");
308
309use B::Concise qw( walk_output add_style set_style_standard add_callback );
310
311# new relative style, added by set_up_relative_test()
312@stylespec =
313    ( "#hyphseq2 (*(   (x( ;)x))*)<#classsym> "
314      . "#exname#arg(?([#targarglife])?)~#flags(?(/#privateb)?)(x(;~->#next)x) "
315      . "(x(;~=> #extra)x)\n" # new 'variable' used here
316
317      , "  (*(    )*)     goto #seq\n"
318      , "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"
319      #. "(x(;~=> #extra)x)\n" # new 'variable' used here
320      );
321
322sub set_up_relative_test {
323    # add a new style, and a callback which adds an 'extra' property
324
325    add_style ( "relative"	=> @stylespec );
326    #set_style_standard ( "relative" );
327
328    add_callback
329	( sub {
330	    my ($h, $op, $format, $level, $style) = @_;
331
332	    # callback marks up const ops
333	    $h->{arg} .= ' CALLBACK' if $h->{name} eq 'const';
334	    $h->{extra} = '';
335
336	    if ($lastnext and $$lastnext != $$op) {
337		$h->{goto} = ($h->{seq} eq '-')
338		    ? 'unresolved' : $h->{seq};
339	    }
340
341	    # 2 style specific behaviors
342	    if ($style eq 'relative') {
343		$h->{extra} = 'RELATIVE';
344		$h->{arg} .= ' RELATIVE' if $h->{name} eq 'leavesub';
345	    }
346	    elsif ($style eq 'scope') {
347		# suppress printout entirely
348		$$format="" unless grep { $h->{name} eq $_ } @scopeops;
349	    }
350	});
351}
352
353#################################
354set_up_relative_test();
355pass("set_up_relative_test, new callback installed");
356
357checkOptree ( name	=> 'callback used, independent of style',
358	      bcopts	=> [qw/ -concise -exec /],
359	      code	=> sub{$a=$b+42},
360	      strip_open_hints => 1,
361	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
3621  <;> nextstate(main 76 optree_concise.t:337) v:>,<,%,{
3632  <#> gvsv[*b] s
3643  <$> const[IV 42] CALLBACK s
3654  <2> add[t3] sK/2
3665  <#> gvsv[*a] s
3676  <2> sassign sKS/2
3687  <1> leavesub[1 ref] K/REFC,1
369EOT_EOT
370# 1  <;> nextstate(main 455 optree_concise.t:328) v:>,<,%,{
371# 2  <$> gvsv(*b) s
372# 3  <$> const(IV 42) CALLBACK s
373# 4  <2> add[t1] sK/2
374# 5  <$> gvsv(*a) s
375# 6  <2> sassign sKS/2
376# 7  <1> leavesub[1 ref] K/REFC,1
377EONT_EONT
378
379checkOptree ( name	=> "new 'relative' style, -exec mode",
380	      bcopts	=> [qw/ -basic -relative /],
381	      code	=> sub{$a=$b+42},
382	      crossfail	=> 1,
383	      #retry	=> 1,
384	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
3857  <1> leavesub RELATIVE[1 ref] K ->(end) => RELATIVE
386-     <@> lineseq KP ->7 => RELATIVE
3871        <;> nextstate(main 49 optree_concise.t:309) v ->2 => RELATIVE
3886        <2> sassign sKS ->7 => RELATIVE
3894           <2> add[t3] sK ->5 => RELATIVE
390-              <1> ex-rv2sv sK ->3 => RELATIVE
3912                 <#> gvsv[*b] s ->3 => RELATIVE
3923              <$> const[IV 42] CALLBACK s ->4 => RELATIVE
393-           <1> ex-rv2sv sKRM* ->6 => RELATIVE
3945              <#> gvsv[*a] s ->6 => RELATIVE
395EOT_EOT
396# 7  <1> leavesub RELATIVE[1 ref] K ->(end) => RELATIVE
397# -     <@> lineseq KP ->7 => RELATIVE
398# 1        <;> nextstate(main 77 optree_concise.t:353) v ->2 => RELATIVE
399# 6        <2> sassign sKS ->7 => RELATIVE
400# 4           <2> add[t1] sK ->5 => RELATIVE
401# -              <1> ex-rv2sv sK ->3 => RELATIVE
402# 2                 <$> gvsv(*b) s ->3 => RELATIVE
403# 3              <$> const(IV 42) CALLBACK s ->4 => RELATIVE
404# -           <1> ex-rv2sv sKRM* ->6 => RELATIVE
405# 5              <$> gvsv(*a) s ->6 => RELATIVE
406EONT_EONT
407
408checkOptree ( name	=> "both -exec -relative",
409	      bcopts	=> [qw/ -exec -relative /],
410	      code	=> sub{$a=$b+42},
411	      crossfail	=> 1,
412	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
4131  <;> nextstate(main 50 optree_concise.t:326) v
4142  <#> gvsv[*b] s
4153  <$> const[IV 42] CALLBACK s
4164  <2> add[t3] sK
4175  <#> gvsv[*a] s
4186  <2> sassign sKS
4197  <1> leavesub RELATIVE[1 ref] K
420EOT_EOT
421# 1  <;> nextstate(main 78 optree_concise.t:371) v
422# 2  <$> gvsv(*b) s
423# 3  <$> const(IV 42) CALLBACK s
424# 4  <2> add[t1] sK
425# 5  <$> gvsv(*a) s
426# 6  <2> sassign sKS
427# 7  <1> leavesub RELATIVE[1 ref] K
428EONT_EONT
429
430#################################
431
432@scopeops = qw( leavesub enter leave nextstate );
433add_style
434	( 'scope'  # concise copy
435	  , "#hyphseq2 (*(   (x( ;)x))*)<#classsym> "
436	  . "#exname#arg(?([#targarglife])?)~#flags(?(/#private)?)(x(;~->#next)x) "
437	  , "  (*(    )*)     goto #seq\n"
438	  , "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"
439	 );
440
441checkOptree ( name	=> "both -exec -scope",
442	      bcopts	=> [qw/ -exec -scope /],
443	      code	=> sub{$a=$b+42},
444	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
4451  <;> nextstate(main 50 optree_concise.t:337) v
4467  <1> leavesub[1 ref] K/REFC,1
447EOT_EOT
4481  <;> nextstate(main 75 optree_concise.t:396) v
4497  <1> leavesub[1 ref] K/REFC,1
450EONT_EONT
451
452
453checkOptree ( name	=> "both -basic -scope",
454	      bcopts	=> [qw/ -basic -scope /],
455	      code	=> sub{$a=$b+42},
456	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
4577  <1> leavesub[1 ref] K/REFC,1 ->(end)
4581        <;> nextstate(main 51 optree_concise.t:347) v ->2
459EOT_EOT
4607  <1> leavesub[1 ref] K/REFC,1 ->(end)
4611        <;> nextstate(main 76 optree_concise.t:407) v ->2
462EONT_EONT
463