This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
libperl leaks a THREAD_KEY each time it is reloaded
[perl5.git] / ext / B / t / optree_concise.t
CommitLineData
724aa791
JC		 1#!perl
2
3BEGIN {
5638aaac
SM		 4 if ($ENV{PERL_CORE}){
5 chdir('t') if -d 't';
6 @INC = ('.', '../lib', '../ext/B/t');
7 } else {
8 unshift @INC, 't';
9 push @INC, "../../t";
10 }
9cd8f857
NC		 11 require Config;
12 if (($Config::Config{'extensions'} !~ /\bB\b/) ){
13 print "1..0 # Skip -- Perl configured without B module\n";
14 exit 0;
15 }
8dd2f9d4 16 if ($Config::Config{'extensions'} !~ /\bData\/Dumper\b/) {
2799c206
NC		 17 print
18 "1..0 # Skip: Data::Dumper was not built, needed by OptreeCheck\n";
19 exit 0;
2799c206 20 }
5638aaac 21 require 'test.pl';
724aa791
JC		 22}
23
24# import checkOptree(), and %gOpts (containing test state)
25use OptreeCheck; # ALSO DOES @ARGV HANDLING !!!!!!
2ce64696 26use Config;
724aa791 27
5e251bf1 28plan tests => 24;
2ce64696 29SKIP: {
4837be01 30skip "no perlio in this build", 24 unless $Config::Config{useperlio};
724aa791
JC		 31
32$SIG{__WARN__} = sub {
33 my $err = shift;
34 $err =~ m/Subroutine re::(un)?install redefined/ and return;
35};
36#################################
37pass("CANONICAL B::Concise EXAMPLE");
38
39checkOptree ( name => 'canonical example w -basic',
40 bcopts => '-basic',
41 code => sub{$a=$b+42},
42 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
43# 7 <1> leavesub[\d+ refs?] K/REFC,1 ->(end)
44# - <@> lineseq KP ->7
45# 1 <;> nextstate(foo bar) v ->2
46# 6 <2> sassign sKS/2 ->7
47# 4 <2> add[t\d+] sK/2 ->5
48# - <1> ex-rv2sv sK/1 ->3
49# 2 <#> gvsv[*b] s ->3
50# 3 <$> const[IV 42] s ->4
51# - <1> ex-rv2sv sKRM*/1 ->6
52# 5 <#> gvsv[*a] s ->6
53EOT_EOT
54# 7 <1> leavesub[1 ref] K/REFC,1 ->(end)
55# - <@> lineseq KP ->7
56# 1 <;> nextstate(main 60 optree_concise.t:122) v ->2
57# 6 <2> sassign sKS/2 ->7
58# 4 <2> add[t1] sK/2 ->5
59# - <1> ex-rv2sv sK/1 ->3
60# 2 <$> gvsv(*b) s ->3
61# 3 <$> const(IV 42) s ->4
62# - <1> ex-rv2sv sKRM*/1 ->6
63# 5 <$> gvsv(*a) s ->6
64EONT_EONT
65
66checkOptree ( name => 'canonical example w -exec',
67 bcopts => '-exec',
68 code => sub{$a=$b+42},
69 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
724aa791
JC		 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[t3] sK/2
74# 5 <#> gvsv[*a] s
75# 6 <2> sassign sKS/2
76# 7 <1> leavesub[1 ref] K/REFC,1
77EOT_EOT
724aa791
JC		 78# 1 <;> nextstate(main 61 optree_concise.t:139) v
79# 2 <$> gvsv(*b) s
80# 3 <$> const(IV 42) s
81# 4 <2> add[t1] sK/2
82# 5 <$> gvsv(*a) s
83# 6 <2> sassign sKS/2
84# 7 <1> leavesub[1 ref] K/REFC,1
85EONT_EONT
86
724aa791
JC		 87#################################
88pass("B::Concise OPTION TESTS");
89
90checkOptree ( name => '-base3 sticky-exec',
91 bcopts => '-base3',
92 code => sub{$a=$b+42},
93 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
724aa791
JC		 941 <;> dbstate(main 24 optree_concise.t:132) v
952 <#> gvsv[*b] s
9610 <$> const[IV 42] s
9711 <2> add[t3] sK/2
9812 <#> gvsv[*a] s
9920 <2> sassign sKS/2
cc02ea56 10021 <1> leavesub[1 ref] K/REFC,1
724aa791 101EOT_EOT
724aa791
JC		 102# 1 <;> nextstate(main 62 optree_concise.t:161) v
103# 2 <$> gvsv(*b) s
104# 10 <$> const(IV 42) s
105# 11 <2> add[t1] sK/2
106# 12 <$> gvsv(*a) s
107# 20 <2> sassign sKS/2
108# 21 <1> leavesub[1 ref] K/REFC,1
109EONT_EONT
110
111checkOptree ( name => 'sticky-base3, -basic over sticky-exec',
112 bcopts => '-basic',
113 code => sub{$a=$b+42},
114 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
11521 <1> leavesub[1 ref] K/REFC,1 ->(end)
116- <@> lineseq KP ->21
1171 <;> nextstate(main 32 optree_concise.t:164) v ->2
11820 <2> sassign sKS/2 ->21
11911 <2> add[t3] sK/2 ->12
120- <1> ex-rv2sv sK/1 ->10
1212 <#> gvsv[*b] s ->10
12210 <$> const[IV 42] s ->11
123- <1> ex-rv2sv sKRM*/1 ->20
12412 <#> gvsv[*a] s ->20
125EOT_EOT
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
136EONT_EONT
137
138checkOptree ( name => '-base4',
139 bcopts => [qw/ -basic -base4 /],
140 code => sub{$a=$b+42},
141 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
14213 <1> leavesub[1 ref] K/REFC,1 ->(end)
143- <@> lineseq KP ->13
1441 <;> nextstate(main 26 optree_concise.t:145) v ->2
14512 <2> sassign sKS/2 ->13
14610 <2> add[t3] sK/2 ->11
147- <1> ex-rv2sv sK/1 ->3
1482 <#> gvsv[*b] s ->3
1493 <$> const[IV 42] s ->10
150- <1> ex-rv2sv sKRM*/1 ->12
15111 <#> gvsv[*a] s ->12
152EOT_EOT
153# 13 <1> leavesub[1 ref] K/REFC,1 ->(end)
154# - <@> lineseq KP ->13
155# 1 <;> nextstate(main 64 optree_concise.t:193) v ->2
156# 12 <2> sassign sKS/2 ->13
157# 10 <2> add[t1] sK/2 ->11
158# - <1> ex-rv2sv sK/1 ->3
159# 2 <$> gvsv(*b) s ->3
160# 3 <$> const(IV 42) s ->10
161# - <1> ex-rv2sv sKRM*/1 ->12
162# 11 <$> gvsv(*a) s ->12
163EONT_EONT
164
165checkOptree ( name => "restore -base36 default",
166 bcopts => [qw/ -basic -base36 /],
167 code => sub{$a},
168 crossfail => 1,
169 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
1703 <1> leavesub[1 ref] K/REFC,1 ->(end)
171- <@> lineseq KP ->3
1721 <;> nextstate(main 27 optree_concise.t:161) v ->2
173- <1> ex-rv2sv sK/1 ->-
1742 <#> gvsv[*a] s ->3
175EOT_EOT
176# 3 <1> leavesub[1 ref] K/REFC,1 ->(end)
177# - <@> lineseq KP ->3
178# 1 <;> nextstate(main 65 optree_concise.t:210) v ->2
179# - <1> ex-rv2sv sK/1 ->-
180# 2 <$> gvsv(*a) s ->3
181EONT_EONT
182
183checkOptree ( name => "terse basic",
184 bcopts => [qw/ -basic -terse /],
185 code => sub{$a},
186 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
187UNOP (0x82b0918) leavesub [1]
188 LISTOP (0x82b08d8) lineseq
189 COP (0x82b0880) nextstate
190 UNOP (0x82b0860) null [15]
191 PADOP (0x82b0840) gvsv GV (0x82a818c) *a
192EOT_EOT
193# UNOP (0x8282310) leavesub [1]
194# LISTOP (0x82822f0) lineseq
195# COP (0x82822b8) nextstate
196# UNOP (0x812fc20) null [15]
197# SVOP (0x812fc00) gvsv GV (0x814692c) *a
198EONT_EONT
199
200checkOptree ( name => "sticky-terse exec",
201 bcopts => [qw/ -exec /],
202 code => sub{$a},
203 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
724aa791
JC		 204COP (0x82b0d70) nextstate
205PADOP (0x82b0d30) gvsv GV (0x82a818c) *a
206UNOP (0x82b0e08) leavesub [1]
207EOT_EOT
724aa791
JC		 208# COP (0x82828e0) nextstate
209# SVOP (0x82828a0) gvsv GV (0x814692c) *a
210# UNOP (0x8282938) leavesub [1]
211EONT_EONT
212
213pass("OPTIONS IN CMDLINE MODE");
214
215checkOptree ( name => 'cmdline invoke -basic works',
216 prog => 'sort @a',
217 #bcopts => '-basic', # default
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 bcopts => '-exec',
239 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
2401 <0> enter
2412 <;> nextstate(main 1 -e:1) v
2423 <0> pushmark s
2434 <#> gv[*a] s
2445 <1> rv2av[t2] lK/1
2456 <@> sort vK
2467 <@> leave[1 ref] vKP/REFC
247EOT_EOT
248# 1 <0> enter
249# 2 <;> nextstate(main 1 -e:1) v
250# 3 <0> pushmark s
251# 4 <$> gv(*a) s
252# 5 <1> rv2av[t1] lK/1
253# 6 <@> sort vK
254# 7 <@> leave[1 ref] vKP/REFC
255EONT_EONT
256
5e251bf1
JC		 257;
258$DB::single=1;
259checkOptree
260 ( name => 'cmdline self-strict compile err using prog',
261 prog => 'use strict; sort @a',
262 bcopts => [qw/ -basic -concise -exec /],
263 errs => 'Global symbol "@a" requires explicit package name at .*? line 1.',
264 );
724aa791 265
5e251bf1
JC		 266checkOptree
267 ( name => 'cmdline self-strict compile err using code',
268 code => 'use strict; sort @a',
269 bcopts => [qw/ -basic -concise -exec /],
270 #noanchors => 1,
271 errs => 'Global symbol "@a" requires explicit package name at .*? line 1.',
272 );
724aa791 273
5e251bf1
JC		 274checkOptree
275 ( name => 'useless use of sort in void context',
276 prog => 'our @a; sort @a',
277 bcopts => [qw/ -basic -concise -exec /],
278 errs => 'Useless use of sort in void context at -e line 1.',
279 );
280
281checkOptree
282 ( name => 'cmdline -basic -concise -exec works',
283 prog => 'our @a; sort @a',
284 bcopts => [qw/ -basic -concise -exec /],
285 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
724aa791
JC		 286# 1 <0> enter
287# 2 <;> nextstate(main 1 -e:1) v
288# 3 <#> gv[*a] s
289# 4 <1> rv2av[t3] vK/OURINTR,1
290# 5 <;> nextstate(main 2 -e:1) v
291# 6 <0> pushmark s
292# 7 <#> gv[*a] s
293# 8 <1> rv2av[t5] lK/1
294# 9 <@> sort vK
295# a <@> leave[1 ref] vKP/REFC
296EOT_EOT
297# 1 <0> enter
298# 2 <;> nextstate(main 1 -e:1) v
299# 3 <$> gv(*a) s
300# 4 <1> rv2av[t2] vK/OURINTR,1
301# 5 <;> nextstate(main 2 -e:1) v
302# 6 <0> pushmark s
303# 7 <$> gv(*a) s
304# 8 <1> rv2av[t3] lK/1
305# 9 <@> sort vK
306# a <@> leave[1 ref] vKP/REFC
307EONT_EONT
308
309
310#################################
311pass("B::Concise STYLE/CALLBACK TESTS");
312
313use B::Concise qw( walk_output add_style set_style_standard add_callback );
314
315# new relative style, added by set_up_relative_test()
316@stylespec =
317 ( "#hyphseq2 (*( (x( ;)x))*)<#classsym> "
318 . "#exname#arg(?([#targarglife])?)~#flags(?(/#privateb)?)(x(;~->#next)x) "
319 . "(x(;~=> #extra)x)\n" # new 'variable' used here
320
321 , " (*( )*) goto #seq\n"
cc02ea56 322 , "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"
724aa791
JC		 323 #. "(x(;~=> #extra)x)\n" # new 'variable' used here
324 );
325
326sub set_up_relative_test {
327 # add a new style, and a callback which adds an 'extra' property
328
329 add_style ( "relative" => @stylespec );
330 #set_style_standard ( "relative" );
331
332 add_callback
333 ( sub {
334 my ($h, $op, $format, $level, $style) = @_;
335
336 # callback marks up const ops
337 $h->{arg} .= ' CALLBACK' if $h->{name} eq 'const';
338 $h->{extra} = '';
339
cc02ea56
JC		 340 if ($lastnext and $$lastnext != $$op) {
341 $h->{goto} = ($h->{seq} eq '-')
342 ? 'unresolved' : $h->{seq};
343 }
344
724aa791
JC		 345 # 2 style specific behaviors
346 if ($style eq 'relative') {
347 $h->{extra} = 'RELATIVE';
348 $h->{arg} .= ' RELATIVE' if $h->{name} eq 'leavesub';
349 }
350 elsif ($style eq 'scope') {
351 # supress printout entirely
352 $$format="" unless grep { $h->{name} eq $_ } @scopeops;
353 }
354 });
355}
356
357#################################
358set_up_relative_test();
359pass("set_up_relative_test, new callback installed");
360
361checkOptree ( name => 'callback used, independent of style',
362 bcopts => [qw/ -concise -exec /],
363 code => sub{$a=$b+42},
364 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
724aa791
JC		 3651 <;> nextstate(main 76 optree_concise.t:337) v
3662 <#> gvsv[*b] s
3673 <$> const[IV 42] CALLBACK s
3684 <2> add[t3] sK/2
3695 <#> gvsv[*a] s
3706 <2> sassign sKS/2
3717 <1> leavesub[1 ref] K/REFC,1
372EOT_EOT
373# 1 <;> nextstate(main 455 optree_concise.t:328) v
374# 2 <$> gvsv(*b) s
375# 3 <$> const(IV 42) CALLBACK s
376# 4 <2> add[t1] sK/2
377# 5 <$> gvsv(*a) s
378# 6 <2> sassign sKS/2
379# 7 <1> leavesub[1 ref] K/REFC,1
380EONT_EONT
381
382checkOptree ( name => "new 'relative' style, -exec mode",
383 bcopts => [qw/ -basic -relative /],
384 code => sub{$a=$b+42},
385 crossfail => 1,
386 #retry => 1,
387 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
cc02ea56
JC		 3887 <1> leavesub RELATIVE[1 ref] K ->(end) => RELATIVE
389- <@> lineseq KP ->7 => RELATIVE
3901 <;> nextstate(main 49 optree_concise.t:309) v ->2 => RELATIVE
3916 <2> sassign sKS ->7 => RELATIVE
3924 <2> add[t3] sK ->5 => RELATIVE
393- <1> ex-rv2sv sK ->3 => RELATIVE
3942 <#> gvsv[*b] s ->3 => RELATIVE
3953 <$> const[IV 42] CALLBACK s ->4 => RELATIVE
396- <1> ex-rv2sv sKRM* ->6 => RELATIVE
3975 <#> gvsv[*a] s ->6 => RELATIVE
724aa791 398EOT_EOT
cc02ea56
JC		 399# 7 <1> leavesub RELATIVE[1 ref] K ->(end) => RELATIVE
400# - <@> lineseq KP ->7 => RELATIVE
401# 1 <;> nextstate(main 77 optree_concise.t:353) v ->2 => RELATIVE
402# 6 <2> sassign sKS ->7 => RELATIVE
403# 4 <2> add[t1] sK ->5 => RELATIVE
404# - <1> ex-rv2sv sK ->3 => RELATIVE
405# 2 <$> gvsv(*b) s ->3 => RELATIVE
406# 3 <$> const(IV 42) CALLBACK s ->4 => RELATIVE
407# - <1> ex-rv2sv sKRM* ->6 => RELATIVE
408# 5 <$> gvsv(*a) s ->6 => RELATIVE
724aa791
JC		 409EONT_EONT
410
411checkOptree ( name => "both -exec -relative",
412 bcopts => [qw/ -exec -relative /],
413 code => sub{$a=$b+42},
414 crossfail => 1,
415 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
724aa791
JC		 4161 <;> nextstate(main 50 optree_concise.t:326) v
4172 <#> gvsv[*b] s
4183 <$> const[IV 42] CALLBACK s
4194 <2> add[t3] sK
4205 <#> gvsv[*a] s
4216 <2> sassign sKS
4227 <1> leavesub RELATIVE[1 ref] K
423EOT_EOT
424# 1 <;> nextstate(main 78 optree_concise.t:371) v
425# 2 <$> gvsv(*b) s
426# 3 <$> const(IV 42) CALLBACK s
427# 4 <2> add[t1] sK
428# 5 <$> gvsv(*a) s
429# 6 <2> sassign sKS
430# 7 <1> leavesub RELATIVE[1 ref] K
431EONT_EONT
432
433#################################
434
435@scopeops = qw( leavesub enter leave nextstate );
436add_style
437 ( 'scope' # concise copy
438 , "#hyphseq2 (*( (x( ;)x))*)<#classsym> "
439 . "#exname#arg(?([#targarglife])?)~#flags(?(/#private)?)(x(;~->#next)x) "
440 , " (*( )*) goto #seq\n"
441 , "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"
442 );
443
444checkOptree ( name => "both -exec -scope",
445 bcopts => [qw/ -exec -scope /],
446 code => sub{$a=$b+42},
447 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
724aa791
JC		 4481 <;> nextstate(main 50 optree_concise.t:337) v
4497 <1> leavesub[1 ref] K/REFC,1
450EOT_EOT
724aa791
JC		 4511 <;> nextstate(main 75 optree_concise.t:396) v
4527 <1> leavesub[1 ref] K/REFC,1
453EONT_EONT
454
455
456checkOptree ( name => "both -basic -scope",
457 bcopts => [qw/ -basic -scope /],
458 code => sub{$a=$b+42},
459 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
4607 <1> leavesub[1 ref] K/REFC,1 ->(end)
4611 <;> nextstate(main 51 optree_concise.t:347) v ->2
462EOT_EOT
4637 <1> leavesub[1 ref] K/REFC,1 ->(end)
4641 <;> nextstate(main 76 optree_concise.t:407) v ->2
465EONT_EONT
466
2ce64696 467} #skip
724aa791 468
Unnamed repository; edit this file 'description' to name the repository.