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 [14] 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 [14] 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 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 226EOT_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 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 v 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 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 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 (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 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 (?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 286checkOptree 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 300EOT_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 308EONT_EONT 309 310 311################################# 312pass("B::Concise STYLE/CALLBACK TESTS"); 313 314use 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 327sub 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################################# 359set_up_relative_test(); 360pass("set_up_relative_test, new callback installed"); 361 362checkOptree ( 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'); 3671 <;> nextstate(main 76 optree_concise.t:337) v:>,<,%,{ 3682 <#> gvsv[*b] s 3693 <$> const[IV 42] CALLBACK s 3704 <2> add[t3] sK/2 3715 <#> gvsv[*a] s 3726 <2> sassign sKS/2 3737 <1> leavesub[1 ref] K/REFC,1 374EOT_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 382EONT_EONT 383 384checkOptree ( 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'); 3907 <1> leavesub RELATIVE[1 ref] K ->(end) => RELATIVE 391- <@> lineseq KP ->7 => RELATIVE 3921 <;> nextstate(main 49 optree_concise.t:309) v ->2 => RELATIVE 3936 <2> sassign sKS ->7 => RELATIVE 3944 <2> add[t3] sK ->5 => RELATIVE 395- <1> ex-rv2sv sK ->3 => RELATIVE 3962 <#> gvsv[*b] s ->3 => RELATIVE 3973 <$> const[IV 42] CALLBACK s ->4 => RELATIVE 398- <1> ex-rv2sv sKRM* ->6 => RELATIVE 3995 <#> gvsv[*a] s ->6 => RELATIVE 400EOT_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 411EONT_EONT 412 413checkOptree ( 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'); 4181 <;> nextstate(main 50 optree_concise.t:326) v 4192 <#> gvsv[*b] s 4203 <$> const[IV 42] CALLBACK s 4214 <2> add[t3] sK 4225 <#> gvsv[*a] s 4236 <2> sassign sKS 4247 <1> leavesub RELATIVE[1 ref] K 425EOT_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 433EONT_EONT 434 435################################# 436 437@scopeops = qw( leavesub enter leave nextstate ); 438add_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 446checkOptree ( name => "both -exec -scope", 447 bcopts => [qw/ -exec -scope /], 448 code => sub{$a=$b+42}, 449 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); 4501 <;> nextstate(main 50 optree_concise.t:337) v 4517 <1> leavesub[1 ref] K/REFC,1 452EOT_EOT 4531 <;> nextstate(main 75 optree_concise.t:396) v 4547 <1> leavesub[1 ref] K/REFC,1 455EONT_EONT 456 457 458checkOptree ( name => "both -basic -scope", 459 bcopts => [qw/ -basic -scope /], 460 code => sub{$a=$b+42}, 461 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); 4627 <1> leavesub[1 ref] K/REFC,1 ->(end) 4631 <;> nextstate(main 51 optree_concise.t:347) v ->2 464EOT_EOT 4657 <1> leavesub[1 ref] K/REFC,1 ->(end) 4661 <;> nextstate(main 76 optree_concise.t:407) v ->2 467EONT_EONT 468