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