ext/B/t/optree_check.t

   1 #!perl
   2
   3 BEGIN {
   4     unshift @INC, 't';
   5     require Config;
   6     if (($Config::Config{'extensions'} !~ /\bB\b/) ){
   7         print "1..0 # Skip -- Perl configured without B module\n";
   8         exit 0;
   9     }
  10     if (!$Config::Config{useperlio}) {
  11         print "1..0 # Skip -- need perlio to walk the optree\n";
  12         exit 0;
  13     }
  14 }
  15
  16 use OptreeCheck;
  17
  18 =head1 OptreeCheck selftest harness
  19
  20 This file is primarily to test services of OptreeCheck itself, ie
  21 checkOptree().  %gOpts provides test-state info, it is 'exported' into
  22 main::
  23
  24 doing use OptreeCheck runs import(), which processes @ARGV to process
  25 cmdline args in 'standard' way across all clients of OptreeCheck.
  26
  27 =cut
  28
  29 plan tests =>     11 # REGEX TEST HARNESS SELFTEST
  30                 +  3 # TEST FATAL ERRS
  31                 + 11 # TEST -e \$srcCode
  32                 +  5 # REFTEXT FIXUP TESTS
  33                 +  5 # CANONICAL B::Concise EXAMPLE
  34                 + 16 * $gOpts{selftest}; # XXX I don't understand this - DAPM
  35
  36 pass("REGEX TEST HARNESS SELFTEST");
  37
  38 checkOptree ( name      => "bare minimum opcode search",
  39               bcopts    => '-exec',
  40               code      => sub {my $a},
  41               noanchors => 1, # unanchored match
  42               expect    => 'leavesub',
  43               expect_nt => 'leavesub');
  44
  45 checkOptree ( name      => "found print opcode",
  46               bcopts    => '-exec',
  47               code      => sub {print 1},
  48               noanchors => 1, # unanchored match
  49               expect    => 'print',
  50               expect_nt => 'leavesub');
  51
  52 checkOptree ( name      => 'test skip itself',
  53               skip      => 'this is skip-reason',
  54               bcopts    => '-exec',
  55               code      => sub {print 1},
  56               expect    => 'dont-care, skipping',
  57               expect_nt => 'this insures failure');
  58
  59 # This test 'unexpectedly succeeds', but that is "expected".  Theres
  60 # no good way to expect a successful todo, and inducing a failure
  61 # causes the harness to print verbose errors, which is NOT helpful.
  62
  63 checkOptree ( name      => 'test todo itself',
  64               todo      => "your excuse here ;-)",
  65               bcopts    => '-exec',
  66               code      => sub {print 1},
  67               noanchors => 1, # unanchored match
  68               expect    => 'print',
  69               expect_nt => 'print') if 0;
  70
  71 checkOptree ( name      => 'impossible match, remove skip to see failure',
  72               todo      => "see! it breaks!",
  73               skip      => 'skip the failure',
  74               code      => sub {print 1},
  75               expect    => 'look out ! Boy Wonder',
  76               expect_nt => 'holy near earth asteroid Batman !');
  77
  78 pass ("TEST FATAL ERRS");
  79
  80 if (1) {
  81     # test for fatal errors. Im unsettled on fail vs die.
  82     # calling fail isnt good enough by itself.
  83
  84     $@='';
  85     eval {
  86         checkOptree ( name      => 'test against empty expectations',
  87                       bcopts    => '-exec',
  88                       code      => sub {print 1},
  89                       expect    => '',
  90                       expect_nt => '');
  91     };
  92     like($@, qr/no '\w+' golden-sample found/, "empty expectations prevented");
  93
  94     $@='';
  95     eval {
  96         checkOptree ( name      => 'prevent whitespace only expectations',
  97                       bcopts    => '-exec',
  98                       code      => sub {my $a},
  99                       #skip     => 1,
 100                       expect_nt => "\n",
 101                       expect    => "\n");
 102     };
 103     like($@, qr/whitespace only reftext found for '\w+'/,
 104          "just whitespace expectations prevented");
 105 }
 106
 107 pass ("TEST -e \$srcCode");
 108
 109 checkOptree ( name      => 'empty code or prog',
 110               skip      => 'or fails',
 111               todo      => "your excuse here ;-)",
 112               code      => '',
 113               prog      => '',
 114               );
 115
 116 checkOptree
 117     (  name     => "self strict, catch err",
 118        prog     => 'use strict; bogus',
 119        errs     => 'Bareword "bogus" not allowed while "strict subs" in use at -e line 1.',
 120        expect   => "nextstate", # simple expectations
 121        expect_nt => "nextstate",
 122        noanchors => 1,          # allow them to work
 123        );
 124
 125 checkOptree ( name      => "sort lK - flag specific search",
 126               prog      => 'our (@a,@b); @b = sort @a',
 127               noanchors => 1,
 128               expect    => '<@> sort lK ',
 129               expect_nt => '<@> sort lK ');
 130
 131 checkOptree ( name      => "sort vK - flag specific search",
 132               prog      => 'sort our @a',
 133               errs      => 'Useless use of sort in void context at -e line 1.',
 134               noanchors => 1,
 135               expect    => '<@> sort vK',
 136               expect_nt => '<@> sort vK');
 137
 138 checkOptree ( name      => "'code' => 'sort our \@a'",
 139               code      => 'sort our @a',
 140               noanchors => 1,
 141               expect    => '<@> sort K',
 142               expect_nt => '<@> sort K');
 143
 144 pass ("REFTEXT FIXUP TESTS");
 145
 146 checkOptree ( name      => 'fixup nextstate (in reftext)',
 147               bcopts    => '-exec',
 148               code      => sub {my $a},
 149               strip_open_hints => 1,
 150               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 151 # 1  <;> nextstate( NOTE THAT THIS CAN BE ANYTHING ) v:>,<,%
 152 # 2  <0> padsv[$a:54,55] M/LVINTRO
 153 # 3  <1> leavesub[1 ref] K/REFC,1
 154 EOT_EOT
 155 # 1  <;> nextstate(main 54 optree_concise.t:84) v:>,<,%
 156 # 2  <0> padsv[$a:54,55] M/LVINTRO
 157 # 3  <1> leavesub[1 ref] K/REFC,1
 158 EONT_EONT
 159
 160 checkOptree ( name      => 'fixup opcode args',
 161               bcopts    => '-exec',
 162               #fail     => 1, # uncomment to see real padsv args: [$a:491,492]
 163               code      => sub {my $a},
 164               strip_open_hints => 1,
 165               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 166 # 1  <;> nextstate(main 56 optree_concise.t:96) v:>,<,%
 167 # 2  <0> padsv[$a:56,57] M/LVINTRO
 168 # 3  <1> leavesub[1 ref] K/REFC,1
 169 EOT_EOT
 170 # 1  <;> nextstate(main 56 optree_concise.t:96) v:>,<,%
 171 # 2  <0> padsv[$a:56,57] M/LVINTRO
 172 # 3  <1> leavesub[1 ref] K/REFC,1
 173 EONT_EONT
 174
 175 #################################
 176 pass("CANONICAL B::Concise EXAMPLE");
 177
 178 checkOptree ( name      => 'canonical example w -basic',
 179               bcopts    => '-basic',
 180               code      =>  sub{$a=$b+42},
 181               crossfail => 1,
 182               strip_open_hints => 1,
 183               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 184 # 7  <1> leavesub[1 ref] K/REFC,1 ->(end)
 185 # -     <@> lineseq KP ->7
 186 # 1        <;> nextstate(main 380 optree_selftest.t:139) v:>,<,%,{ ->2
 187 # 6        <2> sassign sKS/2 ->7
 188 # 4           <2> add[t3] sK/2 ->5
 189 # -              <1> ex-rv2sv sK/1 ->3
 190 # 2                 <#> gvsv[*b] s ->3
 191 # 3              <$> const[IV 42] s ->4
 192 # -           <1> ex-rv2sv sKRM*/1 ->6
 193 # 5              <#> gvsv[*a] s ->6
 194 EOT_EOT
 195 # 7  <1> leavesub[1 ref] K/REFC,1 ->(end)
 196 # -     <@> lineseq KP ->7
 197 # 1        <;> nextstate(main 60 optree_concise.t:122) v:>,<,%,{ ->2
 198 # 6        <2> sassign sKS/2 ->7
 199 # 4           <2> add[t1] sK/2 ->5
 200 # -              <1> ex-rv2sv sK/1 ->3
 201 # 2                 <$> gvsv(*b) s ->3
 202 # 3              <$> const(IV 42) s ->4
 203 # -           <1> ex-rv2sv sKRM*/1 ->6
 204 # 5              <$> gvsv(*a) s ->6
 205 EONT_EONT
 206
 207 checkOptree ( code      => '$a=$b+42',
 208               bcopts    => '-exec',
 209               expect    => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 210 # 1  <;> nextstate(main 837 (eval 24):1) v:{
 211 # 2  <#> gvsv[*b] s
 212 # 3  <$> const[IV 42] s
 213 # 4  <2> add[t3] sK/2
 214 # 5  <#> gvsv[*a] s
 215 # 6  <2> sassign sKS/2
 216 # 7  <1> leavesub[1 ref] K/REFC,1
 217 EOT_EOT
 218 # 1  <;> nextstate(main 837 (eval 24):1) v:{
 219 # 2  <$> gvsv(*b) s
 220 # 3  <$> const(IV 42) s
 221 # 4  <2> add[t1] sK/2
 222 # 5  <$> gvsv(*a) s
 223 # 6  <2> sassign sKS/2
 224 # 7  <1> leavesub[1 ref] K/REFC,1
 225 EONT_EONT