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