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

#!perl

BEGIN {
    chdir 't';
    @INC = ('../lib', '../ext/B/t');
    require Config;
    if (($Config::Config{'extensions'} !~ /\bB\b/) ){
        print "1..0 # Skip -- Perl configured without B module\n";
        exit 0;
    }
    if ($Config{'extensions'} !~ /\bData\/Dumper\b/) {
	print
	    "1..0 # Skip: Data::Dumper was not built, needed by OptreeCheck\n";
	exit 0;

    }
    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 + 18 + 14 * $gOpts{selftest};	# fudged

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


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	=> 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},
	      noanchors	=> 1, # unanchored match
	      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',
	      noanchors	=> 1, # unanchored match
	      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',
	      noanchors	=> 1,
	      expect	=> 'strict subs',
	      expect_nt	=> 'strict subs');

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

checkOptree ( name	=> "'prog' => 'sort our \@a'",
	      prog	=> 'sort our @a',
	      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},
	      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 square-bracket args',
	      bcopts	=> '-exec',
	      todo	=> 'not done in rexpedant mode',
	      code	=> sub {my $a},
	      #skip	=> 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,
	      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');
# 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

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