This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
5.8's B.xs exports AVf_REAL, so need to jiggle the test count by 1.
[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 6
d51cf0c9
JC
7To verify that B::Concise properly reports whether functions are XS,
8perl, or optimized constant subs, we test against a few core packages
9which have a stable API, and which have functions of all 3 types.
10
11=head1 WHAT IS TESTED
12
135 core packages are tested; Digest::MD5, B, B::Deparse, Data::Dumper,
14and POSIX. These have a mix of the 3 expected implementation types;
15perl, XS, and constant (optimized constant subs).
16
17%$testpkgs specifies what packages are tested; each package is loaded,
18and the stash is scanned for the function-names in that package.
19
20Each value in %$testpkgs is a hash-of-lists (HoL) whose keys are
21implementation-types and values are lists of function-names of that type.
22
23To keep these HoLs smaller and more managable, they may carry an
24additional 'dflt' => $impl_Type, which means that unnamed functions
25are expected to be of that default implementation type. Those unnamed
26functions are known from the scan of the package stash.
27
28=head1 HOW THEY'RE TESTED
29
30Each function is 'rendered' by B::Concise, and result is matched
31against regexs for each possible implementation-type. For some
32packages, some functions may be unimplemented on some platforms.
33
34To slay this maintenance dragon, the regexs used in like() match
35against renderings which indicate that there is no implementation.
36
37If a function is implemented differently on different platforms, the
38test for that function will fail on one of those platforms. These
39specific functions can be skipped by a 'skip' => [ @list ] to the HoL
40mentioned previously. See usage for skip in B's HoL, which avoids
41testing a function which doesnt exist on non-threaded builds.
c0939cee 42
5b493bdf
JC
43=head1 OPTIONS AND ARGUMENTS
44
45C<-v> and C<-V> trigger 2 levels of verbosity.
46
47C<-a> uses Module::CoreList to run all core packages through the test, which
48gives some interesting results.
49
50C<-c> causes the expected XS/non-XS results to be marked with
d51cf0c9
JC
51corrections, which are then reported at program END, in a form that's
52readily cut-and-pastable into this file.
53
5b493bdf
JC
54
55C<< -r <file> >> reads a file, as written by C<-c>, and adjusts the expected
56results accordingly. The file is 'required', so @INC settings apply.
57
c0939cee
JC
58If module-names are given as args, those packages are run through the
59test harness; this is handy for collecting further items to test, and
60may be useful otherwise (ie just to see).
61
5b493bdf
JC
62=head1 EXAMPLES
63
5b493bdf
JC
64=over 4
65
66=item ./perl -Ilib -wS ext/B/t/concise-xs.t -c Storable
67
68Tests Storable.pm for XS/non-XS routines, writes findings (along with
69test results) to stdout. You could edit results to produce a test
70file, as in next example
71
72=item ./perl -Ilib -wS ext/B/t/concise-xs.t -r ./storable
c0939cee 73
5b493bdf
JC
74Loads file, and uses it to set expectations, and run tests
75
76=item ./perl -Ilib -wS ext/B/t/concise-xs.t -avc > ../foo-avc 2> ../foo-avc2
77
78Gets module list from Module::Corelist, and runs them all through the
79test. Since -c is used, this generates corrections, which are saved
80in a file, which is edited down to produce ../all-xs
81
82=item ./perl -Ilib -wS ext/B/t/concise-xs.t -cr ../all-xs > ../foo 2> ../foo2
83
84This runs the tests specified in the file created in previous example.
85-c is used again, and stdout verifies that all the expected results
86given by -r ../all-xs are now seen.
87
88Looking at ../foo2, you'll see 34 occurrences of the following error:
89
90# err: Can't use an undefined value as a SCALAR reference at
91# lib/B/Concise.pm line 634, <DATA> line 1.
92
93=back
c0939cee
JC
94
95=cut
96
97BEGIN {
98 if ($ENV{PERL_CORE}) {
99 chdir('t') if -d 't';
100 @INC = ('.', '../lib');
101 } else {
102 unshift @INC, 't';
103 push @INC, "../../t";
104 }
105 require Config;
106 if (($Config::Config{'extensions'} !~ /\bB\b/) ){
107 print "1..0 # Skip -- Perl configured without B module\n";
108 exit 0;
109 }
28380c63
NC
110 unless ($Config::Config{useperlio}) {
111 print "1..0 # Skip -- Perl configured without perlio\n";
112 exit 0;
113 }
c0939cee
JC
114}
115
116use Getopt::Std;
117use Carp;
2018a5c3
JC
118use Test::More tests => ( # per-pkg tests (function ct + require_ok)
119 40 + 16 # Data::Dumper, Digest::MD5
cde0cee5 120 + 517 + 239 # B::Deparse, B
fba16c4d 121 + 595 + 190 # POSIX, IO::Socket
5c721124 122 + 345 * ($] > 5.009)
e412117e 123 + 17 * ($] >= 5.009003)
5c721124 124 - 365); # fudge
c0939cee
JC
125
126require_ok("B::Concise");
127
d51cf0c9
JC
128my %matchers =
129 ( constant => qr{ (?-x: is a constant sub, optimized to a \w+)
130 |(?-x: exists in stash, but has no START) }x,
2018a5c3
JC
131 XS => qr/ is XS code/,
132 perl => qr/ (next|db)state/,
133 noSTART => qr/ exists in stash, but has no START/,
d51cf0c9 134);
5b493bdf 135
d51cf0c9
JC
136my $testpkgs = {
137 # packages to test, with expected types for named funcs
138
139 Digest::MD5 => { perl => [qw/ import /],
140 dflt => 'XS' },
141
142 Data::Dumper => { XS => [qw/ bootstrap Dumpxs /],
143 dflt => 'perl' },
144 B => {
145 dflt => 'constant', # all but 47/274
146 skip => [ 'regex_padav' ], # threaded only
147 perl => [qw(
148 walksymtable walkoptree_slow walkoptree_exec
149 timing_info savesym peekop parents objsym debug
150 compile_stats clearsym class
151 )],
152 XS => [qw(
153 warnhook walkoptree_debug walkoptree threadsv_names
154 svref_2object sv_yes sv_undef sv_no save_BEGINs
155 regex_padav ppname perlstring opnumber minus_c
156 main_start main_root main_cv init_av inc_gv hash
157 formfeed end_av dowarn diehook defstash curstash
158 cstring comppadlist check_av cchar cast_I32 bootstrap
5ce57cc0 159 begin_av amagic_generation sub_generation address
e412117e 160 ), $] > 5.009 ? ('unitcheck_av') : ()],
d51cf0c9
JC
161 },
162
163 B::Deparse => { dflt => 'perl', # 235 functions
164
165 XS => [qw( svref_2object perlstring opnumber main_start
166 main_root main_cv )],
167
168 constant => [qw/ ASSIGN CVf_ASSERTION CVf_LOCKED CVf_LVALUE
169 CVf_METHOD LIST_CONTEXT OP_CONST OP_LIST OP_RV2SV
170 OP_STRINGIFY OPf_KIDS OPf_MOD OPf_REF OPf_SPECIAL
171 OPf_STACKED OPf_WANT OPf_WANT_LIST OPf_WANT_SCALAR
172 OPf_WANT_VOID OPpCONST_ARYBASE OPpCONST_BARE
173 OPpENTERSUB_AMPER OPpEXISTS_SUB OPpITER_REVERSED
174 OPpLVAL_INTRO OPpOUR_INTRO OPpSLICE OPpSORT_DESCEND
175 OPpSORT_INPLACE OPpSORT_INTEGER OPpSORT_NUMERIC
176 OPpSORT_REVERSE OPpTARGET_MY OPpTRANS_COMPLEMENT
177 OPpTRANS_DELETE OPpTRANS_SQUASH PMf_CONTINUE
178 PMf_EVAL PMf_EXTENDED PMf_FOLD PMf_GLOBAL PMf_KEEP
179 PMf_MULTILINE PMf_ONCE PMf_SINGLELINE PMf_SKIPWHITE
180 POSTFIX SVf_FAKE SVf_IOK SVf_NOK SVf_POK SVf_ROK
d449ddce 181 SVpad_OUR SVs_RMG SVs_SMG SWAP_CHILDREN OPpPAD_STATE
d51cf0c9
JC
182 /],
183 },
184
f9f861ec
JC
185 POSIX => { dflt => 'constant', # all but 252/589
186 skip => [qw/ _POSIX_JOB_CONTROL /], # platform varying
d51cf0c9
JC
187 perl => [qw/ import croak AUTOLOAD /],
188
189 XS => [qw/ write wctomb wcstombs uname tzset tzname
190 ttyname tmpnam times tcsetpgrp tcsendbreak
191 tcgetpgrp tcflush tcflow tcdrain tanh tan
192 sysconf strxfrm strtoul strtol strtod
193 strftime strcoll sinh sigsuspend sigprocmask
194 sigpending sigaction setuid setsid setpgid
195 setlocale setgid read pipe pause pathconf
196 open nice modf mktime mkfifo mbtowc mbstowcs
197 mblen lseek log10 localeconv ldexp lchown
198 isxdigit isupper isspace ispunct isprint
199 islower isgraph isdigit iscntrl isalpha
200 isalnum int_macro_int getcwd frexp fpathconf
201 fmod floor dup2 dup difftime cuserid ctime
202 ctermid cosh constant close clock ceil
203 bootstrap atan asin asctime acos access abort
2018a5c3 204 _exit
d51cf0c9
JC
205 /],
206 },
2018a5c3 207
f84b4b22 208 IO::Socket => { dflt => 'constant', # 157/190
2018a5c3
JC
209
210 perl => [qw/ timeout socktype sockopt sockname
211 socketpair socket sockdomain sockaddr_un
212 sockaddr_in shutdown setsockopt send
213 register_domain recv protocol peername
214 new listen import getsockopt croak
215 connected connect configure confess close
e412117e
NC
216 carp bind atmark accept
217 /, $] > 5.009 ? ('blocking') : () ],
2018a5c3
JC
218
219 XS => [qw/ unpack_sockaddr_un unpack_sockaddr_in
220 sockatmark sockaddr_family pack_sockaddr_un
221 pack_sockaddr_in inet_ntoa inet_aton
222 /],
223 },
c0939cee
JC
224};
225
226############
227
228B::Concise::compile('-nobanner'); # set a silent default
5b493bdf 229getopts('vaVcr:', \my %opts) or
c0939cee
JC
230 die <<EODIE;
231
232usage: PERL_CORE=1 ./perl ext/B/t/concise-xs.t [-av] [module-list]
233 tests ability to discern XS funcs using Digest::MD5 package
234 -v : runs verbosely
235 -V : more verbosity
236 -a : runs all modules in CoreList
5b493bdf
JC
237 -c : writes test corrections as a Data::Dumper expression
238 -r <file> : reads file of tests, as written by -c
468aa647 239 <args> : additional modules are loaded and tested
d51cf0c9 240 (will report failures, since no XS funcs are known apriori)
c0939cee
JC
241
242EODIE
243 ;
244
245if (%opts) {
246 require Data::Dumper;
247 Data::Dumper->import('Dumper');
248 $Data::Dumper::Sortkeys = 1;
249}
250my @argpkgs = @ARGV;
5b493bdf
JC
251my %report;
252
253if ($opts{r}) {
254 my $refpkgs = require "$opts{r}";
255 $testpkgs->{$_} = $refpkgs->{$_} foreach keys %$refpkgs;
468aa647 256}
5b493bdf
JC
257
258unless ($opts{a}) {
259 unless (@argpkgs) {
260 foreach $pkg (sort keys %$testpkgs) {
261 test_pkg($pkg, $testpkgs->{$pkg});
262 }
263 } else {
264 foreach $pkg (@argpkgs) {
265 test_pkg($pkg, $testpkgs->{$pkg});
266 }
267 }
268} else {
269 corecheck();
c0939cee 270}
c0939cee
JC
271############
272
273sub test_pkg {
d51cf0c9
JC
274 my ($pkg, $fntypes) = @_;
275 require_ok($pkg);
c0939cee 276
d51cf0c9 277 # build %stash: keys are func-names, vals filled in below
c0939cee 278 my (%stash) = map
d51cf0c9
JC
279 ( ($_ => 0)
280 => ( grep exists &{"$pkg\::$_"} # grab CODE symbols
c0939cee 281 => grep !/__ANON__/ # but not anon subs
d51cf0c9 282 => keys %{$pkg.'::'} # from symbol table
c0939cee 283 ));
468aa647 284
d51cf0c9
JC
285 for my $type (keys %matchers) {
286 foreach my $fn (@{$fntypes->{$type}}) {
287 carp "$fn can only be one of $type, $stash{$fn}\n"
288 if $stash{$fn};
289 $stash{$fn} = $type;
290 }
291 }
292 # set default type for un-named functions
293 my $dflt = $fntypes->{dflt} || 'perl';
294 for my $k (keys %stash) {
295 $stash{$k} = $dflt unless $stash{$k};
296 }
297 $stash{$_} = 'skip' foreach @{$fntypes->{skip}};
c0939cee 298
5b493bdf 299 if ($opts{v}) {
d51cf0c9
JC
300 diag("fntypes: " => Dumper($fntypes));
301 diag("$pkg stash: " => Dumper(\%stash));
c0939cee 302 }
d51cf0c9
JC
303 foreach my $fn (reverse sort keys %stash) {
304 next if $stash{$fn} eq 'skip';
305 my $res = checkXS("${pkg}::$fn", $stash{$fn});
306 if ($res ne '1') {
307 push @{$report{$pkg}{$res}}, $fn;
5b493bdf 308 }
c0939cee
JC
309 }
310}
311
312sub checkXS {
d51cf0c9
JC
313 my ($func_name, $want) = @_;
314
315 croak "unknown type $want: $func_name\n"
316 unless defined $matchers{$want};
c0939cee
JC
317
318 my ($buf, $err) = render($func_name);
d51cf0c9
JC
319 my $res = like($buf, $matchers{$want}, "$want sub:\t $func_name");
320
321 unless ($res) {
322 # test failed. return type that would give success
323 for my $m (keys %matchers) {
324 return $m if $buf =~ $matchers{$m};
325 }
c0939cee 326 }
d51cf0c9 327 $res;
c0939cee
JC
328}
329
330sub render {
331 my ($func_name) = @_;
332
333 B::Concise::reset_sequence();
334 B::Concise::walk_output(\my $buf);
335
336 my $walker = B::Concise::compile($func_name);
337 eval { $walker->() };
338 diag("err: $@ $buf") if $@;
339 diag("verbose: $buf") if $opts{V};
340
341 return ($buf, $@);
342}
343
344sub corecheck {
345 eval { require Module::CoreList };
346 if ($@) {
347 warn "Module::CoreList not available on $]\n";
348 return;
349 }
5b493bdf
JC
350 my $mods = $Module::CoreList::version{'5.009002'};
351 $mods = [ sort keys %$mods ];
c0939cee
JC
352 print Dumper($mods);
353
5b493bdf 354 foreach my $pkgnm (@$mods) {
c0939cee
JC
355 test_pkg($pkgnm);
356 }
357}
358
5b493bdf
JC
359END {
360 if ($opts{c}) {
d51cf0c9
JC
361 $Data::Dumper::Indent = 1;
362 print "Corrections: ", Dumper(\%report);
5b493bdf
JC
363
364 foreach my $pkg (sort keys %report) {
d51cf0c9
JC
365 for my $type (keys %matchers) {
366 print "$pkg: $type: @{$report{$pkg}{$type}}\n"
367 if @{$report{$pkg}{$type}};
368 }
5b493bdf 369 }
5b493bdf
JC
370 }
371}
372
c0939cee 373__END__