ext/B/t/optree_concise.t

   1 #!perl
   2
   3 BEGIN {
   4     chdir 't';
   5     @INC = ('../lib', '../ext/B/t');
   6     require Config;
   7     if (($Config::Config{'extensions'} !~ /\bB\b/) ){
   8         print "1..0 # Skip -- Perl configured without B module\n";
   9         exit 0;
  10     }
  11     if ($Config::Config{'extensions'} !~ /\bData\/Dumper\b/) {
  12         print
  13             "1..0 # Skip: Data::Dumper was not built, needed by OptreeCheck\n";
  14         exit 0;
  15     }
  16     require './test.pl';
  17 }
  18
  19 # import checkOptree(), and %gOpts (containing test state)
  20 use OptreeCheck;        # ALSO DOES @ARGV HANDLING !!!!!!
  21 use Config;
  22
  23 plan tests => 24;
  24 SKIP: {
  25 skip "no perlio in this build", 24 unless $Config::Config{useperlio};
  26
  27 $SIG{__WARN__} = sub {
  28     my $err = shift;
  29     $err =~ m/Subroutine re::(un)?install redefined/ and return;
  30 };
  31 #################################
  32 pass("CANONICAL B::Concise EXAMPLE");
  33
  34 checkOptree ( name      => 'canonical example w -basic',
  35               bcopts    => '-basic',
  36               code      =>  sub{$a=$b+42},
  37               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
  38 # 7  <1> leavesub[\d+ refs?] K/REFC,1 ->(end)
  39 # -     <@> lineseq KP ->7
  40 # 1        <;> nextstate(foo bar) v ->2
  41 # 6        <2> sassign sKS/2 ->7
  42 # 4           <2> add[t\d+] sK/2 ->5
  43 # -              <1> ex-rv2sv sK/1 ->3
  44 # 2                 <#> gvsv[*b] s ->3
  45 # 3              <$> const[IV 42] s ->4
  46 # -           <1> ex-rv2sv sKRM*/1 ->6
  47 # 5              <#> gvsv[*a] s ->6
  48 EOT_EOT
  49 # 7  <1> leavesub[1 ref] K/REFC,1 ->(end)
  50 # -     <@> lineseq KP ->7
  51 # 1        <;> nextstate(main 60 optree_concise.t:122) v ->2
  52 # 6        <2> sassign sKS/2 ->7
  53 # 4           <2> add[t1] sK/2 ->5
  54 # -              <1> ex-rv2sv sK/1 ->3
  55 # 2                 <$> gvsv(*b) s ->3
  56 # 3              <$> const(IV 42) s ->4
  57 # -           <1> ex-rv2sv sKRM*/1 ->6
  58 # 5              <$> gvsv(*a) s ->6
  59 EONT_EONT
  60
  61 checkOptree ( name      => 'canonical example w -exec',
  62               bcopts    => '-exec',
  63               code      => sub{$a=$b+42},
  64               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
  65 # 1  <;> nextstate(main 61 optree_concise.t:139) v
  66 # 2  <#> gvsv[*b] s
  67 # 3  <$> const[IV 42] s
  68 # 4  <2> add[t3] sK/2
  69 # 5  <#> gvsv[*a] s
  70 # 6  <2> sassign sKS/2
  71 # 7  <1> leavesub[1 ref] K/REFC,1
  72 EOT_EOT
  73 # 1  <;> nextstate(main 61 optree_concise.t:139) v
  74 # 2  <$> gvsv(*b) s
  75 # 3  <$> const(IV 42) s
  76 # 4  <2> add[t1] sK/2
  77 # 5  <$> gvsv(*a) s
  78 # 6  <2> sassign sKS/2
  79 # 7  <1> leavesub[1 ref] K/REFC,1
  80 EONT_EONT
  81
  82 #################################
  83 pass("B::Concise OPTION TESTS");
  84
  85 checkOptree ( name      => '-base3 sticky-exec',
  86               bcopts    => '-base3',
  87               code      => sub{$a=$b+42},
  88               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
  89 1  <;> dbstate(main 24 optree_concise.t:132) v
  90 2  <#> gvsv[*b] s
  91 10 <$> const[IV 42] s
  92 11 <2> add[t3] sK/2
  93 12 <#> gvsv[*a] s
  94 20 <2> sassign sKS/2
  95 21 <1> leavesub[1 ref] K/REFC,1
  96 EOT_EOT
  97 # 1  <;> nextstate(main 62 optree_concise.t:161) v
  98 # 2  <$> gvsv(*b) s
  99 # 10 <$> const(IV 42) s
 100 # 11 <2> add[t1] sK/2
 101 # 12 <$> gvsv(*a) s
 102 # 20 <2> sassign sKS/2
 103 # 21 <1> leavesub[1 ref] K/REFC,1
 104 EONT_EONT
 105
 106 checkOptree ( name      => 'sticky-base3, -basic over sticky-exec',
 107               bcopts    => '-basic',
 108               code      => sub{$a=$b+42},
 109               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 110 21 <1> leavesub[1 ref] K/REFC,1 ->(end)
 111 -     <@> lineseq KP ->21
 112 1        <;> nextstate(main 32 optree_concise.t:164) v ->2
 113 20       <2> sassign sKS/2 ->21
 114 11          <2> add[t3] sK/2 ->12
 115 -              <1> ex-rv2sv sK/1 ->10
 116 2                 <#> gvsv[*b] s ->10
 117 10             <$> const[IV 42] s ->11
 118 -           <1> ex-rv2sv sKRM*/1 ->20
 119 12             <#> gvsv[*a] s ->20
 120 EOT_EOT
 121 # 21 <1> leavesub[1 ref] K/REFC,1 ->(end)
 122 # -     <@> lineseq KP ->21
 123 # 1        <;> nextstate(main 63 optree_concise.t:186) v ->2
 124 # 20       <2> sassign sKS/2 ->21
 125 # 11          <2> add[t1] sK/2 ->12
 126 # -              <1> ex-rv2sv sK/1 ->10
 127 # 2                 <$> gvsv(*b) s ->10
 128 # 10             <$> const(IV 42) s ->11
 129 # -           <1> ex-rv2sv sKRM*/1 ->20
 130 # 12             <$> gvsv(*a) s ->20
 131 EONT_EONT
 132
 133 checkOptree ( name      => '-base4',
 134               bcopts    => [qw/ -basic -base4 /],
 135               code      => sub{$a=$b+42},
 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               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 165 3  <1> leavesub[1 ref] K/REFC,1 ->(end)
 166 -     <@> lineseq KP ->3
 167 1        <;> nextstate(main 27 optree_concise.t:161) v ->2
 168 -        <1> ex-rv2sv sK/1 ->-
 169 2           <#> gvsv[*a] s ->3
 170 EOT_EOT
 171 # 3  <1> leavesub[1 ref] K/REFC,1 ->(end)
 172 # -     <@> lineseq KP ->3
 173 # 1        <;> nextstate(main 65 optree_concise.t:210) v ->2
 174 # -        <1> ex-rv2sv sK/1 ->-
 175 # 2           <$> gvsv(*a) s ->3
 176 EONT_EONT
 177
 178 checkOptree ( name      => "terse basic",
 179               bcopts    => [qw/ -basic -terse /],
 180               code      => sub{$a},
 181               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 182 UNOP (0x82b0918) leavesub [1]
 183     LISTOP (0x82b08d8) lineseq
 184         COP (0x82b0880) nextstate
 185         UNOP (0x82b0860) null [15]
 186             PADOP (0x82b0840) gvsv  GV (0x82a818c) *a
 187 EOT_EOT
 188 # UNOP (0x8282310) leavesub [1]
 189 #     LISTOP (0x82822f0) lineseq
 190 #         COP (0x82822b8) nextstate
 191 #         UNOP (0x812fc20) null [15]
 192 #             SVOP (0x812fc00) gvsv  GV (0x814692c) *a
 193 EONT_EONT
 194
 195 checkOptree ( name      => "sticky-terse exec",
 196               bcopts    => [qw/ -exec /],
 197               code      => sub{$a},
 198               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 199 COP (0x82b0d70) nextstate
 200 PADOP (0x82b0d30) gvsv  GV (0x82a818c) *a
 201 UNOP (0x82b0e08) leavesub [1]
 202 EOT_EOT
 203 # COP (0x82828e0) nextstate
 204 # SVOP (0x82828a0) gvsv  GV (0x814692c) *a
 205 # UNOP (0x8282938) leavesub [1]
 206 EONT_EONT
 207
 208 pass("OPTIONS IN CMDLINE MODE");
 209
 210 checkOptree ( name      => 'cmdline invoke -basic works',
 211               prog      => 'sort @a',
 212               #bcopts   => '-basic', # default
 213               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 214 # 7  <@> leave[1 ref] vKP/REFC ->(end)
 215 # 1     <0> enter ->2
 216 # 2     <;> nextstate(main 1 -e:1) v ->3
 217 # 6     <@> sort vK ->7
 218 # 3        <0> pushmark s ->4
 219 # 5        <1> rv2av[t2] lK/1 ->6
 220 # 4           <#> gv[*a] s ->5
 221 EOT_EOT
 222 # 7  <@> leave[1 ref] vKP/REFC ->(end)
 223 # 1     <0> enter ->2
 224 # 2     <;> nextstate(main 1 -e:1) v ->3
 225 # 6     <@> sort vK ->7
 226 # 3        <0> pushmark s ->4
 227 # 5        <1> rv2av[t1] lK/1 ->6
 228 # 4           <$> gv(*a) s ->5
 229 EONT_EONT
 230
 231 checkOptree ( name      => 'cmdline invoke -exec works',
 232               prog      => 'sort @a',
 233               bcopts    => '-exec',
 234               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 235 1  <0> enter
 236 2  <;> nextstate(main 1 -e:1) v
 237 3  <0> pushmark s
 238 4  <#> gv[*a] s
 239 5  <1> rv2av[t2] lK/1
 240 6  <@> sort vK
 241 7  <@> leave[1 ref] vKP/REFC
 242 EOT_EOT
 243 # 1  <0> enter
 244 # 2  <;> nextstate(main 1 -e:1) v
 245 # 3  <0> pushmark s
 246 # 4  <$> gv(*a) s
 247 # 5  <1> rv2av[t1] lK/1
 248 # 6  <@> sort vK
 249 # 7  <@> leave[1 ref] vKP/REFC
 250 EONT_EONT
 251
 252 ;
 253 $DB::single=1;
 254 checkOptree
 255     ( name      => 'cmdline self-strict compile err using prog',
 256       prog      => 'use strict; sort @a',
 257       bcopts    => [qw/ -basic -concise -exec /],
 258       errs      => 'Global symbol "@a" requires explicit package name at .*? line 1.',
 259       );
 260
 261 checkOptree
 262     ( name      => 'cmdline self-strict compile err using code',
 263       code      => 'use strict; sort @a',
 264       bcopts    => [qw/ -basic -concise -exec /],
 265       #noanchors        => 1,
 266       errs      => 'Global symbol "@a" requires explicit package name at .*? line 1.',
 267       );
 268
 269 checkOptree
 270     ( name      => 'useless use of sort in void context',
 271       prog      => 'our @a; sort @a',
 272       bcopts    => [qw/ -basic -concise -exec /],
 273       errs      => 'Useless use of sort in void context at -e line 1.',
 274       );
 275
 276 checkOptree
 277     ( name      => 'cmdline -basic -concise -exec works',
 278       prog      => 'our @a; sort @a',
 279       bcopts    => [qw/ -basic -concise -exec /],
 280       expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 281 # 1  <0> enter
 282 # 2  <;> nextstate(main 1 -e:1) v
 283 # 3  <#> gv[*a] s
 284 # 4  <1> rv2av[t3] vK/OURINTR,1
 285 # 5  <;> nextstate(main 2 -e:1) v
 286 # 6  <0> pushmark s
 287 # 7  <#> gv[*a] s
 288 # 8  <1> rv2av[t5] lK/1
 289 # 9  <@> sort vK
 290 # a  <@> leave[1 ref] vKP/REFC
 291 EOT_EOT
 292 # 1  <0> enter
 293 # 2  <;> nextstate(main 1 -e:1) v
 294 # 3  <$> gv(*a) s
 295 # 4  <1> rv2av[t2] vK/OURINTR,1
 296 # 5  <;> nextstate(main 2 -e:1) v
 297 # 6  <0> pushmark s
 298 # 7  <$> gv(*a) s
 299 # 8  <1> rv2av[t3] lK/1
 300 # 9  <@> sort vK
 301 # a  <@> leave[1 ref] vKP/REFC
 302 EONT_EONT
 303
 304
 305 #################################
 306 pass("B::Concise STYLE/CALLBACK TESTS");
 307
 308 use B::Concise qw( walk_output add_style set_style_standard add_callback );
 309
 310 # new relative style, added by set_up_relative_test()
 311 @stylespec =
 312     ( "#hyphseq2 (*(   (x( ;)x))*)<#classsym> "
 313       . "#exname#arg(?([#targarglife])?)~#flags(?(/#privateb)?)(x(;~->#next)x) "
 314       . "(x(;~=> #extra)x)\n" # new 'variable' used here
 315
 316       , "  (*(    )*)     goto #seq\n"
 317       , "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"
 318       #. "(x(;~=> #extra)x)\n" # new 'variable' used here
 319       );
 320
 321 sub set_up_relative_test {
 322     # add a new style, and a callback which adds an 'extra' property
 323
 324     add_style ( "relative"      => @stylespec );
 325     #set_style_standard ( "relative" );
 326
 327     add_callback
 328         ( sub {
 329             my ($h, $op, $format, $level, $style) = @_;
 330
 331             # callback marks up const ops
 332             $h->{arg} .= ' CALLBACK' if $h->{name} eq 'const';
 333             $h->{extra} = '';
 334
 335             if ($lastnext and $$lastnext != $$op) {
 336                 $h->{goto} = ($h->{seq} eq '-')
 337                     ? 'unresolved' : $h->{seq};
 338             }
 339
 340             # 2 style specific behaviors
 341             if ($style eq 'relative') {
 342                 $h->{extra} = 'RELATIVE';
 343                 $h->{arg} .= ' RELATIVE' if $h->{name} eq 'leavesub';
 344             }
 345             elsif ($style eq 'scope') {
 346                 # supress printout entirely
 347                 $$format="" unless grep { $h->{name} eq $_ } @scopeops;
 348             }
 349         });
 350 }
 351
 352 #################################
 353 set_up_relative_test();
 354 pass("set_up_relative_test, new callback installed");
 355
 356 checkOptree ( name      => 'callback used, independent of style',
 357               bcopts    => [qw/ -concise -exec /],
 358               code      => sub{$a=$b+42},
 359               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 360 1  <;> nextstate(main 76 optree_concise.t:337) v
 361 2  <#> gvsv[*b] s
 362 3  <$> const[IV 42] CALLBACK s
 363 4  <2> add[t3] sK/2
 364 5  <#> gvsv[*a] s
 365 6  <2> sassign sKS/2
 366 7  <1> leavesub[1 ref] K/REFC,1
 367 EOT_EOT
 368 # 1  <;> nextstate(main 455 optree_concise.t:328) v
 369 # 2  <$> gvsv(*b) s
 370 # 3  <$> const(IV 42) CALLBACK s
 371 # 4  <2> add[t1] sK/2
 372 # 5  <$> gvsv(*a) s
 373 # 6  <2> sassign sKS/2
 374 # 7  <1> leavesub[1 ref] K/REFC,1
 375 EONT_EONT
 376
 377 checkOptree ( name      => "new 'relative' style, -exec mode",
 378               bcopts    => [qw/ -basic -relative /],
 379               code      => sub{$a=$b+42},
 380               crossfail => 1,
 381               #retry    => 1,
 382               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 383 7  <1> leavesub RELATIVE[1 ref] K ->(end) => RELATIVE
 384 -     <@> lineseq KP ->7 => RELATIVE
 385 1        <;> nextstate(main 49 optree_concise.t:309) v ->2 => RELATIVE
 386 6        <2> sassign sKS ->7 => RELATIVE
 387 4           <2> add[t3] sK ->5 => RELATIVE
 388 -              <1> ex-rv2sv sK ->3 => RELATIVE
 389 2                 <#> gvsv[*b] s ->3 => RELATIVE
 390 3              <$> const[IV 42] CALLBACK s ->4 => RELATIVE
 391 -           <1> ex-rv2sv sKRM* ->6 => RELATIVE
 392 5              <#> gvsv[*a] s ->6 => RELATIVE
 393 EOT_EOT
 394 # 7  <1> leavesub RELATIVE[1 ref] K ->(end) => RELATIVE
 395 # -     <@> lineseq KP ->7 => RELATIVE
 396 # 1        <;> nextstate(main 77 optree_concise.t:353) v ->2 => RELATIVE
 397 # 6        <2> sassign sKS ->7 => RELATIVE
 398 # 4           <2> add[t1] 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 EONT_EONT
 405
 406 checkOptree ( name      => "both -exec -relative",
 407               bcopts    => [qw/ -exec -relative /],
 408               code      => sub{$a=$b+42},
 409               crossfail => 1,
 410               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 411 1  <;> nextstate(main 50 optree_concise.t:326) v
 412 2  <#> gvsv[*b] s
 413 3  <$> const[IV 42] CALLBACK s
 414 4  <2> add[t3] sK
 415 5  <#> gvsv[*a] s
 416 6  <2> sassign sKS
 417 7  <1> leavesub RELATIVE[1 ref] K
 418 EOT_EOT
 419 # 1  <;> nextstate(main 78 optree_concise.t:371) v
 420 # 2  <$> gvsv(*b) s
 421 # 3  <$> const(IV 42) CALLBACK s
 422 # 4  <2> add[t1] sK
 423 # 5  <$> gvsv(*a) s
 424 # 6  <2> sassign sKS
 425 # 7  <1> leavesub RELATIVE[1 ref] K
 426 EONT_EONT
 427
 428 #################################
 429
 430 @scopeops = qw( leavesub enter leave nextstate );
 431 add_style
 432         ( 'scope'  # concise copy
 433           , "#hyphseq2 (*(   (x( ;)x))*)<#classsym> "
 434           . "#exname#arg(?([#targarglife])?)~#flags(?(/#private)?)(x(;~->#next)x) "
 435           , "  (*(    )*)     goto #seq\n"
 436           , "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"
 437          );
 438
 439 checkOptree ( name      => "both -exec -scope",
 440               bcopts    => [qw/ -exec -scope /],
 441               code      => sub{$a=$b+42},
 442               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 443 1  <;> nextstate(main 50 optree_concise.t:337) v
 444 7  <1> leavesub[1 ref] K/REFC,1
 445 EOT_EOT
 446 1  <;> nextstate(main 75 optree_concise.t:396) v
 447 7  <1> leavesub[1 ref] K/REFC,1
 448 EONT_EONT
 449
 450
 451 checkOptree ( name      => "both -basic -scope",
 452               bcopts    => [qw/ -basic -scope /],
 453               code      => sub{$a=$b+42},
 454               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 455 7  <1> leavesub[1 ref] K/REFC,1 ->(end)
 456 1        <;> nextstate(main 51 optree_concise.t:347) v ->2
 457 EOT_EOT
 458 7  <1> leavesub[1 ref] K/REFC,1 ->(end)
 459 1        <;> nextstate(main 76 optree_concise.t:407) v ->2
 460 EONT_EONT
 461
 462 } #skip
 463