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