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