ext/B/t/optree_concise.t

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