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