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