[perl5.git] / ext / B / t / optree_check.t

#!perl

BEGIN {
    unshift @INC, 't';
    require Config;
    if (($Config::Config{'extensions'} !~ /\bB\b/) ){
        print "1..0 # Skip -- Perl configured without B module\n";
        exit 0;
    }
    if (!$Config::Config{useperlio}) {
        print "1..0 # Skip -- need perlio to walk the optree\n";
        exit 0;
    }
}

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

plan tests =>     11 # REGEX TEST HARNESS SELFTEST
		+  3 # TEST FATAL ERRS
		+ 11 # TEST -e \$srcCode
		+  5 # REFTEXT FIXUP TESTS
		+  5 # CANONICAL B::Concise EXAMPLE
		+ 16 * $gOpts{selftest}; # XXX I don't understand this - DAPM

pass("REGEX TEST HARNESS SELFTEST");

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

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

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

# This test 'unexpectedly succeeds', but that is "expected".  Theres
# no good way to expect a successful todo, and inducing a failure
# causes the harness to print verbose errors, which is NOT helpful.

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

checkOptree ( name	=> 'impossible match, remove skip to see failure',
	      todo	=> "see! it breaks!",
	      skip	=> 'skip the failure',
	      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	=> 'test against empty expectations',
		      bcopts	=> '-exec',
		      code	=> sub {print 1},
		      expect	=> '',
		      expect_nt	=> '');
    };
    like($@, qr/no '\w+' golden-sample found/, "empty expectations prevented");
    
    $@='';
    eval {
	checkOptree ( name	=> 'prevent whitespace only expectations',
		      bcopts	=> '-exec',
		      code	=> sub {my $a},
		      #skip	=> 1,
		      expect_nt	=> "\n",
		      expect	=> "\n");
    };
    like($@, qr/whitespace only reftext found for '\w+'/,
	 "just whitespace expectations prevented");
}
    
pass ("TEST -e \$srcCode");

checkOptree ( name	=> 'empty code or prog',
	      skip	=> 'or fails',
	      todo	=> "your excuse here ;-)",
	      code	=> '',
	      prog	=> '',
	      );
    
checkOptree
    (  name	=> "self strict, catch err",
       prog	=> 'use strict; bogus',
       errs	=> 'Bareword "bogus" not allowed while "strict subs" in use at -e line 1.',
       expect	=> "nextstate",	# simple expectations
       expect_nt => "nextstate",
       noanchors => 1,		# allow them to work
       );
    
checkOptree ( name	=> "sort lK - flag specific search",
	      prog	=> 'our (@a,@b); @b = sort @a',
	      noanchors	=> 1,
	      expect	=> '<@> sort lK ',
	      expect_nt	=> '<@> sort lK ');

checkOptree ( name	=> "sort vK - flag specific search",
	      prog	=> 'sort our @a',
	      errs	=> 'Useless use of sort in void context at -e line 1.',
	      noanchors	=> 1,
	      expect	=> '<@> sort vK',
	      expect_nt	=> '<@> sort vK');

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

pass ("REFTEXT FIXUP TESTS");

checkOptree ( name	=> 'fixup nextstate (in reftext)',
	      bcopts	=> '-exec',
	      code	=> sub {my $a},
	      strip_open_hints => 1,
	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 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
# 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 opcode args',
	      bcopts	=> '-exec',
	      #fail	=> 1, # uncomment to see real padsv args: [$a:491,492] 
	      code	=> sub {my $a},
	      strip_open_hints => 1,
	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 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
# 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

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

checkOptree ( name	=> 'canonical example w -basic',
	      bcopts	=> '-basic',
	      code	=>  sub{$a=$b+42},
	      crossfail => 1,
	      strip_open_hints => 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 ( code	=> '$a=$b+42',
	      bcopts	=> '-exec',
	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
# 1  <;> nextstate(main 837 (eval 24):1) 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
# 1  <;> nextstate(main 837 (eval 24):1) 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
Commit	Line	Data
724aa791 JC	1	#!perl
	2
	3	BEGIN {
74517a3a	4	unshift @INC, 't';
9cd8f857 NC	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	}
27e11f68 NC	10	if (!$Config::Config{useperlio}) {
	11	print "1..0 # Skip -- need perlio to walk the optree\n";
	12	exit 0;
	13	}
724aa791 JC	14	}
	15
	16	use OptreeCheck;
	17
	18	=head1 OptreeCheck selftest harness
	19
	20	This file is primarily to test services of OptreeCheck itself, ie
	21	checkOptree(). %gOpts provides test-state info, it is 'exported' into
	22	main::
	23
	24	doing use OptreeCheck runs import(), which processes @ARGV to process
	25	cmdline args in 'standard' way across all clients of OptreeCheck.
	26
	27	=cut
	28
82aeefe1 DM	29	plan 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
2ce64696	35
724aa791 JC	36	pass("REGEX TEST HARNESS SELFTEST");
	37
	38	checkOptree ( name => "bare minimum opcode search",
	39	bcopts => '-exec',
	40	code => sub {my $a},
cc02ea56	41	noanchors => 1, # unanchored match
724aa791 JC	42	expect => 'leavesub',
	43	expect_nt => 'leavesub');
	44
	45	checkOptree ( name => "found print opcode",
	46	bcopts => '-exec',
	47	code => sub {print 1},
cc02ea56	48	noanchors => 1, # unanchored match
724aa791 JC	49	expect => 'print',
	50	expect_nt => 'leavesub');
	51
	52	checkOptree ( name => 'test skip itself',
19e169bf	53	skip => 'this is skip-reason',
724aa791 JC	54	bcopts => '-exec',
	55	code => sub {print 1},
	56	expect => 'dont-care, skipping',
	57	expect_nt => 'this insures failure');
	58
181f6ff5 JC	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
724aa791 JC	63	checkOptree ( name => 'test todo itself',
	64	todo => "your excuse here ;-)",
	65	bcopts => '-exec',
	66	code => sub {print 1},
cc02ea56	67	noanchors => 1, # unanchored match
724aa791	68	expect => 'print',
19e169bf	69	expect_nt => 'print') if 0;
724aa791 JC	70
	71	checkOptree ( name => 'impossible match, remove skip to see failure',
	72	todo => "see! it breaks!",
19e169bf	73	skip => 'skip the failure',
724aa791 JC	74	code => sub {print 1},
	75	expect => 'look out ! Boy Wonder',
	76	expect_nt => 'holy near earth asteroid Batman !');
	77
	78	pass ("TEST FATAL ERRS");
	79
	80	if (1) {
	81	# test for fatal errors. Im unsettled on fail vs die.
	82	# calling fail isnt good enough by itself.
19e169bf	83
724aa791 JC	84	$@='';
	85	eval {
	86	checkOptree ( name => 'test against empty expectations',
	87	bcopts => '-exec',
	88	code => sub {print 1},
	89	expect => '',
	90	expect_nt => '');
	91	};
332878e1	92	like($@, qr/no '\w+' golden-sample found/, "empty expectations prevented");
724aa791 JC	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	};
332878e1	103	like($@, qr/whitespace only reftext found for '\w+'/,
19e169bf	104	"just whitespace expectations prevented");
724aa791	105	}
19e169bf	106
724aa791 JC	107	pass ("TEST -e \$srcCode");
724aa791 JC	108
19e169bf JC	109	checkOptree ( name => 'empty code or prog',
	110	skip => 'or fails',
	111	todo => "your excuse here ;-)",
	112	code => '',
	113	prog => '',
	114	);
5e251bf1 JC	115
	116	checkOptree
	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.',
19e169bf JC	120	expect => "nextstate", # simple expectations
	121	expect_nt => "nextstate",
	122	noanchors => 1, # allow them to work
5e251bf1 JC	123	);
5e251bf1 JC	124
19e169bf JC	125	checkOptree ( name => "sort lK - flag specific search",
19e169bf JC	126	prog => 'our (@a,@b); @b = sort @a',
cc02ea56	127	noanchors => 1,
19e169bf JC	128	expect => '<@> sort lK ',
19e169bf JC	129	expect_nt => '<@> sort lK ');
724aa791	130
19e169bf	131	checkOptree ( name => "sort vK - flag specific search",
724aa791	132	prog => 'sort our @a',
19e169bf	133	errs => 'Useless use of sort in void context at -e line 1.',
cc02ea56	134	noanchors => 1,
724aa791 JC	135	expect => '<@> sort vK',
	136	expect_nt => '<@> sort vK');
	137
	138	checkOptree ( name => "'code' => 'sort our \@a'",
	139	code => 'sort our @a',
cc02ea56	140	noanchors => 1,
724aa791 JC	141	expect => '<@> sort K',
	142	expect_nt => '<@> sort K');
	143
	144	pass ("REFTEXT FIXUP TESTS");
	145
	146	checkOptree ( name => 'fixup nextstate (in reftext)',
	147	bcopts => '-exec',
	148	code => sub {my $a},
be2b1c74	149	strip_open_hints => 1,
724aa791	150	expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
be2b1c74	151	# 1 <;> nextstate( NOTE THAT THIS CAN BE ANYTHING ) v:>,<,%
724aa791 JC	152	# 2 <0> padsv[$a:54,55] M/LVINTRO
	153	# 3 <1> leavesub[1 ref] K/REFC,1
	154	EOT_EOT
be2b1c74	155	# 1 <;> nextstate(main 54 optree_concise.t:84) v:>,<,%
724aa791 JC	156	# 2 <0> padsv[$a:54,55] M/LVINTRO
	157	# 3 <1> leavesub[1 ref] K/REFC,1
	158	EONT_EONT
	159
181f6ff5	160	checkOptree ( name => 'fixup opcode args',
724aa791	161	bcopts => '-exec',
181f6ff5	162	#fail => 1, # uncomment to see real padsv args: [$a:491,492]
724aa791	163	code => sub {my $a},
be2b1c74	164	strip_open_hints => 1,
724aa791	165	expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
be2b1c74	166	# 1 <;> nextstate(main 56 optree_concise.t:96) v:>,<,%
724aa791 JC	167	# 2 <0> padsv[$a:56,57] M/LVINTRO
	168	# 3 <1> leavesub[1 ref] K/REFC,1
	169	EOT_EOT
be2b1c74	170	# 1 <;> nextstate(main 56 optree_concise.t:96) v:>,<,%
724aa791 JC	171	# 2 <0> padsv[$a:56,57] M/LVINTRO
	172	# 3 <1> leavesub[1 ref] K/REFC,1
	173	EONT_EONT
	174
724aa791 JC	175	#################################
	176	pass("CANONICAL B::Concise EXAMPLE");
	177
	178	checkOptree ( name => 'canonical example w -basic',
	179	bcopts => '-basic',
	180	code => sub{$a=$b+42},
	181	crossfail => 1,
be2b1c74	182	strip_open_hints => 1,
724aa791 JC	183	expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
	184	# 7 <1> leavesub[1 ref] K/REFC,1 ->(end)
	185	# - <@> lineseq KP ->7
be2b1c74	186	# 1 <;> nextstate(main 380 optree_selftest.t:139) v:>,<,%,{ ->2
724aa791 JC	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
	194	EOT_EOT
	195	# 7 <1> leavesub[1 ref] K/REFC,1 ->(end)
	196	# - <@> lineseq KP ->7
be2b1c74	197	# 1 <;> nextstate(main 60 optree_concise.t:122) v:>,<,%,{ ->2
724aa791 JC	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
	205	EONT_EONT
	206
19e169bf	207	checkOptree ( code => '$a=$b+42',
724aa791	208	bcopts => '-exec',
724aa791	209	expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
d1718a7c	210	# 1 <;> nextstate(main 837 (eval 24):1) v:{
724aa791 JC	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
	217	EOT_EOT
d1718a7c	218	# 1 <;> nextstate(main 837 (eval 24):1) v:{
724aa791 JC	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
	225	EONT_EONT