This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Correct the version-dependant expression for the number of tests, as it
[perl5.git] / ext / B / t / concise-xs.t
CommitLineData
c0939cee
JC
1#!./perl
2
3# 2 purpose file: 1-test 2-demonstrate (via args, -v -a options)
4
5b493bdf 5=head1 SYNOPSIS
c0939cee
JC
6
7To verify that B::Concise properly reports whether functions are XS or
8perl, we test against 2 (currently) core packages which have lots of
5b493bdf 9XS functions: B and Digest::MD5. They're listed in %$testpkgs, along
c0939cee
JC
10with a list of functions that are (or are not) XS. For brevity, you
11can specify the shorter list; if they're non-xs routines, start list
12with a '!'. Data::Dumper is also tested, partly to prove the non-!
13usage.
14
15We demand-load each package, scan its stash for function names, and
16mark them as XS/not-XS according to the list given for each package.
17Then we test B::Concise's report on each.
18
5b493bdf
JC
19=head1 OPTIONS AND ARGUMENTS
20
21C<-v> and C<-V> trigger 2 levels of verbosity.
22
23C<-a> uses Module::CoreList to run all core packages through the test, which
24gives some interesting results.
25
26C<-c> causes the expected XS/non-XS results to be marked with
27corrections, which are then reported at program END, in a
28Data::Dumper statement
29
30C<< -r <file> >> reads a file, as written by C<-c>, and adjusts the expected
31results accordingly. The file is 'required', so @INC settings apply.
32
c0939cee
JC
33If module-names are given as args, those packages are run through the
34test harness; this is handy for collecting further items to test, and
35may be useful otherwise (ie just to see).
36
5b493bdf
JC
37=head1 EXAMPLES
38
39All following examples avoid using PERL_CORE=1, since that changes @INC
40
41=over 4
42
43=item ./perl -Ilib -wS ext/B/t/concise-xs.t -c Storable
44
45Tests Storable.pm for XS/non-XS routines, writes findings (along with
46test results) to stdout. You could edit results to produce a test
47file, as in next example
48
49=item ./perl -Ilib -wS ext/B/t/concise-xs.t -r ./storable
c0939cee 50
5b493bdf
JC
51Loads file, and uses it to set expectations, and run tests
52
53=item ./perl -Ilib -wS ext/B/t/concise-xs.t -avc > ../foo-avc 2> ../foo-avc2
54
55Gets module list from Module::Corelist, and runs them all through the
56test. Since -c is used, this generates corrections, which are saved
57in a file, which is edited down to produce ../all-xs
58
59=item ./perl -Ilib -wS ext/B/t/concise-xs.t -cr ../all-xs > ../foo 2> ../foo2
60
61This runs the tests specified in the file created in previous example.
62-c is used again, and stdout verifies that all the expected results
63given by -r ../all-xs are now seen.
64
65Looking at ../foo2, you'll see 34 occurrences of the following error:
66
67# err: Can't use an undefined value as a SCALAR reference at
68# lib/B/Concise.pm line 634, <DATA> line 1.
69
70=back
c0939cee
JC
71
72=cut
73
74BEGIN {
75 if ($ENV{PERL_CORE}) {
76 chdir('t') if -d 't';
77 @INC = ('.', '../lib');
78 } else {
79 unshift @INC, 't';
80 push @INC, "../../t";
81 }
82 require Config;
83 if (($Config::Config{'extensions'} !~ /\bB\b/) ){
84 print "1..0 # Skip -- Perl configured without B module\n";
85 exit 0;
86 }
87}
88
89use Getopt::Std;
90use Carp;
91use Test::More tests => ( 1 * !!$Config::Config{useithreads}
736c8e74
NC
92 + 1 * ($] > 5.009)
93 + 779 );
c0939cee
JC
94
95require_ok("B::Concise");
96
97my $testpkgs = {
468aa647 98
c0939cee 99 Digest::MD5 => [qw/ ! import /],
468aa647 100
c0939cee
JC
101 B => [qw/ ! class clearsym compile_stats debug objsym parents
102 peekop savesym timing_info walkoptree_exec
103 walkoptree_slow walksymtable /],
104
105 Data::Dumper => [qw/ bootstrap Dumpxs /],
5b493bdf
JC
106
107 B::Deparse => [qw/ ASSIGN CVf_ASSERTION CVf_LOCKED CVf_LVALUE
108 CVf_METHOD LIST_CONTEXT OP_CONST OP_LIST OP_RV2SV
109 OP_STRINGIFY OPf_KIDS OPf_MOD OPf_REF OPf_SPECIAL
110 OPf_STACKED OPf_WANT OPf_WANT_LIST OPf_WANT_SCALAR
111 OPf_WANT_VOID OPpCONST_ARYBASE OPpCONST_BARE
112 OPpENTERSUB_AMPER OPpEXISTS_SUB OPpITER_REVERSED
113 OPpLVAL_INTRO OPpOUR_INTRO OPpSLICE OPpSORT_DESCEND
114 OPpSORT_INPLACE OPpSORT_INTEGER OPpSORT_NUMERIC
115 OPpSORT_REVERSE OPpTARGET_MY OPpTRANS_COMPLEMENT
116 OPpTRANS_DELETE OPpTRANS_SQUASH PMf_CONTINUE
117 PMf_EVAL PMf_EXTENDED PMf_FOLD PMf_GLOBAL PMf_KEEP
118 PMf_MULTILINE PMf_ONCE PMf_SINGLELINE PMf_SKIPWHITE
119 POSTFIX SVf_FAKE SVf_IOK SVf_NOK SVf_POK SVf_ROK
120 SVpad_OUR SVs_RMG SVs_SMG SWAP_CHILDREN main_cv
121 main_root main_start opnumber perlstring
122 svref_2object /],
123
c0939cee
JC
124};
125
126############
127
128B::Concise::compile('-nobanner'); # set a silent default
5b493bdf 129getopts('vaVcr:', \my %opts) or
c0939cee
JC
130 die <<EODIE;
131
132usage: PERL_CORE=1 ./perl ext/B/t/concise-xs.t [-av] [module-list]
133 tests ability to discern XS funcs using Digest::MD5 package
134 -v : runs verbosely
135 -V : more verbosity
136 -a : runs all modules in CoreList
5b493bdf
JC
137 -c : writes test corrections as a Data::Dumper expression
138 -r <file> : reads file of tests, as written by -c
468aa647 139 <args> : additional modules are loaded and tested
c0939cee
JC
140 (will report failures, since no XS funcs are known aprior)
141
142EODIE
143 ;
144
145if (%opts) {
146 require Data::Dumper;
147 Data::Dumper->import('Dumper');
148 $Data::Dumper::Sortkeys = 1;
149}
150my @argpkgs = @ARGV;
5b493bdf
JC
151my %report;
152
153if ($opts{r}) {
154 my $refpkgs = require "$opts{r}";
155 $testpkgs->{$_} = $refpkgs->{$_} foreach keys %$refpkgs;
468aa647 156}
5b493bdf
JC
157
158unless ($opts{a}) {
159 unless (@argpkgs) {
160 foreach $pkg (sort keys %$testpkgs) {
161 test_pkg($pkg, $testpkgs->{$pkg});
162 }
163 } else {
164 foreach $pkg (@argpkgs) {
165 test_pkg($pkg, $testpkgs->{$pkg});
166 }
167 }
168} else {
169 corecheck();
c0939cee 170}
c0939cee
JC
171############
172
173sub test_pkg {
174 my ($pkg_name, $xslist) = @_;
175 require_ok($pkg_name);
176
177 unless (ref $xslist eq 'ARRAY') {
178 warn "no XS/non-XS function list given, assuming empty XS list";
179 $xslist = [''];
180 }
468aa647 181
c0939cee 182 my $assumeXS = 0; # assume list enumerates XS funcs, not perl ones
5b493bdf 183 $assumeXS = 1 if $xslist->[0] and $xslist->[0] eq '!';
468aa647 184
c0939cee
JC
185 # build %stash: keys are func-names, vals: 1 if XS, 0 if not
186 my (%stash) = map
187 ( ($_ => $assumeXS)
188 => ( grep exists &{"$pkg_name\::$_"} # grab CODE symbols
189 => grep !/__ANON__/ # but not anon subs
190 => keys %{$pkg_name.'::'} # from symbol table
191 ));
468aa647 192
c0939cee
JC
193 # now invert according to supplied list
194 $stash{$_} = int ! $assumeXS foreach @$xslist;
468aa647 195
c0939cee
JC
196 # and cleanup cruft (easier than preventing)
197 delete @stash{'!',''};
198
5b493bdf 199 if ($opts{v}) {
c0939cee
JC
200 diag("xslist: " => Dumper($xslist));
201 diag("$pkg_name stash: " => Dumper(\%stash));
202 }
5b493bdf 203 my $err;
c0939cee 204 foreach $func_name (reverse sort keys %stash) {
5b493bdf
JC
205 my $res = checkXS("${pkg_name}::$func_name", $stash{$func_name});
206 if (!$res) {
207 $stash{$func_name} ^= 1;
208 print "$func_name ";
209 $err++;
210 }
c0939cee 211 }
5b493bdf 212 $report{$pkg_name} = \%stash if $opts{c} and $err || $opts{v};
c0939cee
JC
213}
214
215sub checkXS {
216 my ($func_name, $wantXS) = @_;
217
218 my ($buf, $err) = render($func_name);
219 if ($wantXS) {
220 like($buf, qr/\Q$func_name is XS code/,
221 "XS code:\t $func_name");
222 } else {
223 unlike($buf, qr/\Q$func_name is XS code/,
224 "perl code:\t $func_name");
225 }
226 #returns like or unlike, whichever was called
227}
228
229sub render {
230 my ($func_name) = @_;
231
232 B::Concise::reset_sequence();
233 B::Concise::walk_output(\my $buf);
234
235 my $walker = B::Concise::compile($func_name);
236 eval { $walker->() };
237 diag("err: $@ $buf") if $@;
238 diag("verbose: $buf") if $opts{V};
239
240 return ($buf, $@);
241}
242
243sub corecheck {
5b493bdf 244
c0939cee
JC
245 eval { require Module::CoreList };
246 if ($@) {
247 warn "Module::CoreList not available on $]\n";
248 return;
249 }
5b493bdf
JC
250 my $mods = $Module::CoreList::version{'5.009002'};
251 $mods = [ sort keys %$mods ];
c0939cee
JC
252 print Dumper($mods);
253
5b493bdf 254 foreach my $pkgnm (@$mods) {
c0939cee
JC
255 test_pkg($pkgnm);
256 }
257}
258
5b493bdf
JC
259END {
260 if ($opts{c}) {
261 # print "Corrections: ", Dumper(\%report);
262 print "# Tested Package Subroutines, 1's are XS, 0's are perl\n";
263 print "\$VAR1 = {\n";
264
265 foreach my $pkg (sort keys %report) {
266 my (@xs, @perl);
267 my $stash = $report{$pkg};
268
269 @xs = sort grep $stash->{$_} == 1, keys %$stash;
270 @perl = sort grep $stash->{$_} == 0, keys %$stash;
271
272 my @list = (@xs > @perl) ? ( '!', @perl) : @xs;
273 print "\t$pkg => [qw/ @list /],\n";
274 }
275 print "};\n";
276 }
277}
278
c0939cee 279__END__