1#!perl 2 3BEGIN { 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 } 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 } 16 # require 'test.pl'; # now done by OptreeCheck 17} 18 19# import checkOptree(), and %gOpts (containing test state) 20use OptreeCheck; # ALSO DOES @ARGV HANDLING !!!!!! 21use Config; 22 23my $tests = 23; 24plan tests => $tests; 25SKIP: { 26skip "no perlio in this build", $tests unless $Config::Config{useperlio}; 27 28$SIG{__WARN__} = sub { 29 my $err = shift; 30 $err =~ m/Subroutine re::(un)?install redefined/ and return; 31}; 32################################# 33pass("CANONICAL B::Concise EXAMPLE"); 34 35checkOptree ( name => 'canonical example w -basic', 36 bcopts => '-basic', 37 code => sub{$a=$b+42}, 38 strip_open_hints => 1, 39 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); 40# 7 <1> leavesub[1 ref] K/REFC,1 ->(end) 41# - <@> lineseq KP ->7 42# 1 <;> nextstate(foo bar) v:>,<,%,{ ->2 43# 6 <2> sassign sKS/2 ->7 44# 4 <2> add[t3] 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 50EOT_EOT 51# 7 <1> leavesub[1 ref] K/REFC,1 ->(end) 52# - <@> lineseq KP ->7 53# 1 <;> nextstate(main 60 optree_concise.t:122) v:>,<,%,{ ->2 54# 6 <2> sassign sKS/2 ->7 55# 4 <2> add[t1] sK/2 ->5 56# - <1> ex-rv2sv sK/1 ->3 57# 2 <$> gvsv(*b) s ->3 58# 3 <$> const(IV 42) s ->4 59# - <1> ex-rv2sv sKRM*/1 ->6 60# 5 <$> gvsv(*a) s ->6 61EONT_EONT 62 63checkOptree ( name => 'canonical example w -exec', 64 bcopts => '-exec', 65 code => sub{$a=$b+42}, 66 strip_open_hints => 1, 67 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); 68# 1 <;> nextstate(main 61 optree_concise.t:139) v:>,<,%,{ 69# 2 <#> gvsv[*b] s 70# 3 <$> const[IV 42] s 71# 4 <2> add[t3] sK/2 72# 5 <#> gvsv[*a] s 73# 6 <2> sassign sKS/2 74# 7 <1> leavesub[1 ref] K/REFC,1 75EOT_EOT 76# 1 <;> nextstate(main 61 optree_concise.t:139) v:>,<,%,{ 77# 2 <$> gvsv(*b) s 78# 3 <$> const(IV 42) s 79# 4 <2> add[t1] sK/2 80# 5 <$> gvsv(*a) s 81# 6 <2> sassign sKS/2 82# 7 <1> leavesub[1 ref] K/REFC,1 83EONT_EONT 84 85################################# 86pass("B::Concise OPTION TESTS"); 87 88checkOptree ( name => '-base3 sticky-exec', 89 bcopts => '-base3', 90 code => sub{$a=$b+42}, 91 strip_open_hints => 1, 92 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); 931 <;> dbstate(main 24 optree_concise.t:132) v:>,<,%,{ 942 <#> gvsv[*b] s 9510 <$> const[IV 42] s 9611 <2> add[t3] sK/2 9712 <#> gvsv[*a] s 9820 <2> sassign sKS/2 9921 <1> leavesub[1 ref] K/REFC,1 100EOT_EOT 101# 1 <;> nextstate(main 62 optree_concise.t:161) v:>,<,%,{ 102# 2 <$> gvsv(*b) s 103# 10 <$> const(IV 42) s 104# 11 <2> add[t1] sK/2 105# 12 <$> gvsv(*a) s 106# 20 <2> sassign sKS/2 107# 21 <1> leavesub[1 ref] K/REFC,1 108EONT_EONT 109 110checkOptree ( name => 'sticky-base3, -basic over sticky-exec', 111 bcopts => '-basic', 112 code => sub{$a=$b+42}, 113 strip_open_hints => 1, 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 strip_open_hints => 1, 142 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); 14313 <1> leavesub[1 ref] K/REFC,1 ->(end) 144- <@> lineseq KP ->13 1451 <;> nextstate(main 26 optree_concise.t:145) v:>,<,%,{ ->2 14612 <2> sassign sKS/2 ->13 14710 <2> add[t3] sK/2 ->11 148- <1> ex-rv2sv sK/1 ->3 1492 <#> gvsv[*b] s ->3 1503 <$> const[IV 42] s ->10 151- <1> ex-rv2sv sKRM*/1 ->12 15211 <#> gvsv[*a] s ->12 153EOT_EOT 154# 13 <1> leavesub[1 ref] K/REFC,1 ->(end) 155# - <@> lineseq KP ->13 156# 1 <;> nextstate(main 64 optree_concise.t:193) v:>,<,%,{ ->2 157# 12 <2> sassign sKS/2 ->13 158# 10 <2> add[t1] sK/2 ->11 159# - <1> ex-rv2sv sK/1 ->3 160# 2 <$> gvsv(*b) s ->3 161# 3 <$> const(IV 42) s ->10 162# - <1> ex-rv2sv sKRM*/1 ->12 163# 11 <$> gvsv(*a) s ->12 164EONT_EONT 165 166checkOptree ( name => "restore -base36 default", 167 bcopts => [qw/ -basic -base36 /], 168 code => sub{$a}, 169 crossfail => 1, 170 strip_open_hints => 1, 171 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); 1723 <1> leavesub[1 ref] K/REFC,1 ->(end) 173- <@> lineseq KP ->3 1741 <;> nextstate(main 27 optree_concise.t:161) v:>,<,% ->2 175- <1> ex-rv2sv sK/1 ->- 1762 <#> gvsv[*a] s ->3 177EOT_EOT 178# 3 <1> leavesub[1 ref] K/REFC,1 ->(end) 179# - <@> lineseq KP ->3 180# 1 <;> nextstate(main 65 optree_concise.t:210) v:>,<,% ->2 181# - <1> ex-rv2sv sK/1 ->- 182# 2 <$> gvsv(*a) s ->3 183EONT_EONT 184 185checkOptree ( name => "terse basic", 186 bcopts => [qw/ -basic -terse /], 187 code => sub{$a}, 188 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); 189UNOP (0x82b0918) leavesub [1] 190 LISTOP (0x82b08d8) lineseq 191 COP (0x82b0880) nextstate 192 UNOP (0x82b0860) null [15] 193 PADOP (0x82b0840) gvsv GV (0x82a818c) *a 194EOT_EOT 195# UNOP (0x8282310) leavesub [1] 196# LISTOP (0x82822f0) lineseq 197# COP (0x82822b8) nextstate 198# UNOP (0x812fc20) null [15] 199# SVOP (0x812fc00) gvsv GV (0x814692c) *a 200EONT_EONT 201 202checkOptree ( name => "sticky-terse exec", 203 bcopts => [qw/ -exec /], 204 code => sub{$a}, 205 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); 206COP (0x82b0d70) nextstate 207PADOP (0x82b0d30) gvsv GV (0x82a818c) *a 208UNOP (0x82b0e08) leavesub [1] 209EOT_EOT 210# COP (0x82828e0) nextstate 211# SVOP (0x82828a0) gvsv GV (0x814692c) *a 212# UNOP (0x8282938) leavesub [1] 213EONT_EONT 214 215pass("OPTIONS IN CMDLINE MODE"); 216 217checkOptree ( name => 'cmdline invoke -basic works', 218 prog => 'sort @a', 219 errs => [ 'Useless use of sort in void context at -e line 1.', 220 'Name "main::a" used only once: possible typo at -e line 1.', 221 ], 222 #bcopts => '-basic', # default 223 strip_open_hints => 1, 224 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); 225# 7 <@> leave[1 ref] vKP/REFC ->(end) 226# 1 <0> enter ->2 227# 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ ->3 228# 6 <@> sort vK ->7 229# 3 <0> pushmark s ->4 230# 5 <1> rv2av[t2] lK/1 ->6 231# 4 <#> gv[*a] s ->5 232EOT_EOT 233# 7 <@> leave[1 ref] vKP/REFC ->(end) 234# 1 <0> enter ->2 235# 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ ->3 236# 6 <@> sort vK ->7 237# 3 <0> pushmark s ->4 238# 5 <1> rv2av[t1] lK/1 ->6 239# 4 <$> gv(*a) s ->5 240EONT_EONT 241 242checkOptree ( name => 'cmdline invoke -exec works', 243 prog => 'sort @a', 244 errs => [ 'Useless use of sort in void context at -e line 1.', 245 'Name "main::a" used only once: possible typo at -e line 1.', 246 ], 247 bcopts => '-exec', 248 strip_open_hints => 1, 249 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); 2501 <0> enter 2512 <;> nextstate(main 1 -e:1) v:>,<,%,{ 2523 <0> pushmark s 2534 <#> gv[*a] s 2545 <1> rv2av[t2] lK/1 2556 <@> sort vK 2567 <@> leave[1 ref] vKP/REFC 257EOT_EOT 258# 1 <0> enter 259# 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ 260# 3 <0> pushmark s 261# 4 <$> gv(*a) s 262# 5 <1> rv2av[t1] lK/1 263# 6 <@> sort vK 264# 7 <@> leave[1 ref] vKP/REFC 265EONT_EONT 266 267; 268 269checkOptree 270 ( name => 'cmdline self-strict compile err using prog', 271 prog => 'use strict; sort @a', 272 bcopts => [qw/ -basic -concise -exec /], 273 errs => 'Global symbol "@a" requires explicit package name at -e line 1.', 274 expect => 'nextstate', 275 expect_nt => 'nextstate', 276 noanchors => 1, # allow simple expectations to work 277 ); 278 279checkOptree 280 ( name => 'cmdline self-strict compile err using code', 281 code => 'use strict; sort @a', 282 bcopts => [qw/ -basic -concise -exec /], 283 errs => 'Global symbol "@a" requires explicit package name at .*? line 1.', 284 note => 'this test relys on a kludge which copies $@ to rendering when empty', 285 expect => 'Global symbol', 286 expect_nt => 'Global symbol', 287 noanchors => 1, # allow simple expectations to work 288 ); 289 290checkOptree 291 ( name => 'cmdline -basic -concise -exec works', 292 prog => 'our @a; sort @a', 293 bcopts => [qw/ -basic -concise -exec /], 294 errs => ['Useless use of sort in void context at -e line 1.'], 295 strip_open_hints => 1, 296 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); 297# 1 <0> enter 298# 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ 299# 3 <#> gv[*a] s 300# 4 <1> rv2av[t3] 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[t5] lK/1 305# 9 <@> sort vK 306# a <@> leave[1 ref] vKP/REFC 307EOT_EOT 308# 1 <0> enter 309# 2 <;> nextstate(main 1 -e:1) v:>,<,%,{ 310# 3 <$> gv(*a) s 311# 4 <1> rv2av[t2] vK/OURINTR,1 312# 5 <;> nextstate(main 2 -e:1) v:>,<,%,{ 313# 6 <0> pushmark s 314# 7 <$> gv(*a) s 315# 8 <1> rv2av[t3] lK/1 316# 9 <@> sort vK 317# a <@> leave[1 ref] vKP/REFC 318EONT_EONT 319 320 321################################# 322pass("B::Concise STYLE/CALLBACK TESTS"); 323 324use B::Concise qw( walk_output add_style set_style_standard add_callback ); 325 326# new relative style, added by set_up_relative_test() 327@stylespec = 328 ( "#hyphseq2 (*( (x( ;)x))*)<#classsym> " 329 . "#exname#arg(?([#targarglife])?)~#flags(?(/#privateb)?)(x(;~->#next)x) " 330 . "(x(;~=> #extra)x)\n" # new 'variable' used here 331 332 , " (*( )*) goto #seq\n" 333 , "(?(<#seq>)?)#exname#arg(?([#targarglife])?)" 334 #. "(x(;~=> #extra)x)\n" # new 'variable' used here 335 ); 336 337sub set_up_relative_test { 338 # add a new style, and a callback which adds an 'extra' property 339 340 add_style ( "relative" => @stylespec ); 341 #set_style_standard ( "relative" ); 342 343 add_callback 344 ( sub { 345 my ($h, $op, $format, $level, $style) = @_; 346 347 # callback marks up const ops 348 $h->{arg} .= ' CALLBACK' if $h->{name} eq 'const'; 349 $h->{extra} = ''; 350 351 if ($lastnext and $$lastnext != $$op) { 352 $h->{goto} = ($h->{seq} eq '-') 353 ? 'unresolved' : $h->{seq}; 354 } 355 356 # 2 style specific behaviors 357 if ($style eq 'relative') { 358 $h->{extra} = 'RELATIVE'; 359 $h->{arg} .= ' RELATIVE' if $h->{name} eq 'leavesub'; 360 } 361 elsif ($style eq 'scope') { 362 # supress printout entirely 363 $$format="" unless grep { $h->{name} eq $_ } @scopeops; 364 } 365 }); 366} 367 368################################# 369set_up_relative_test(); 370pass("set_up_relative_test, new callback installed"); 371 372checkOptree ( name => 'callback used, independent of style', 373 bcopts => [qw/ -concise -exec /], 374 code => sub{$a=$b+42}, 375 strip_open_hints => 1, 376 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); 3771 <;> nextstate(main 76 optree_concise.t:337) v:>,<,%,{ 3782 <#> gvsv[*b] s 3793 <$> const[IV 42] CALLBACK s 3804 <2> add[t3] sK/2 3815 <#> gvsv[*a] s 3826 <2> sassign sKS/2 3837 <1> leavesub[1 ref] K/REFC,1 384EOT_EOT 385# 1 <;> nextstate(main 455 optree_concise.t:328) v:>,<,%,{ 386# 2 <$> gvsv(*b) s 387# 3 <$> const(IV 42) CALLBACK s 388# 4 <2> add[t1] sK/2 389# 5 <$> gvsv(*a) s 390# 6 <2> sassign sKS/2 391# 7 <1> leavesub[1 ref] K/REFC,1 392EONT_EONT 393 394checkOptree ( name => "new 'relative' style, -exec mode", 395 bcopts => [qw/ -basic -relative /], 396 code => sub{$a=$b+42}, 397 crossfail => 1, 398 #retry => 1, 399 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); 4007 <1> leavesub RELATIVE[1 ref] K ->(end) => RELATIVE 401- <@> lineseq KP ->7 => RELATIVE 4021 <;> nextstate(main 49 optree_concise.t:309) v ->2 => RELATIVE 4036 <2> sassign sKS ->7 => RELATIVE 4044 <2> add[t3] sK ->5 => RELATIVE 405- <1> ex-rv2sv sK ->3 => RELATIVE 4062 <#> gvsv[*b] s ->3 => RELATIVE 4073 <$> const[IV 42] CALLBACK s ->4 => RELATIVE 408- <1> ex-rv2sv sKRM* ->6 => RELATIVE 4095 <#> gvsv[*a] s ->6 => RELATIVE 410EOT_EOT 411# 7 <1> leavesub RELATIVE[1 ref] K ->(end) => RELATIVE 412# - <@> lineseq KP ->7 => RELATIVE 413# 1 <;> nextstate(main 77 optree_concise.t:353) v ->2 => RELATIVE 414# 6 <2> sassign sKS ->7 => RELATIVE 415# 4 <2> add[t1] sK ->5 => RELATIVE 416# - <1> ex-rv2sv sK ->3 => RELATIVE 417# 2 <$> gvsv(*b) s ->3 => RELATIVE 418# 3 <$> const(IV 42) CALLBACK s ->4 => RELATIVE 419# - <1> ex-rv2sv sKRM* ->6 => RELATIVE 420# 5 <$> gvsv(*a) s ->6 => RELATIVE 421EONT_EONT 422 423checkOptree ( name => "both -exec -relative", 424 bcopts => [qw/ -exec -relative /], 425 code => sub{$a=$b+42}, 426 crossfail => 1, 427 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); 4281 <;> nextstate(main 50 optree_concise.t:326) v 4292 <#> gvsv[*b] s 4303 <$> const[IV 42] CALLBACK s 4314 <2> add[t3] sK 4325 <#> gvsv[*a] s 4336 <2> sassign sKS 4347 <1> leavesub RELATIVE[1 ref] K 435EOT_EOT 436# 1 <;> nextstate(main 78 optree_concise.t:371) v 437# 2 <$> gvsv(*b) s 438# 3 <$> const(IV 42) CALLBACK s 439# 4 <2> add[t1] sK 440# 5 <$> gvsv(*a) s 441# 6 <2> sassign sKS 442# 7 <1> leavesub RELATIVE[1 ref] K 443EONT_EONT 444 445################################# 446 447@scopeops = qw( leavesub enter leave nextstate ); 448add_style 449 ( 'scope' # concise copy 450 , "#hyphseq2 (*( (x( ;)x))*)<#classsym> " 451 . "#exname#arg(?([#targarglife])?)~#flags(?(/#private)?)(x(;~->#next)x) " 452 , " (*( )*) goto #seq\n" 453 , "(?(<#seq>)?)#exname#arg(?([#targarglife])?)" 454 ); 455 456checkOptree ( name => "both -exec -scope", 457 bcopts => [qw/ -exec -scope /], 458 code => sub{$a=$b+42}, 459 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); 4601 <;> nextstate(main 50 optree_concise.t:337) v 4617 <1> leavesub[1 ref] K/REFC,1 462EOT_EOT 4631 <;> nextstate(main 75 optree_concise.t:396) v 4647 <1> leavesub[1 ref] K/REFC,1 465EONT_EONT 466 467 468checkOptree ( name => "both -basic -scope", 469 bcopts => [qw/ -basic -scope /], 470 code => sub{$a=$b+42}, 471 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); 4727 <1> leavesub[1 ref] K/REFC,1 ->(end) 4731 <;> nextstate(main 51 optree_concise.t:347) v ->2 474EOT_EOT 4757 <1> leavesub[1 ref] K/REFC,1 ->(end) 4761 <;> nextstate(main 76 optree_concise.t:407) v ->2 477EONT_EONT 478 479} #skip 480 481