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