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     if ($Config::Config{'extensions'} !~ /\bData\/Dumper\b/) {
  17         print
  18             "1..0 # Skip: Data::Dumper was not built, needed by OptreeCheck\n";
  19         exit 0;
  20     }
  21     require 'test.pl';
  22 }
  23
  24 # import checkOptree(), and %gOpts (containing test state)
  25 use OptreeCheck;        # ALSO DOES @ARGV HANDLING !!!!!!
  26 use Config;
  27
  28 plan tests => 24;
  29 SKIP: {
  30 skip "no perlio in this build", 24 unless $Config::Config{useperlio};
  31
  32 $SIG{__WARN__} = sub {
  33     my $err = shift;
  34     $err =~ m/Subroutine re::(un)?install redefined/ and return;
  35 };
  36 #################################
  37 pass("CANONICAL B::Concise EXAMPLE");
  38
  39 checkOptree ( 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
  53 EOT_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
  64 EONT_EONT
  65
  66 checkOptree ( name      => 'canonical example w -exec',
  67               bcopts    => '-exec',
  68               code      => sub{$a=$b+42},
  69               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
  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
  77 EOT_EOT
  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
  85 EONT_EONT
  86
  87 #################################
  88 pass("B::Concise OPTION TESTS");
  89
  90 checkOptree ( name      => '-base3 sticky-exec',
  91               bcopts    => '-base3',
  92               code      => sub{$a=$b+42},
  93               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
  94 1  <;> dbstate(main 24 optree_concise.t:132) v
  95 2  <#> gvsv[*b] s
  96 10 <$> const[IV 42] s
  97 11 <2> add[t3] sK/2
  98 12 <#> gvsv[*a] s
  99 20 <2> sassign sKS/2
 100 21 <1> leavesub[1 ref] K/REFC,1
 101 EOT_EOT
 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
 109 EONT_EONT
 110
 111 checkOptree ( name      => 'sticky-base3, -basic over sticky-exec',
 112               bcopts    => '-basic',
 113               code      => sub{$a=$b+42},
 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               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 142 13 <1> leavesub[1 ref] K/REFC,1 ->(end)
 143 -     <@> lineseq KP ->13
 144 1        <;> nextstate(main 26 optree_concise.t:145) v ->2
 145 12       <2> sassign sKS/2 ->13
 146 10          <2> add[t3] sK/2 ->11
 147 -              <1> ex-rv2sv sK/1 ->3
 148 2                 <#> gvsv[*b] s ->3
 149 3              <$> const[IV 42] s ->10
 150 -           <1> ex-rv2sv sKRM*/1 ->12
 151 11             <#> gvsv[*a] s ->12
 152 EOT_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
 163 EONT_EONT
 164
 165 checkOptree ( name      => "restore -base36 default",
 166               bcopts    => [qw/ -basic -base36 /],
 167               code      => sub{$a},
 168               crossfail => 1,
 169               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 170 3  <1> leavesub[1 ref] K/REFC,1 ->(end)
 171 -     <@> lineseq KP ->3
 172 1        <;> nextstate(main 27 optree_concise.t:161) v ->2
 173 -        <1> ex-rv2sv sK/1 ->-
 174 2           <#> gvsv[*a] s ->3
 175 EOT_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
 181 EONT_EONT
 182
 183 checkOptree ( name      => "terse basic",
 184               bcopts    => [qw/ -basic -terse /],
 185               code      => sub{$a},
 186               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 187 UNOP (0x82b0918) leavesub [1]
 188     LISTOP (0x82b08d8) lineseq
 189         COP (0x82b0880) nextstate
 190         UNOP (0x82b0860) null [15]
 191             PADOP (0x82b0840) gvsv  GV (0x82a818c) *a
 192 EOT_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
 198 EONT_EONT
 199
 200 checkOptree ( name      => "sticky-terse exec",
 201               bcopts    => [qw/ -exec /],
 202               code      => sub{$a},
 203               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 204 COP (0x82b0d70) nextstate
 205 PADOP (0x82b0d30) gvsv  GV (0x82a818c) *a
 206 UNOP (0x82b0e08) leavesub [1]
 207 EOT_EOT
 208 # COP (0x82828e0) nextstate
 209 # SVOP (0x82828a0) gvsv  GV (0x814692c) *a
 210 # UNOP (0x8282938) leavesub [1]
 211 EONT_EONT
 212
 213 pass("OPTIONS IN CMDLINE MODE");
 214
 215 checkOptree ( 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
 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               bcopts    => '-exec',
 239               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 240 1  <0> enter
 241 2  <;> nextstate(main 1 -e:1) v
 242 3  <0> pushmark s
 243 4  <#> gv[*a] s
 244 5  <1> rv2av[t2] lK/1
 245 6  <@> sort vK
 246 7  <@> leave[1 ref] vKP/REFC
 247 EOT_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
 255 EONT_EONT
 256
 257 ;
 258 $DB::single=1;
 259 checkOptree
 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       );
 265
 266 checkOptree
 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       );
 273
 274 checkOptree
 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
 281 checkOptree
 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');
 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
 296 EOT_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
 307 EONT_EONT
 308
 309
 310 #################################
 311 pass("B::Concise STYLE/CALLBACK TESTS");
 312
 313 use 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"
 322       , "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"
 323       #. "(x(;~=> #extra)x)\n" # new 'variable' used here
 324       );
 325
 326 sub 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
 340             if ($lastnext and $$lastnext != $$op) {
 341                 $h->{goto} = ($h->{seq} eq '-')
 342                     ? 'unresolved' : $h->{seq};
 343             }
 344
 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 #################################
 358 set_up_relative_test();
 359 pass("set_up_relative_test, new callback installed");
 360
 361 checkOptree ( 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');
 365 1  <;> nextstate(main 76 optree_concise.t:337) v
 366 2  <#> gvsv[*b] s
 367 3  <$> const[IV 42] CALLBACK s
 368 4  <2> add[t3] sK/2
 369 5  <#> gvsv[*a] s
 370 6  <2> sassign sKS/2
 371 7  <1> leavesub[1 ref] K/REFC,1
 372 EOT_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
 380 EONT_EONT
 381
 382 checkOptree ( 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');
 388 7  <1> leavesub RELATIVE[1 ref] K ->(end) => RELATIVE
 389 -     <@> lineseq KP ->7 => RELATIVE
 390 1        <;> nextstate(main 49 optree_concise.t:309) v ->2 => RELATIVE
 391 6        <2> sassign sKS ->7 => RELATIVE
 392 4           <2> add[t3] sK ->5 => RELATIVE
 393 -              <1> ex-rv2sv sK ->3 => RELATIVE
 394 2                 <#> gvsv[*b] s ->3 => RELATIVE
 395 3              <$> const[IV 42] CALLBACK s ->4 => RELATIVE
 396 -           <1> ex-rv2sv sKRM* ->6 => RELATIVE
 397 5              <#> gvsv[*a] s ->6 => RELATIVE
 398 EOT_EOT
 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
 409 EONT_EONT
 410
 411 checkOptree ( 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');
 416 1  <;> nextstate(main 50 optree_concise.t:326) v
 417 2  <#> gvsv[*b] s
 418 3  <$> const[IV 42] CALLBACK s
 419 4  <2> add[t3] sK
 420 5  <#> gvsv[*a] s
 421 6  <2> sassign sKS
 422 7  <1> leavesub RELATIVE[1 ref] K
 423 EOT_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
 431 EONT_EONT
 432
 433 #################################
 434
 435 @scopeops = qw( leavesub enter leave nextstate );
 436 add_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
 444 checkOptree ( name      => "both -exec -scope",
 445               bcopts    => [qw/ -exec -scope /],
 446               code      => sub{$a=$b+42},
 447               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 448 1  <;> nextstate(main 50 optree_concise.t:337) v
 449 7  <1> leavesub[1 ref] K/REFC,1
 450 EOT_EOT
 451 1  <;> nextstate(main 75 optree_concise.t:396) v
 452 7  <1> leavesub[1 ref] K/REFC,1
 453 EONT_EONT
 454
 455
 456 checkOptree ( name      => "both -basic -scope",
 457               bcopts    => [qw/ -basic -scope /],
 458               code      => sub{$a=$b+42},
 459               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 460 7  <1> leavesub[1 ref] K/REFC,1 ->(end)
 461 1        <;> nextstate(main 51 optree_concise.t:347) v ->2
 462 EOT_EOT
 463 7  <1> leavesub[1 ref] K/REFC,1 ->(end)
 464 1        <;> nextstate(main 76 optree_concise.t:407) v ->2
 465 EONT_EONT
 466
 467 } #skip
 468