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 => 24;
  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 #            goto -
  56 # 1  <;> nextstate(main 61 optree_concise.t:139) v
  57 # 2  <#> gvsv[*b] s
  58 # 3  <$> const[IV 42] s
  59 # 4  <2> add[t3] sK/2
  60 # 5  <#> gvsv[*a] s
  61 # 6  <2> sassign sKS/2
  62 # 7  <1> leavesub[1 ref] K/REFC,1
  63 EOT_EOT
  64 #            goto -
  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[t1] sK/2
  69 # 5  <$> gvsv(*a) s
  70 # 6  <2> sassign sKS/2
  71 # 7  <1> leavesub[1 ref] K/REFC,1
  72 EONT_EONT
  73
  74 checkOptree ( name      => 'tree reftext is messy cut-paste',
  75               skip      => 1);
  76
  77
  78 #################################
  79 pass("B::Concise OPTION TESTS");
  80
  81 checkOptree ( name      => '-base3 sticky-exec',
  82               bcopts    => '-base3',
  83               code      => sub{$a=$b+42},
  84               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
  85            goto -
  86 1  <;> dbstate(main 24 optree_concise.t:132) v
  87 2  <#> gvsv[*b] s
  88 10 <$> const[IV 42] s
  89 11 <2> add[t3] sK/2
  90 12 <#> gvsv[*a] s
  91 20 <2> sassign sKS/2
  92 21 <1> leavesub[2 refs] K/REFC,1
  93 EOT_EOT
  94 #            goto -
  95 # 1  <;> nextstate(main 62 optree_concise.t:161) v
  96 # 2  <$> gvsv(*b) s
  97 # 10 <$> const(IV 42) s
  98 # 11 <2> add[t1] sK/2
  99 # 12 <$> gvsv(*a) s
 100 # 20 <2> sassign sKS/2
 101 # 21 <1> leavesub[1 ref] K/REFC,1
 102 EONT_EONT
 103
 104 checkOptree ( name      => 'sticky-base3, -basic over sticky-exec',
 105               bcopts    => '-basic',
 106               code      => sub{$a=$b+42},
 107               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 108 21 <1> leavesub[1 ref] K/REFC,1 ->(end)
 109 -     <@> lineseq KP ->21
 110 1        <;> nextstate(main 32 optree_concise.t:164) v ->2
 111 20       <2> sassign sKS/2 ->21
 112 11          <2> add[t3] sK/2 ->12
 113 -              <1> ex-rv2sv sK/1 ->10
 114 2                 <#> gvsv[*b] s ->10
 115 10             <$> const[IV 42] s ->11
 116 -           <1> ex-rv2sv sKRM*/1 ->20
 117 12             <#> gvsv[*a] s ->20
 118 EOT_EOT
 119 # 21 <1> leavesub[1 ref] K/REFC,1 ->(end)
 120 # -     <@> lineseq KP ->21
 121 # 1        <;> nextstate(main 63 optree_concise.t:186) v ->2
 122 # 20       <2> sassign sKS/2 ->21
 123 # 11          <2> add[t1] sK/2 ->12
 124 # -              <1> ex-rv2sv sK/1 ->10
 125 # 2                 <$> gvsv(*b) s ->10
 126 # 10             <$> const(IV 42) s ->11
 127 # -           <1> ex-rv2sv sKRM*/1 ->20
 128 # 12             <$> gvsv(*a) s ->20
 129 EONT_EONT
 130
 131 checkOptree ( name      => '-base4',
 132               bcopts    => [qw/ -basic -base4 /],
 133               code      => sub{$a=$b+42},
 134               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 135 13 <1> leavesub[1 ref] K/REFC,1 ->(end)
 136 -     <@> lineseq KP ->13
 137 1        <;> nextstate(main 26 optree_concise.t:145) v ->2
 138 12       <2> sassign sKS/2 ->13
 139 10          <2> add[t3] sK/2 ->11
 140 -              <1> ex-rv2sv sK/1 ->3
 141 2                 <#> gvsv[*b] s ->3
 142 3              <$> const[IV 42] s ->10
 143 -           <1> ex-rv2sv sKRM*/1 ->12
 144 11             <#> gvsv[*a] s ->12
 145 EOT_EOT
 146 # 13 <1> leavesub[1 ref] K/REFC,1 ->(end)
 147 # -     <@> lineseq KP ->13
 148 # 1        <;> nextstate(main 64 optree_concise.t:193) v ->2
 149 # 12       <2> sassign sKS/2 ->13
 150 # 10          <2> add[t1] sK/2 ->11
 151 # -              <1> ex-rv2sv sK/1 ->3
 152 # 2                 <$> gvsv(*b) s ->3
 153 # 3              <$> const(IV 42) s ->10
 154 # -           <1> ex-rv2sv sKRM*/1 ->12
 155 # 11             <$> gvsv(*a) s ->12
 156 EONT_EONT
 157
 158 checkOptree ( name      => "restore -base36 default",
 159               bcopts    => [qw/ -basic -base36 /],
 160               code      => sub{$a},
 161               crossfail => 1,
 162               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 163 3  <1> leavesub[1 ref] K/REFC,1 ->(end)
 164 -     <@> lineseq KP ->3
 165 1        <;> nextstate(main 27 optree_concise.t:161) v ->2
 166 -        <1> ex-rv2sv sK/1 ->-
 167 2           <#> gvsv[*a] s ->3
 168 EOT_EOT
 169 # 3  <1> leavesub[1 ref] K/REFC,1 ->(end)
 170 # -     <@> lineseq KP ->3
 171 # 1        <;> nextstate(main 65 optree_concise.t:210) v ->2
 172 # -        <1> ex-rv2sv sK/1 ->-
 173 # 2           <$> gvsv(*a) s ->3
 174 EONT_EONT
 175
 176 checkOptree ( name      => "terse basic",
 177               bcopts    => [qw/ -basic -terse /],
 178               code      => sub{$a},
 179               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 180 UNOP (0x82b0918) leavesub [1]
 181     LISTOP (0x82b08d8) lineseq
 182         COP (0x82b0880) nextstate
 183         UNOP (0x82b0860) null [15]
 184             PADOP (0x82b0840) gvsv  GV (0x82a818c) *a
 185 EOT_EOT
 186 # UNOP (0x8282310) leavesub [1]
 187 #     LISTOP (0x82822f0) lineseq
 188 #         COP (0x82822b8) nextstate
 189 #         UNOP (0x812fc20) null [15]
 190 #             SVOP (0x812fc00) gvsv  GV (0x814692c) *a
 191 EONT_EONT
 192
 193 checkOptree ( name      => "sticky-terse exec",
 194               bcopts    => [qw/ -exec /],
 195               code      => sub{$a},
 196               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 197     goto UNOP (0x82b0918)
 198 COP (0x82b0d70) nextstate
 199 PADOP (0x82b0d30) gvsv  GV (0x82a818c) *a
 200 UNOP (0x82b0e08) leavesub [1]
 201 EOT_EOT
 202 #     goto UNOP (0x8282310)
 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 checkOptree ( name      => 'cmdline self-strict compile err',
 253               prog      => 'use strict; sort @a',
 254               bcopts    => [qw/ -basic -concise -exec /],
 255               expect    => 'compilation errors',
 256               expect_nt => 'compilation errors');
 257
 258 checkOptree ( name      => 'error at -e line 1',
 259               prog      => 'our @a; sort @a',
 260               bcopts    => [qw/ -basic -concise -exec /],
 261               expect    => 'at -e line 1',
 262               expect_nt => 'at -e line 1');
 263
 264 checkOptree ( name      => 'cmdline -basic -concise -exec works',
 265               prog      => 'our @a; sort @a',
 266               bcopts    => [qw/ -basic -concise -exec /],
 267               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 268 # 1  <0> enter
 269 # 2  <;> nextstate(main 1 -e:1) v
 270 # 3  <#> gv[*a] s
 271 # 4  <1> rv2av[t3] vK/OURINTR,1
 272 # 5  <;> nextstate(main 2 -e:1) v
 273 # 6  <0> pushmark s
 274 # 7  <#> gv[*a] s
 275 # 8  <1> rv2av[t5] lK/1
 276 # 9  <@> sort vK
 277 # a  <@> leave[1 ref] vKP/REFC
 278 EOT_EOT
 279 # 1  <0> enter
 280 # 2  <;> nextstate(main 1 -e:1) v
 281 # 3  <$> gv(*a) s
 282 # 4  <1> rv2av[t2] vK/OURINTR,1
 283 # 5  <;> nextstate(main 2 -e:1) v
 284 # 6  <0> pushmark s
 285 # 7  <$> gv(*a) s
 286 # 8  <1> rv2av[t3] lK/1
 287 # 9  <@> sort vK
 288 # a  <@> leave[1 ref] vKP/REFC
 289 EONT_EONT
 290
 291
 292 #################################
 293 pass("B::Concise STYLE/CALLBACK TESTS");
 294
 295 use B::Concise qw( walk_output add_style set_style_standard add_callback );
 296
 297 # new relative style, added by set_up_relative_test()
 298 @stylespec =
 299     ( "#hyphseq2 (*(   (x( ;)x))*)<#classsym> "
 300       . "#exname#arg(?([#targarglife])?)~#flags(?(/#privateb)?)(x(;~->#next)x) "
 301       . "(x(;~=> #extra)x)\n" # new 'variable' used here
 302
 303       , "  (*(    )*)     goto #seq\n"
 304       , "(?(<#speq>)?)#exname#arg(?([#targarglife])?)"
 305       #. "(x(;~=> #extra)x)\n" # new 'variable' used here
 306       );
 307
 308 sub set_up_relative_test {
 309     # add a new style, and a callback which adds an 'extra' property
 310
 311     add_style ( "relative"      => @stylespec );
 312     #set_style_standard ( "relative" );
 313
 314     add_callback
 315         ( sub {
 316             my ($h, $op, $format, $level, $style) = @_;
 317
 318             # callback marks up const ops
 319             $h->{arg} .= ' CALLBACK' if $h->{name} eq 'const';
 320             $h->{extra} = '';
 321
 322             # 2 style specific behaviors
 323             if ($style eq 'relative') {
 324                 $h->{extra} = 'RELATIVE';
 325                 $h->{arg} .= ' RELATIVE' if $h->{name} eq 'leavesub';
 326             }
 327             elsif ($style eq 'scope') {
 328                 # supress printout entirely
 329                 $$format="" unless grep { $h->{name} eq $_ } @scopeops;
 330             }
 331         });
 332 }
 333
 334 #################################
 335 set_up_relative_test();
 336 pass("set_up_relative_test, new callback installed");
 337
 338 checkOptree ( name      => 'callback used, independent of style',
 339               bcopts    => [qw/ -concise -exec /],
 340               code      => sub{$a=$b+42},
 341               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 342            goto -
 343 1  <;> nextstate(main 76 optree_concise.t:337) v
 344 2  <#> gvsv[*b] s
 345 3  <$> const[IV 42] CALLBACK s
 346 4  <2> add[t3] sK/2
 347 5  <#> gvsv[*a] s
 348 6  <2> sassign sKS/2
 349 7  <1> leavesub[1 ref] K/REFC,1
 350 EOT_EOT
 351 # 1  <;> nextstate(main 455 optree_concise.t:328) v
 352 # 2  <$> gvsv(*b) s
 353 # 3  <$> const(IV 42) CALLBACK s
 354 # 4  <2> add[t1] sK/2
 355 # 5  <$> gvsv(*a) s
 356 # 6  <2> sassign sKS/2
 357 # 7  <1> leavesub[1 ref] K/REFC,1
 358 EONT_EONT
 359
 360 checkOptree ( name      => "new 'relative' style, -exec mode",
 361               bcopts    => [qw/ -basic -relative /],
 362               code      => sub{$a=$b+42},
 363               crossfail => 1,
 364               #retry    => 1,
 365               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 366 7  <1> leavesub RELATIVE[1 ref] K ->(end)       => RELATIVE
 367 -     <@> lineseq KP ->7        => RELATIVE
 368 1        <;> nextstate(main 49 optree_concise.t:309) v ->2      => RELATIVE
 369 6        <2> sassign sKS ->7    => RELATIVE
 370 4           <2> add[t3] sK ->5  => RELATIVE
 371 -              <1> ex-rv2sv sK ->3      => RELATIVE
 372 2                 <#> gvsv[*b] s ->3    => RELATIVE
 373 3              <$> const[IV 42] CALLBACK s ->4  => RELATIVE
 374 -           <1> ex-rv2sv sKRM* ->6      => RELATIVE
 375 5              <#> gvsv[*a] s ->6       => RELATIVE
 376 EOT_EOT
 377 # 7  <1> leavesub RELATIVE[1 ref] K ->(end)     => RELATIVE
 378 # -     <@> lineseq KP ->7      => RELATIVE
 379 # 1        <;> nextstate(main 77 optree_concise.t:353) v ->2    => RELATIVE
 380 # 6        <2> sassign sKS ->7  => RELATIVE
 381 # 4           <2> add[t1] sK ->5        => RELATIVE
 382 # -              <1> ex-rv2sv sK ->3    => RELATIVE
 383 # 2                 <$> gvsv(*b) s ->3  => RELATIVE
 384 # 3              <$> const(IV 42) CALLBACK s ->4        => RELATIVE
 385 # -           <1> ex-rv2sv sKRM* ->6    => RELATIVE
 386 # 5              <$> gvsv(*a) s ->6     => RELATIVE
 387 EONT_EONT
 388
 389 checkOptree ( name      => "both -exec -relative",
 390               bcopts    => [qw/ -exec -relative /],
 391               code      => sub{$a=$b+42},
 392               crossfail => 1,
 393               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 394            goto -
 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            goto -
 428 1  <;> nextstate(main 50 optree_concise.t:337) v
 429 7  <1> leavesub[1 ref] K/REFC,1
 430 EOT_EOT
 431            goto -
 432 1  <;> nextstate(main 75 optree_concise.t:396) v
 433 7  <1> leavesub[1 ref] K/REFC,1
 434 EONT_EONT
 435
 436
 437 checkOptree ( name      => "both -basic -scope",
 438               bcopts    => [qw/ -basic -scope /],
 439               code      => sub{$a=$b+42},
 440               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 441 7  <1> leavesub[1 ref] K/REFC,1 ->(end)
 442 1        <;> nextstate(main 51 optree_concise.t:347) v ->2
 443 EOT_EOT
 444 7  <1> leavesub[1 ref] K/REFC,1 ->(end)
 445 1        <;> nextstate(main 76 optree_concise.t:407) v ->2
 446 EONT_EONT
 447
 448 } #skip
 449
 450 __END__
 451