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

#!perl

BEGIN {
    if ($ENV{PERL_CORE}){
	chdir('t') if -d 't';
	@INC = ('.', '../lib', '../ext/B/t');
    } else {
	unshift @INC, 't';
	push @INC, "../../t";
    }
    require Config;
    if (($Config::Config{'extensions'} !~ /\bB\b/) ){
        print "1..0 # Skip -- Perl configured without B module\n";
        exit 0;
    }
    # require 'test.pl'; # now done by OptreeCheck
}

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

my $tests = 5 + 15 + 16 * $gOpts{selftest};	# pass()s + $#tests
plan tests => $tests;

SKIP: {
    skip "no perlio in this build", $tests
    unless $Config::Config{useperlio};

my @open_todo;
sub open_todo {
    if (((caller 0)[10]||{})->{open}) {
	@open_todo = (skip => "\$^OPEN is set");
    }
}
open_todo;

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($@, /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($@, /no '\w+' golden-sample found/,
	 "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},
	      @open_todo,
	      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},
	      @open_todo,
	      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,
	      debug	=> 1,
	      @open_todo,
	      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 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
# 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

} # skip

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