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