ext/B/t/optree_concise.t

   1 #!perl
   2
   3 BEGIN {
   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)
  20 use OptreeCheck;        # ALSO DOES @ARGV HANDLING !!!!!!
  21 use Config;
  22
  23 my $tests = 23;
  24 plan tests => $tests;
  25 SKIP: {
  26 skip "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 #################################
  33 pass("CANONICAL B::Concise EXAMPLE");
  34
  35 checkOptree ( 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
  50 EOT_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
  61 EONT_EONT
  62
  63 checkOptree ( 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
  75 EOT_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
  83 EONT_EONT
  84
  85 #################################
  86 pass("B::Concise OPTION TESTS");
  87
  88 checkOptree ( 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');
  93 1  <;> dbstate(main 24 optree_concise.t:132) v:>,<,%,{
  94 2  <#> gvsv[*b] s
  95 10 <$> const[IV 42] s
  96 11 <2> add[t3] sK/2
  97 12 <#> gvsv[*a] s
  98 20 <2> sassign sKS/2
  99 21 <1> leavesub[1 ref] K/REFC,1
 100 EOT_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
 108 EONT_EONT
 109
 110 checkOptree ( 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');
 115 21 <1> leavesub[1 ref] K/REFC,1 ->(end)
 116 -     <@> lineseq KP ->21
 117 1        <;> nextstate(main 32 optree_concise.t:164) v:>,<,%,{ ->2
 118 20       <2> sassign sKS/2 ->21
 119 11          <2> add[t3] 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
 125 EOT_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
 136 EONT_EONT
 137
 138 checkOptree ( 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');
 143 13 <1> leavesub[1 ref] K/REFC,1 ->(end)
 144 -     <@> lineseq KP ->13
 145 1        <;> nextstate(main 26 optree_concise.t:145) v:>,<,%,{ ->2
 146 12       <2> sassign sKS/2 ->13
 147 10          <2> add[t3] 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
 153 EOT_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
 164 EONT_EONT
 165
 166 checkOptree ( 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');
 172 3  <1> leavesub[1 ref] K/REFC,1 ->(end)
 173 -     <@> lineseq KP ->3
 174 1        <;> nextstate(main 27 optree_concise.t:161) v:>,<,% ->2
 175 -        <1> ex-rv2sv sK/1 ->-
 176 2           <#> gvsv[*a] s ->3
 177 EOT_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
 183 EONT_EONT
 184
 185 checkOptree ( name      => "terse basic",
 186               bcopts    => [qw/ -basic -terse /],
 187               code      => sub{$a},
 188               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 189 UNOP (0x82b0918) leavesub [1]
 190     LISTOP (0x82b08d8) lineseq
 191         COP (0x82b0880) nextstate
 192         UNOP (0x82b0860) null [15]
 193             PADOP (0x82b0840) gvsv  GV (0x82a818c) *a
 194 EOT_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
 200 EONT_EONT
 201
 202 checkOptree ( name      => "sticky-terse exec",
 203               bcopts    => [qw/ -exec /],
 204               code      => sub{$a},
 205               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 206 COP (0x82b0d70) nextstate
 207 PADOP (0x82b0d30) gvsv  GV (0x82a818c) *a
 208 UNOP (0x82b0e08) leavesub [1]
 209 EOT_EOT
 210 # COP (0x82828e0) nextstate
 211 # SVOP (0x82828a0) gvsv  GV (0x814692c) *a
 212 # UNOP (0x8282938) leavesub [1]
 213 EONT_EONT
 214
 215 pass("OPTIONS IN CMDLINE MODE");
 216
 217 checkOptree ( 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
 232 EOT_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
 240 EONT_EONT
 241
 242 checkOptree ( 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');
 250 1  <0> enter
 251 2  <;> nextstate(main 1 -e:1) v:>,<,%,{
 252 3  <0> pushmark s
 253 4  <#> gv[*a] s
 254 5  <1> rv2av[t2] lK/1
 255 6  <@> sort vK
 256 7  <@> leave[1 ref] vKP/REFC
 257 EOT_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
 265 EONT_EONT
 266
 267 ;
 268
 269 checkOptree
 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
 279 checkOptree
 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
 290 checkOptree
 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
 307 EOT_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
 318 EONT_EONT
 319
 320
 321 #################################
 322 pass("B::Concise STYLE/CALLBACK TESTS");
 323
 324 use 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
 337 sub 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 #################################
 369 set_up_relative_test();
 370 pass("set_up_relative_test, new callback installed");
 371
 372 checkOptree ( 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');
 377 1  <;> nextstate(main 76 optree_concise.t:337) v:>,<,%,{
 378 2  <#> gvsv[*b] s
 379 3  <$> const[IV 42] CALLBACK s
 380 4  <2> add[t3] sK/2
 381 5  <#> gvsv[*a] s
 382 6  <2> sassign sKS/2
 383 7  <1> leavesub[1 ref] K/REFC,1
 384 EOT_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
 392 EONT_EONT
 393
 394 checkOptree ( 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');
 400 7  <1> leavesub RELATIVE[1 ref] K ->(end) => RELATIVE
 401 -     <@> lineseq KP ->7 => RELATIVE
 402 1        <;> nextstate(main 49 optree_concise.t:309) v ->2 => RELATIVE
 403 6        <2> sassign sKS ->7 => RELATIVE
 404 4           <2> add[t3] sK ->5 => RELATIVE
 405 -              <1> ex-rv2sv sK ->3 => RELATIVE
 406 2                 <#> gvsv[*b] s ->3 => RELATIVE
 407 3              <$> const[IV 42] CALLBACK s ->4 => RELATIVE
 408 -           <1> ex-rv2sv sKRM* ->6 => RELATIVE
 409 5              <#> gvsv[*a] s ->6 => RELATIVE
 410 EOT_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
 421 EONT_EONT
 422
 423 checkOptree ( 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');
 428 1  <;> nextstate(main 50 optree_concise.t:326) v
 429 2  <#> gvsv[*b] s
 430 3  <$> const[IV 42] CALLBACK s
 431 4  <2> add[t3] sK
 432 5  <#> gvsv[*a] s
 433 6  <2> sassign sKS
 434 7  <1> leavesub RELATIVE[1 ref] K
 435 EOT_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
 443 EONT_EONT
 444
 445 #################################
 446
 447 @scopeops = qw( leavesub enter leave nextstate );
 448 add_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
 456 checkOptree ( name      => "both -exec -scope",
 457               bcopts    => [qw/ -exec -scope /],
 458               code      => sub{$a=$b+42},
 459               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 460 1  <;> nextstate(main 50 optree_concise.t:337) v
 461 7  <1> leavesub[1 ref] K/REFC,1
 462 EOT_EOT
 463 1  <;> nextstate(main 75 optree_concise.t:396) v
 464 7  <1> leavesub[1 ref] K/REFC,1
 465 EONT_EONT
 466
 467
 468 checkOptree ( name      => "both -basic -scope",
 469               bcopts    => [qw/ -basic -scope /],
 470               code      => sub{$a=$b+42},
 471               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 472 7  <1> leavesub[1 ref] K/REFC,1 ->(end)
 473 1        <;> nextstate(main 51 optree_concise.t:347) v ->2
 474 EOT_EOT
 475 7  <1> leavesub[1 ref] K/REFC,1 ->(end)
 476 1        <;> nextstate(main 76 optree_concise.t:407) v ->2
 477 EONT_EONT
 478
 479 } #skip
 480