This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Since we no longer autovivify stashes (change #26370), we need
[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 }
28380c63
NC
87 unless ($Config::Config{useperlio}) {
88 print "1..0 # Skip -- Perl configured without perlio\n";
89 exit 0;
90 }
c0939cee
JC
91}
92
93use Getopt::Std;
94use Carp;
95use Test::More tests => ( 1 * !!$Config::Config{useithreads}
a49b57c6 96 + 3 * ($] > 5.009)
7b9ef140 97 + 14 * ($] >= 5.009003)
e26df76a 98 + 780 );
c0939cee
JC
99
100require_ok("B::Concise");
101
102my $testpkgs = {
468aa647 103
c0939cee 104 Digest::MD5 => [qw/ ! import /],
468aa647 105
c0939cee
JC
106 B => [qw/ ! class clearsym compile_stats debug objsym parents
107 peekop savesym timing_info walkoptree_exec
108 walkoptree_slow walksymtable /],
109
110 Data::Dumper => [qw/ bootstrap Dumpxs /],
5b493bdf
JC
111
112 B::Deparse => [qw/ ASSIGN CVf_ASSERTION CVf_LOCKED CVf_LVALUE
113 CVf_METHOD LIST_CONTEXT OP_CONST OP_LIST OP_RV2SV
114 OP_STRINGIFY OPf_KIDS OPf_MOD OPf_REF OPf_SPECIAL
115 OPf_STACKED OPf_WANT OPf_WANT_LIST OPf_WANT_SCALAR
116 OPf_WANT_VOID OPpCONST_ARYBASE OPpCONST_BARE
117 OPpENTERSUB_AMPER OPpEXISTS_SUB OPpITER_REVERSED
118 OPpLVAL_INTRO OPpOUR_INTRO OPpSLICE OPpSORT_DESCEND
119 OPpSORT_INPLACE OPpSORT_INTEGER OPpSORT_NUMERIC
120 OPpSORT_REVERSE OPpTARGET_MY OPpTRANS_COMPLEMENT
121 OPpTRANS_DELETE OPpTRANS_SQUASH PMf_CONTINUE
122 PMf_EVAL PMf_EXTENDED PMf_FOLD PMf_GLOBAL PMf_KEEP
123 PMf_MULTILINE PMf_ONCE PMf_SINGLELINE PMf_SKIPWHITE
124 POSTFIX SVf_FAKE SVf_IOK SVf_NOK SVf_POK SVf_ROK
125 SVpad_OUR SVs_RMG SVs_SMG SWAP_CHILDREN main_cv
126 main_root main_start opnumber perlstring
127 svref_2object /],
128
c0939cee
JC
129};
130
131############
132
133B::Concise::compile('-nobanner'); # set a silent default
5b493bdf 134getopts('vaVcr:', \my %opts) or
c0939cee
JC
135 die <<EODIE;
136
137usage: PERL_CORE=1 ./perl ext/B/t/concise-xs.t [-av] [module-list]
138 tests ability to discern XS funcs using Digest::MD5 package
139 -v : runs verbosely
140 -V : more verbosity
141 -a : runs all modules in CoreList
5b493bdf
JC
142 -c : writes test corrections as a Data::Dumper expression
143 -r <file> : reads file of tests, as written by -c
468aa647 144 <args> : additional modules are loaded and tested
c0939cee
JC
145 (will report failures, since no XS funcs are known aprior)
146
147EODIE
148 ;
149
150if (%opts) {
151 require Data::Dumper;
152 Data::Dumper->import('Dumper');
153 $Data::Dumper::Sortkeys = 1;
154}
155my @argpkgs = @ARGV;
5b493bdf
JC
156my %report;
157
158if ($opts{r}) {
159 my $refpkgs = require "$opts{r}";
160 $testpkgs->{$_} = $refpkgs->{$_} foreach keys %$refpkgs;
468aa647 161}
5b493bdf
JC
162
163unless ($opts{a}) {
164 unless (@argpkgs) {
165 foreach $pkg (sort keys %$testpkgs) {
166 test_pkg($pkg, $testpkgs->{$pkg});
167 }
168 } else {
169 foreach $pkg (@argpkgs) {
170 test_pkg($pkg, $testpkgs->{$pkg});
171 }
172 }
173} else {
174 corecheck();
c0939cee 175}
c0939cee
JC
176############
177
178sub test_pkg {
179 my ($pkg_name, $xslist) = @_;
180 require_ok($pkg_name);
181
182 unless (ref $xslist eq 'ARRAY') {
183 warn "no XS/non-XS function list given, assuming empty XS list";
184 $xslist = [''];
185 }
468aa647 186
c0939cee 187 my $assumeXS = 0; # assume list enumerates XS funcs, not perl ones
5b493bdf 188 $assumeXS = 1 if $xslist->[0] and $xslist->[0] eq '!';
468aa647 189
c0939cee
JC
190 # build %stash: keys are func-names, vals: 1 if XS, 0 if not
191 my (%stash) = map
192 ( ($_ => $assumeXS)
193 => ( grep exists &{"$pkg_name\::$_"} # grab CODE symbols
194 => grep !/__ANON__/ # but not anon subs
195 => keys %{$pkg_name.'::'} # from symbol table
196 ));
468aa647 197
c0939cee
JC
198 # now invert according to supplied list
199 $stash{$_} = int ! $assumeXS foreach @$xslist;
468aa647 200
c0939cee
JC
201 # and cleanup cruft (easier than preventing)
202 delete @stash{'!',''};
203
5b493bdf 204 if ($opts{v}) {
c0939cee
JC
205 diag("xslist: " => Dumper($xslist));
206 diag("$pkg_name stash: " => Dumper(\%stash));
207 }
5b493bdf 208 my $err;
c0939cee 209 foreach $func_name (reverse sort keys %stash) {
5b493bdf
JC
210 my $res = checkXS("${pkg_name}::$func_name", $stash{$func_name});
211 if (!$res) {
212 $stash{$func_name} ^= 1;
213 print "$func_name ";
214 $err++;
215 }
c0939cee 216 }
5b493bdf 217 $report{$pkg_name} = \%stash if $opts{c} and $err || $opts{v};
c0939cee
JC
218}
219
220sub checkXS {
221 my ($func_name, $wantXS) = @_;
222
223 my ($buf, $err) = render($func_name);
224 if ($wantXS) {
225 like($buf, qr/\Q$func_name is XS code/,
226 "XS code:\t $func_name");
227 } else {
228 unlike($buf, qr/\Q$func_name is XS code/,
229 "perl code:\t $func_name");
230 }
231 #returns like or unlike, whichever was called
232}
233
234sub render {
235 my ($func_name) = @_;
236
237 B::Concise::reset_sequence();
238 B::Concise::walk_output(\my $buf);
239
240 my $walker = B::Concise::compile($func_name);
241 eval { $walker->() };
242 diag("err: $@ $buf") if $@;
243 diag("verbose: $buf") if $opts{V};
244
245 return ($buf, $@);
246}
247
248sub corecheck {
5b493bdf 249
c0939cee
JC
250 eval { require Module::CoreList };
251 if ($@) {
252 warn "Module::CoreList not available on $]\n";
253 return;
254 }
5b493bdf
JC
255 my $mods = $Module::CoreList::version{'5.009002'};
256 $mods = [ sort keys %$mods ];
c0939cee
JC
257 print Dumper($mods);
258
5b493bdf 259 foreach my $pkgnm (@$mods) {
c0939cee
JC
260 test_pkg($pkgnm);
261 }
262}
263
5b493bdf
JC
264END {
265 if ($opts{c}) {
266 # print "Corrections: ", Dumper(\%report);
267 print "# Tested Package Subroutines, 1's are XS, 0's are perl\n";
268 print "\$VAR1 = {\n";
269
270 foreach my $pkg (sort keys %report) {
271 my (@xs, @perl);
272 my $stash = $report{$pkg};
273
274 @xs = sort grep $stash->{$_} == 1, keys %$stash;
275 @perl = sort grep $stash->{$_} == 0, keys %$stash;
276
277 my @list = (@xs > @perl) ? ( '!', @perl) : @xs;
278 print "\t$pkg => [qw/ @list /],\n";
279 }
280 print "};\n";
281 }
282}
283
c0939cee 284__END__