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 if (!$Config::Config{useperlio}) { 11 print "1..0 # Skip -- need perlio to walk the optree\n"; 12 exit 0; 13 } 14} 15 16use OptreeCheck; 17 18=head1 OptreeCheck selftest harness 19 20This file is primarily to test services of OptreeCheck itself, ie 21checkOptree(). %gOpts provides test-state info, it is 'exported' into 22main:: 23 24doing use OptreeCheck runs import(), which processes @ARGV to process 25cmdline args in 'standard' way across all clients of OptreeCheck. 26 27=cut 28 29plan 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 36pass("REGEX TEST HARNESS SELFTEST"); 37 38checkOptree ( 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 45checkOptree ( 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 52checkOptree ( 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 63checkOptree ( 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 71checkOptree ( 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 78pass ("TEST FATAL ERRS"); 79 80if (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 107pass ("TEST -e \$srcCode"); 108 109checkOptree ( name => 'empty code or prog', 110 skip => 'or fails', 111 todo => "your excuse here ;-)", 112 code => '', 113 prog => '', 114 ); 115 116checkOptree 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 125checkOptree ( 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 131checkOptree ( 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 138checkOptree ( name => "'code' => 'sort our \@a'", 139 code => 'sort our @a', 140 noanchors => 1, 141 expect => '<@> sort K', 142 expect_nt => '<@> sort K'); 143 144pass ("REFTEXT FIXUP TESTS"); 145 146checkOptree ( 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 154EOT_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 158EONT_EONT 159 160checkOptree ( 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 169EOT_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 173EONT_EONT 174 175################################# 176pass("CANONICAL B::Concise EXAMPLE"); 177 178checkOptree ( 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 194EOT_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 205EONT_EONT 206 207checkOptree ( 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 217EOT_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 225EONT_EONT 226