6 @INC = ('.', '../lib', '../ext/B/t');
12 if (($Config::Config{'extensions'} !~ /\bB\b/) ){
13 print "1..0 # Skip -- Perl configured without B module\n";
16 # require 'test.pl'; # now done by OptreeCheck
21 =head1 OptreeCheck selftest harness
23 This file is primarily to test services of OptreeCheck itself, ie
24 checkOptree(). %gOpts provides test-state info, it is 'exported' into
27 doing use OptreeCheck runs import(), which processes @ARGV to process
28 cmdline args in 'standard' way across all clients of OptreeCheck.
32 my $tests = 5 + 15 + 16 * $gOpts{selftest}; # pass()s + $#tests
36 skip "no perlio in this build", $tests
37 unless $Config::Config{useperlio};
40 pass("REGEX TEST HARNESS SELFTEST");
42 checkOptree ( name => "bare minimum opcode search",
45 noanchors => 1, # unanchored match
47 expect_nt => 'leavesub');
49 checkOptree ( name => "found print opcode",
51 code => sub {print 1},
52 noanchors => 1, # unanchored match
54 expect_nt => 'leavesub');
56 checkOptree ( name => 'test skip itself',
57 skip => 'this is skip-reason',
59 code => sub {print 1},
60 expect => 'dont-care, skipping',
61 expect_nt => 'this insures failure');
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.
67 checkOptree ( name => 'test todo itself',
68 todo => "your excuse here ;-)",
70 code => sub {print 1},
71 noanchors => 1, # unanchored match
73 expect_nt => 'print') if 0;
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 !');
82 pass ("TEST FATAL ERRS");
85 # test for fatal errors. Im unsettled on fail vs die.
86 # calling fail isnt good enough by itself.
90 checkOptree ( name => 'test against empty expectations',
92 code => sub {print 1},
96 like($@, /no '\w+' golden-sample found/, "empty expectations prevented");
100 checkOptree ( name => 'prevent whitespace only expectations',
107 like($@, /no '\w+' golden-sample found/,
108 "just whitespace expectations prevented");
111 pass ("TEST -e \$srcCode");
113 checkOptree ( name => 'empty code or prog',
115 todo => "your excuse here ;-)",
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
129 checkOptree ( name => "sort lK - flag specific search",
130 prog => 'our (@a,@b); @b = sort @a',
132 expect => '<@> sort lK ',
133 expect_nt => '<@> sort lK ');
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.',
139 expect => '<@> sort vK',
140 expect_nt => '<@> sort vK');
142 checkOptree ( name => "'code' => 'sort our \@a'",
143 code => 'sort our @a',
145 expect => '<@> sort K',
146 expect_nt => '<@> sort K');
148 pass ("REFTEXT FIXUP TESTS");
150 checkOptree ( name => 'fixup nextstate (in reftext)',
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
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
164 checkOptree ( name => 'fixup opcode args',
166 #fail => 1, # uncomment to see real padsv args: [$a:491,492]
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
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
179 #################################
180 pass("CANONICAL B::Concise EXAMPLE");
182 checkOptree ( name => 'canonical example w -basic',
184 code => sub{$a=$b+42},
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
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
212 checkOptree ( code => '$a=$b+42',
214 expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
215 # 1 <;> nextstate(main 837 (eval 24):1) v:{
217 # 3 <$> const[IV 42] s
220 # 6 <2> sassign sKS/2
221 # 7 <1> leavesub[1 ref] K/REFC,1
223 # 1 <;> nextstate(main 837 (eval 24):1) v:{
225 # 3 <$> const(IV 42) s
228 # 6 <2> sassign sKS/2
229 # 7 <1> leavesub[1 ref] K/REFC,1