[p5sagit/p5-mst-13.2.git] / ext / B / t / optree_check.t

#!perl

BEGIN {
    chdir 't';
    @INC = ('../lib', '../ext/B/t');
    require './test.pl';
}

use OptreeCheck;

=head1 OptreeCheck selftest harness

This file is primarily to test services of OptreeCheck itself, ie
checkOptree().  %gOpts provides test-state info, it is 'exported' into
main::  

doing use OptreeCheck runs import(), which processes @ARGV to process
cmdline args in 'standard' way across all clients of OptreeCheck.

=cut

use Config;
plan tests => 5 + 19 + 14 * $gOpts{selftest};	# fudged

SKIP: {
    skip "no perlio in this build", 5 + 19 + 14 * $gOpts{selftest}
    unless $Config::Config{useperlio};


pass("REGEX TEST HARNESS SELFTEST");

checkOptree ( name	=> "bare minimum opcode search",
	      bcopts	=> '-exec',
	      code	=> sub {my $a},
	      expect	=> 'leavesub',
	      expect_nt	=> 'leavesub');

checkOptree ( name	=> "found print opcode",
	      bcopts	=> '-exec',
	      code	=> sub {print 1},
	      expect	=> 'print',
	      expect_nt	=> 'leavesub');

checkOptree ( name	=> 'test skip itself',
	      skip	=> 1,
	      bcopts	=> '-exec',
	      code	=> sub {print 1},
	      expect	=> 'dont-care, skipping',
	      expect_nt	=> 'this insures failure');

checkOptree ( name	=> 'test todo itself',
	      todo	=> "your excuse here ;-)",
	      bcopts	=> '-exec',
	      code	=> sub {print 1},
	      expect	=> 'print',
	      expect_nt	=> 'print');

checkOptree ( name	=> 'impossible match, remove skip to see failure',
	      todo	=> "see! it breaks!",
	      skip	=> 1, # but skip it 1st
	      code	=> sub {print 1},
	      expect	=> 'look out ! Boy Wonder',
	      expect_nt	=> 'holy near earth asteroid Batman !');

pass ("TEST FATAL ERRS");

if (1) {
    # test for fatal errors. Im unsettled on fail vs die.
    # calling fail isnt good enough by itself.
    eval {
	
	checkOptree ( name	=> 'empty code or prog',
		      todo	=> "your excuse here ;-)",
		      code	=> '',
		      prog	=> '',
		      );
    };
    like($@, 'code or prog is required', 'empty code or prog prevented');
    
    $@='';
    eval {
	checkOptree ( name	=> 'test against empty expectations',
		      bcopts	=> '-exec',
		      code	=> sub {print 1},
		      expect	=> '',
		      expect_nt	=> '');
    };
    like($@, 'no reftext found for', "empty expectations prevented");
    
    $@='';
    eval {
	checkOptree ( name	=> 'prevent whitespace only expectations',
		      bcopts	=> '-exec',
		      code	=> sub {my $a},
		      #skip	=> 1,
		      expect_nt	=> "\n",
		      expect	=> "\n");
    };
    like($@, 'no reftext found for', "just whitespace expectations prevented");
}

pass ("TEST -e \$srcCode");

checkOptree ( name	=> '-w errors seen',
	      prog	=> 'sort our @a',
	      expect	=> 'Useless use of sort in void context',
	      expect_nt	=> 'Useless use of sort in void context');

checkOptree ( name	=> "self strict, catch err",
	      prog	=> 'use strict; bogus',
	      expect	=> 'strict subs',
	      expect_nt	=> 'strict subs');

checkOptree ( name	=> "sort vK - flag specific search",
	      prog	=> 'sort our @a',
	      expect	=> '<@> sort vK ',
	      expect_nt	=> '<@> sort vK ');

checkOptree ( name	=> "'prog' => 'sort our \@a'",
	      prog	=> 'sort our @a',
	      expect	=> '<@> sort vK',
	      expect_nt	=> '<@> sort vK');

checkOptree ( name	=> "'code' => 'sort our \@a'",
	      code	=> 'sort our @a',
	      expect	=> '<@> sort K',
	      expect_nt	=> '<@> sort K');

pass ("REFTEXT FIXUP TESTS");

checkOptree ( name	=> 'fixup nextstate (in reftext)',
	      bcopts	=> '-exec',
	      code	=> sub {my $a},
	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
#            goto -
# 1  <;> nextstate( NOTE THAT THIS CAN BE ANYTHING ) v
# 2  <0> padsv[$a:54,55] M/LVINTRO
# 3  <1> leavesub[1 ref] K/REFC,1
EOT_EOT
#            goto -
# 1  <;> nextstate(main 54 optree_concise.t:84) v
# 2  <0> padsv[$a:54,55] M/LVINTRO
# 3  <1> leavesub[1 ref] K/REFC,1
EONT_EONT

checkOptree ( name	=> 'fixup square-bracket args',
	      bcopts	=> '-exec',
	      todo	=> 'not done in rexpedant mode',
	      code	=> sub {my $a},
	      #skip	=> 1,
	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
#            goto -
# 1  <;> nextstate(main 56 optree_concise.t:96) v
# 2  <0> padsv[$a:56,57] M/LVINTRO
# 3  <1> leavesub[1 ref] K/REFC,1
EOT_EOT
#            goto -
# 1  <;> nextstate(main 56 optree_concise.t:96) v
# 2  <0> padsv[$a:56,57] M/LVINTRO
# 3  <1> leavesub[1 ref] K/REFC,1
EONT_EONT

checkOptree ( name	=> 'unneeded manual rex-ify by test author',
	      # args in 1,2 are manually edited, unnecessarily
	      bcopts	=> '-exec',
	      code	=> sub {my $a},
	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1  <;> nextstate(.*?) v
# 2  <0> padsv[.*?] M/LVINTRO
# 3  <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1  <;> nextstate(main 57 optree_concise.t:108) v
# 2  <0> padsv[$a:57,58] M/LVINTRO
# 3  <1> leavesub[1 ref] K/REFC,1
EONT_EONT

#################################
pass("CANONICAL B::Concise EXAMPLE");

checkOptree ( name	=> 'canonical example w -basic',
	      bcopts	=> '-basic',
	      code	=>  sub{$a=$b+42},
	      crossfail => 1,
	      debug	=> 1,
	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 7  <1> leavesub[1 ref] K/REFC,1 ->(end)
# -     <@> lineseq KP ->7
# 1        <;> nextstate(main 380 optree_selftest.t:139) v ->2
# 6        <2> sassign sKS/2 ->7
# 4           <2> add[t3] sK/2 ->5
# -              <1> ex-rv2sv sK/1 ->3
# 2                 <#> gvsv[*b] s ->3
# 3              <$> const[IV 42] s ->4
# -           <1> ex-rv2sv sKRM*/1 ->6
# 5              <#> gvsv[*a] s ->6
EOT_EOT
# 7  <1> leavesub[1 ref] K/REFC,1 ->(end)
# -     <@> lineseq KP ->7
# 1        <;> nextstate(main 60 optree_concise.t:122) v ->2
# 6        <2> sassign sKS/2 ->7
# 4           <2> add[t1] sK/2 ->5
# -              <1> ex-rv2sv sK/1 ->3
# 2                 <$> gvsv(*b) s ->3
# 3              <$> const(IV 42) s ->4
# -           <1> ex-rv2sv sKRM*/1 ->6
# 5              <$> gvsv(*a) s ->6
EONT_EONT

checkOptree ( name	=> 'canonical example w -exec',
	      bcopts	=> '-exec',
	      code	=> sub{$a=$b+42},
	      crossfail => 1,
	      retry	=> 1,
	      debug	=> 1,
	      xtestfail	=> 1,
	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
#            goto -
# 1  <;> nextstate(main 61 optree_concise.t:139) v
# 2  <#> gvsv[*b] s
# 3  <$> const[IV 42] s
# 4  <2> add[t3] sK/2
# 5  <#> gvsv[*a] s
# 6  <2> sassign sKS/2
# 7  <1> leavesub[1 ref] K/REFC,1
EOT_EOT
#            goto -
# 1  <;> nextstate(main 61 optree_concise.t:139) v
# 2  <$> gvsv(*b) s
# 3  <$> const(IV 42) s
# 4  <2> add[t1] sK/2
# 5  <$> gvsv(*a) s
# 6  <2> sassign sKS/2
# 7  <1> leavesub[1 ref] K/REFC,1
EONT_EONT

checkOptree ( name	=> 'tree reftext is messy cut-paste',
	      skip	=> 1);

} # skip

__END__
Commit	Line	Data
724aa791	1	#!perl
	2
	3	BEGIN {
	4	chdir 't';
	5	@INC = ('../lib', '../ext/B/t');
	6	require './test.pl';
	7	}
	8
	9	use OptreeCheck;
	10
	11	=head1 OptreeCheck selftest harness
	12
	13	This file is primarily to test services of OptreeCheck itself, ie
	14	checkOptree(). %gOpts provides test-state info, it is 'exported' into
	15	main::
	16
	17	doing use OptreeCheck runs import(), which processes @ARGV to process
	18	cmdline args in 'standard' way across all clients of OptreeCheck.
	19
	20	=cut
	21
2ce64696	22	use Config;
724aa791	23	plan tests => 5 + 19 + 14 * $gOpts{selftest}; # fudged
724aa791	24
2ce64696	25	SKIP: {
	26	skip "no perlio in this build", 5 + 19 + 14 * $gOpts{selftest}
	27	unless $Config::Config{useperlio};
	28
	29
724aa791	30	pass("REGEX TEST HARNESS SELFTEST");
	31
	32	checkOptree ( name => "bare minimum opcode search",
	33	bcopts => '-exec',
	34	code => sub {my $a},
	35	expect => 'leavesub',
	36	expect_nt => 'leavesub');
	37
	38	checkOptree ( name => "found print opcode",
	39	bcopts => '-exec',
	40	code => sub {print 1},
	41	expect => 'print',
	42	expect_nt => 'leavesub');
	43
	44	checkOptree ( name => 'test skip itself',
	45	skip => 1,
	46	bcopts => '-exec',
	47	code => sub {print 1},
	48	expect => 'dont-care, skipping',
	49	expect_nt => 'this insures failure');
	50
	51	checkOptree ( name => 'test todo itself',
	52	todo => "your excuse here ;-)",
	53	bcopts => '-exec',
	54	code => sub {print 1},
	55	expect => 'print',
	56	expect_nt => 'print');
	57
	58	checkOptree ( name => 'impossible match, remove skip to see failure',
	59	todo => "see! it breaks!",
	60	skip => 1, # but skip it 1st
	61	code => sub {print 1},
	62	expect => 'look out ! Boy Wonder',
	63	expect_nt => 'holy near earth asteroid Batman !');
	64
	65	pass ("TEST FATAL ERRS");
	66
	67	if (1) {
	68	# test for fatal errors. Im unsettled on fail vs die.
	69	# calling fail isnt good enough by itself.
	70	eval {
	71
	72	checkOptree ( name => 'empty code or prog',
	73	todo => "your excuse here ;-)",
	74	code => '',
	75	prog => '',
	76	);
	77	};
	78	like($@, 'code or prog is required', 'empty code or prog prevented');
	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($@, 'no reftext found for', "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($@, 'no reftext found for', "just whitespace expectations prevented");
100	}
101
102	pass ("TEST -e \$srcCode");
103
104	checkOptree ( name => '-w errors seen',
105	prog => 'sort our @a',
106	expect => 'Useless use of sort in void context',
107	expect_nt => 'Useless use of sort in void context');
108
109	checkOptree ( name => "self strict, catch err",
110	prog => 'use strict; bogus',
111	expect => 'strict subs',
112	expect_nt => 'strict subs');
113
114	checkOptree ( name => "sort vK - flag specific search",
115	prog => 'sort our @a',
116	expect => '<@> sort vK ',
117	expect_nt => '<@> sort vK ');
118
119	checkOptree ( name => "'prog' => 'sort our \@a'",
120	prog => 'sort our @a',
121	expect => '<@> sort vK',
122	expect_nt => '<@> sort vK');
123
124	checkOptree ( name => "'code' => 'sort our \@a'",
125	code => 'sort our @a',
126	expect => '<@> sort K',
127	expect_nt => '<@> sort K');
128
129	pass ("REFTEXT FIXUP TESTS");
130
131	checkOptree ( name => 'fixup nextstate (in reftext)',
132	bcopts => '-exec',
133	code => sub {my $a},
134	expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
135	# goto -
136	# 1 <;> nextstate( NOTE THAT THIS CAN BE ANYTHING ) v
137	# 2 <0> padsv[$a:54,55] M/LVINTRO
138	# 3 <1> leavesub[1 ref] K/REFC,1
139	EOT_EOT
140	# goto -
141	# 1 <;> nextstate(main 54 optree_concise.t:84) v
142	# 2 <0> padsv[$a:54,55] M/LVINTRO
143	# 3 <1> leavesub[1 ref] K/REFC,1
144	EONT_EONT
145
146	checkOptree ( name => 'fixup square-bracket args',
147	bcopts => '-exec',
148	todo => 'not done in rexpedant mode',
149	code => sub {my $a},
150	#skip => 1,
151	expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
152	# goto -
153	# 1 <;> nextstate(main 56 optree_concise.t:96) v
154	# 2 <0> padsv[$a:56,57] M/LVINTRO
155	# 3 <1> leavesub[1 ref] K/REFC,1
156	EOT_EOT
157	# goto -
158	# 1 <;> nextstate(main 56 optree_concise.t:96) v
159	# 2 <0> padsv[$a:56,57] M/LVINTRO
160	# 3 <1> leavesub[1 ref] K/REFC,1
161	EONT_EONT
162
163	checkOptree ( name => 'unneeded manual rex-ify by test author',
164	# args in 1,2 are manually edited, unnecessarily
165	bcopts => '-exec',
166	code => sub {my $a},
167	expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
168	# 1 <;> nextstate(.*?) v
169	# 2 <0> padsv[.*?] M/LVINTRO
170	# 3 <1> leavesub[1 ref] K/REFC,1
171	EOT_EOT
172	# 1 <;> nextstate(main 57 optree_concise.t:108) v
173	# 2 <0> padsv[$a:57,58] M/LVINTRO
174	# 3 <1> leavesub[1 ref] K/REFC,1
175	EONT_EONT
176
177	#################################
178	pass("CANONICAL B::Concise EXAMPLE");
179
180	checkOptree ( name => 'canonical example w -basic',
181	bcopts => '-basic',
182	code => sub{$a=$b+42},
183	crossfail => 1,
184	debug => 1,
185	expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
186	# 7 <1> leavesub[1 ref] K/REFC,1 ->(end)
187	# - <@> lineseq KP ->7
188	# 1 <;> nextstate(main 380 optree_selftest.t:139) v ->2
189	# 6 <2> sassign sKS/2 ->7
190	# 4 <2> add[t3] sK/2 ->5
191	# - <1> ex-rv2sv sK/1 ->3
192	# 2 <#> gvsv[*b] s ->3
193	# 3 <$> const[IV 42] s ->4
194	# - <1> ex-rv2sv sKRM*/1 ->6
195	# 5 <#> gvsv[*a] s ->6
196	EOT_EOT
197	# 7 <1> leavesub[1 ref] K/REFC,1 ->(end)
198	# - <@> lineseq KP ->7
199	# 1 <;> nextstate(main 60 optree_concise.t:122) v ->2
200	# 6 <2> sassign sKS/2 ->7
201	# 4 <2> add[t1] sK/2 ->5
202	# - <1> ex-rv2sv sK/1 ->3
203	# 2 <$> gvsv(*b) s ->3
204	# 3 <$> const(IV 42) s ->4
205	# - <1> ex-rv2sv sKRM*/1 ->6
206	# 5 <$> gvsv(*a) s ->6
207	EONT_EONT
208
209	checkOptree ( name => 'canonical example w -exec',
210	bcopts => '-exec',
211	code => sub{$a=$b+42},
212	crossfail => 1,
213	retry => 1,
214	debug => 1,
215	xtestfail => 1,
216	expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
217	# goto -
218	# 1 <;> nextstate(main 61 optree_concise.t:139) v
219	# 2 <#> gvsv[*b] s
220	# 3 <$> const[IV 42] s
221	# 4 <2> add[t3] sK/2
222	# 5 <#> gvsv[*a] s
223	# 6 <2> sassign sKS/2
224	# 7 <1> leavesub[1 ref] K/REFC,1
225	EOT_EOT
226	# goto -
227	# 1 <;> nextstate(main 61 optree_concise.t:139) v
228	# 2 <$> gvsv(*b) s
229	# 3 <$> const(IV 42) s
230	# 4 <2> add[t1] sK/2
231	# 5 <$> gvsv(*a) s
232	# 6 <2> sassign sKS/2
233	# 7 <1> leavesub[1 ref] K/REFC,1
234	EONT_EONT
235
236	checkOptree ( name => 'tree reftext is messy cut-paste',
237	skip => 1);
238
2ce64696	239	} # skip
724aa791	240
	241	__END__
	242