ext/B/t/optree_concise.t

   1 #!perl
   2
   3 BEGIN {
   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)
  17 use OptreeCheck;        # ALSO DOES @ARGV HANDLING !!!!!!
  18 use Config;
  19
  20 plan tests => 41;
  21
  22 $SIG{__WARN__} = sub {
  23     my $err = shift;
  24     $err =~ m/Subroutine re::(un)?install redefined/ and return;
  25 };
  26 #################################
  27 pass("CANONICAL B::Concise EXAMPLE");
  28
  29 checkOptree ( 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
  44 EOT_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
  55 EONT_EONT
  56
  57 checkOptree ( 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
  69 EOT_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
  77 EONT_EONT
  78
  79 #################################
  80 pass("B::Concise OPTION TESTS");
  81
  82 checkOptree ( 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');
  87 1  <;> dbstate(main 24 optree_concise.t:132) v:>,<,%,{
  88 2  <#> gvsv[*b] s
  89 10 <$> const[IV 42] s
  90 11 <2> add[t3] sK/2
  91 12 <#> gvsv[*a] s
  92 20 <2> sassign sKS/2
  93 21 <1> leavesub[1 ref] K/REFC,1
  94 EOT_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
 102 EONT_EONT
 103
 104 checkOptree ( 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');
 109 21 <1> leavesub[1 ref] K/REFC,1 ->(end)
 110 -     <@> lineseq KP ->21
 111 1        <;> nextstate(main 32 optree_concise.t:164) v:>,<,%,{ ->2
 112 20       <2> sassign sKS/2 ->21
 113 11          <2> add[t3] sK/2 ->12
 114 -              <1> ex-rv2sv sK/1 ->10
 115 2                 <#> gvsv[*b] s ->10
 116 10             <$> const[IV 42] s ->11
 117 -           <1> ex-rv2sv sKRM*/1 ->20
 118 12             <#> gvsv[*a] s ->20
 119 EOT_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
 130 EONT_EONT
 131
 132 checkOptree ( 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');
 137 13 <1> leavesub[1 ref] K/REFC,1 ->(end)
 138 -     <@> lineseq KP ->13
 139 1        <;> nextstate(main 26 optree_concise.t:145) v:>,<,%,{ ->2
 140 12       <2> sassign sKS/2 ->13
 141 10          <2> add[t3] sK/2 ->11
 142 -              <1> ex-rv2sv sK/1 ->3
 143 2                 <#> gvsv[*b] s ->3
 144 3              <$> const[IV 42] s ->10
 145 -           <1> ex-rv2sv sKRM*/1 ->12
 146 11             <#> gvsv[*a] s ->12
 147 EOT_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
 158 EONT_EONT
 159
 160 checkOptree ( 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');
 166 3  <1> leavesub[1 ref] K/REFC,1 ->(end)
 167 -     <@> lineseq KP ->3
 168 1        <;> nextstate(main 27 optree_concise.t:161) v:>,<,% ->2
 169 -        <1> ex-rv2sv sK/1 ->-
 170 2           <#> gvsv[*a] s ->3
 171 EOT_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
 177 EONT_EONT
 178
 179 checkOptree ( name      => "terse basic",
 180               bcopts    => [qw/ -basic -terse /],
 181               code      => sub{$a},
 182               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 183 UNOP (0x82b0918) leavesub [1]
 184     LISTOP (0x82b08d8) lineseq
 185         COP (0x82b0880) nextstate
 186         UNOP (0x82b0860) null [15]
 187             PADOP (0x82b0840) gvsv  GV (0x82a818c) *a
 188 EOT_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
 194 EONT_EONT
 195
 196 checkOptree ( name      => "sticky-terse exec",
 197               bcopts    => [qw/ -exec /],
 198               code      => sub{$a},
 199               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 200 COP (0x82b0d70) nextstate
 201 PADOP (0x82b0d30) gvsv  GV (0x82a818c) *a
 202 UNOP (0x82b0e08) leavesub [1]
 203 EOT_EOT
 204 # COP (0x82828e0) nextstate
 205 # SVOP (0x82828a0) gvsv  GV (0x814692c) *a
 206 # UNOP (0x8282938) leavesub [1]
 207 EONT_EONT
 208
 209 pass("OPTIONS IN CMDLINE MODE");
 210
 211 checkOptree ( 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
 226 EOT_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
 234 EONT_EONT
 235
 236 checkOptree ( 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');
 244 1  <0> enter
 245 2  <;> nextstate(main 1 -e:1) v:>,<,%,{
 246 3  <0> pushmark s
 247 4  <#> gv[*a] s
 248 5  <1> rv2av[t2] lK/1
 249 6  <@> sort vK
 250 7  <@> leave[1 ref] vKP/REFC
 251 EOT_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
 259 EONT_EONT
 260
 261 ;
 262
 263 checkOptree
 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
 273 checkOptree
 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
 284 checkOptree
 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
 301 EOT_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
 312 EONT_EONT
 313
 314
 315 #################################
 316 pass("B::Concise STYLE/CALLBACK TESTS");
 317
 318 use 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
 331 sub 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 #################################
 363 set_up_relative_test();
 364 pass("set_up_relative_test, new callback installed");
 365
 366 checkOptree ( 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');
 371 1  <;> nextstate(main 76 optree_concise.t:337) v:>,<,%,{
 372 2  <#> gvsv[*b] s
 373 3  <$> const[IV 42] CALLBACK s
 374 4  <2> add[t3] sK/2
 375 5  <#> gvsv[*a] s
 376 6  <2> sassign sKS/2
 377 7  <1> leavesub[1 ref] K/REFC,1
 378 EOT_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
 386 EONT_EONT
 387
 388 checkOptree ( 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');
 394 7  <1> leavesub RELATIVE[1 ref] K ->(end) => RELATIVE
 395 -     <@> lineseq KP ->7 => RELATIVE
 396 1        <;> nextstate(main 49 optree_concise.t:309) v ->2 => RELATIVE
 397 6        <2> sassign sKS ->7 => RELATIVE
 398 4           <2> add[t3] sK ->5 => RELATIVE
 399 -              <1> ex-rv2sv sK ->3 => RELATIVE
 400 2                 <#> gvsv[*b] s ->3 => RELATIVE
 401 3              <$> const[IV 42] CALLBACK s ->4 => RELATIVE
 402 -           <1> ex-rv2sv sKRM* ->6 => RELATIVE
 403 5              <#> gvsv[*a] s ->6 => RELATIVE
 404 EOT_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
 415 EONT_EONT
 416
 417 checkOptree ( 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');
 422 1  <;> nextstate(main 50 optree_concise.t:326) v
 423 2  <#> gvsv[*b] s
 424 3  <$> const[IV 42] CALLBACK s
 425 4  <2> add[t3] sK
 426 5  <#> gvsv[*a] s
 427 6  <2> sassign sKS
 428 7  <1> leavesub RELATIVE[1 ref] K
 429 EOT_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
 437 EONT_EONT
 438
 439 #################################
 440
 441 @scopeops = qw( leavesub enter leave nextstate );
 442 add_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
 450 checkOptree ( name      => "both -exec -scope",
 451               bcopts    => [qw/ -exec -scope /],
 452               code      => sub{$a=$b+42},
 453               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 454 1  <;> nextstate(main 50 optree_concise.t:337) v
 455 7  <1> leavesub[1 ref] K/REFC,1
 456 EOT_EOT
 457 1  <;> nextstate(main 75 optree_concise.t:396) v
 458 7  <1> leavesub[1 ref] K/REFC,1
 459 EONT_EONT
 460
 461
 462 checkOptree ( name      => "both -basic -scope",
 463               bcopts    => [qw/ -basic -scope /],
 464               code      => sub{$a=$b+42},
 465               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 466 7  <1> leavesub[1 ref] K/REFC,1 ->(end)
 467 1        <;> nextstate(main 51 optree_concise.t:347) v ->2
 468 EOT_EOT
 469 7  <1> leavesub[1 ref] K/REFC,1 ->(end)
 470 1        <;> nextstate(main 76 optree_concise.t:407) v ->2
 471 EONT_EONT