ext/B/t/optree_concise.t

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