This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
concise-xs.t is overly chummy with B::Deparse
[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
b7b1e41b 23To keep these HoLs smaller and more manageable, they may carry an
d51cf0c9
JC
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
b7b1e41b 41testing a function which doesn't 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 {
74517a3a 98 unshift @INC, 't';
c0939cee
JC
99 require Config;
100 if (($Config::Config{'extensions'} !~ /\bB\b/) ){
101 print "1..0 # Skip -- Perl configured without B module\n";
102 exit 0;
103 }
28380c63
NC
104 unless ($Config::Config{useperlio}) {
105 print "1..0 # Skip -- Perl configured without perlio\n";
106 exit 0;
107 }
c0939cee
JC
108}
109
110use Getopt::Std;
111use Carp;
3cd6a7dc 112use Test::More 'no_plan';
c0939cee
JC
113
114require_ok("B::Concise");
115
d51cf0c9
JC
116my %matchers =
117 ( constant => qr{ (?-x: is a constant sub, optimized to a \w+)
118 |(?-x: exists in stash, but has no START) }x,
2018a5c3
JC
119 XS => qr/ is XS code/,
120 perl => qr/ (next|db)state/,
121 noSTART => qr/ exists in stash, but has no START/,
d51cf0c9 122);
5b493bdf 123
d51cf0c9
JC
124my $testpkgs = {
125 # packages to test, with expected types for named funcs
126
127 Digest::MD5 => { perl => [qw/ import /],
128 dflt => 'XS' },
129
32b17be1
DM
130 Data::Dumper => { XS => [qw/ bootstrap Dumpxs /,
131 $] >= 5.015 ? qw/_vstring / : () ],
132 $] >= 5.015
133 ? (constant => ['_bad_vsmg']) : (),
d51cf0c9
JC
134 dflt => 'perl' },
135 B => {
c737faaf 136 dflt => 'constant', # all but 47/297
d51cf0c9
JC
137 skip => [ 'regex_padav' ], # threaded only
138 perl => [qw(
139 walksymtable walkoptree_slow walkoptree_exec
140 timing_info savesym peekop parents objsym debug
141 compile_stats clearsym class
142 )],
143 XS => [qw(
144 warnhook walkoptree_debug walkoptree threadsv_names
145 svref_2object sv_yes sv_undef sv_no save_BEGINs
146 regex_padav ppname perlstring opnumber minus_c
147 main_start main_root main_cv init_av inc_gv hash
148 formfeed end_av dowarn diehook defstash curstash
149 cstring comppadlist check_av cchar cast_I32 bootstrap
5ce57cc0 150 begin_av amagic_generation sub_generation address
35633035 151 unitcheck_av) ],
d51cf0c9
JC
152 },
153
867fa1e2 154 B::Deparse => { dflt => 'perl', # 236 functions
d51cf0c9
JC
155
156 XS => [qw( svref_2object perlstring opnumber main_start
157 main_root main_cv )],
158
e95ab0c0 159 constant => [qw/ ASSIGN CVf_LVALUE
d51cf0c9
JC
160 CVf_METHOD LIST_CONTEXT OP_CONST OP_LIST OP_RV2SV
161 OP_STRINGIFY OPf_KIDS OPf_MOD OPf_REF OPf_SPECIAL
162 OPf_STACKED OPf_WANT OPf_WANT_LIST OPf_WANT_SCALAR
e1dccc0d 163 OPf_WANT_VOID OPpCONST_BARE OPpCONST_NOVER
d51cf0c9
JC
164 OPpENTERSUB_AMPER OPpEXISTS_SUB OPpITER_REVERSED
165 OPpLVAL_INTRO OPpOUR_INTRO OPpSLICE OPpSORT_DESCEND
166 OPpSORT_INPLACE OPpSORT_INTEGER OPpSORT_NUMERIC
689e417f
VP
167 OPpSORT_REVERSE OPpREVERSE_INPLACE OPpTARGET_MY
168 OPpTRANS_COMPLEMENT OPpTRANS_DELETE OPpTRANS_SQUASH
169 PMf_CONTINUE PMf_EVAL PMf_EXTENDED PMf_FOLD PMf_GLOBAL
32b17be1
DM
170 PMf_KEEP PMf_NONDESTRUCT
171 PMf_MULTILINE PMf_ONCE PMf_SINGLELINE
d51cf0c9 172 POSTFIX SVf_FAKE SVf_IOK SVf_NOK SVf_POK SVf_ROK
d449ddce 173 SVpad_OUR SVs_RMG SVs_SMG SWAP_CHILDREN OPpPAD_STATE
bcfcd7d8 174 OPpCONST_ARYBASE RXf_SKIPWHITE SVpad_TYPED/,
32b17be1
DM
175 $] >= 5.015 ? qw(
176 OP_GLOB PMf_SKIPWHITE RXf_PMf_CHARSET RXf_PMf_KEEPCOPY
177 OPpEVAL_BYTES OPpSUBSTR_REPL_FIRST) : (),
e5856194 178 $] >= 5.019 ? qw(OP_PUSHMARK OP_NULL) : (),
aa381260
NC
179 'CVf_LOCKED', # This ends up as a constant, pre or post 5.10
180 ],
d51cf0c9
JC
181 },
182
f9f861ec 183 POSIX => { dflt => 'constant', # all but 252/589
9b68a132 184 skip => [qw/ _POSIX_JOB_CONTROL /, # platform varying
61699fd9 185 # Might be XS or imported from Fcntl, depending on your
9b68a132 186 # perl version:
e99d581a
NC
187 qw / S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISREG /,
188 # Might be XS or AUTOLOADed, depending on your perl
189 # version:
190 qw /WEXITSTATUS WIFEXITED WIFSIGNALED WIFSTOPPED
191 WSTOPSIG WTERMSIG/,
192 'int_macro_int', # Removed in POSIX 1.16
7965edec
JH
193
194 'strtold', # platform varying (C99)
195
a5713e21
JH
196 qw/fegetround fesetround/,
197
7965edec
JH
198 # C99 math
199 qw/acosh asinh atanh cbrt copysign cosh erf
200 erfc exp2 expm1 fdim fma fmax fmin fpclassify
201 hypot ilogb isfinite isgreater isgreaterequal
202 isinf isless islessequal islessgreater isnan
203 isnormal isunordered j0 j1 jn lgamma log1p
9e010b89
JH
204 log2 logb lrint lround nan nearbyint nextafter
205 nexttoward remainder remquo rint round scalbn
206 signbit sinh tanh tgamma trunc y0 y1 yn/,
7965edec 207
e99d581a 208 ],
32b17be1
DM
209 perl => [qw/ import croak AUTOLOAD /,
210 $] >= 5.015
211 ? qw/load_imports usage printf sprintf perror/
212 : (),
213 ],
d51cf0c9
JC
214
215 XS => [qw/ write wctomb wcstombs uname tzset tzname
216 ttyname tmpnam times tcsetpgrp tcsendbreak
217 tcgetpgrp tcflush tcflow tcdrain tanh tan
73e21afd 218 sysconf strxfrm strtoul strtol strtod
d51cf0c9
JC
219 strftime strcoll sinh sigsuspend sigprocmask
220 sigpending sigaction setuid setsid setpgid
221 setlocale setgid read pipe pause pathconf
222 open nice modf mktime mkfifo mbtowc mbstowcs
223 mblen lseek log10 localeconv ldexp lchown
224 isxdigit isupper isspace ispunct isprint
225 islower isgraph isdigit iscntrl isalpha
e99d581a 226 isalnum getcwd frexp fpathconf
d51cf0c9
JC
227 fmod floor dup2 dup difftime cuserid ctime
228 ctermid cosh constant close clock ceil
229 bootstrap atan asin asctime acos access abort
32b17be1
DM
230 _exit
231 /, $] >= 5.015 ? ('sleep') : () ],
d51cf0c9 232 },
2018a5c3 233
f84b4b22 234 IO::Socket => { dflt => 'constant', # 157/190
2018a5c3
JC
235
236 perl => [qw/ timeout socktype sockopt sockname
237 socketpair socket sockdomain sockaddr_un
238 sockaddr_in shutdown setsockopt send
239 register_domain recv protocol peername
240 new listen import getsockopt croak
241 connected connect configure confess close
0c7e1d80 242 carp bind atmark accept sockaddr_in6
35633035 243 blocking/ ],
2018a5c3
JC
244
245 XS => [qw/ unpack_sockaddr_un unpack_sockaddr_in
246 sockatmark sockaddr_family pack_sockaddr_un
247 pack_sockaddr_in inet_ntoa inet_aton
0c7e1d80 248 unpack_sockaddr_in6 pack_sockaddr_in6
2018a5c3 249 /],
d6896be3 250 # skip inet_ntop and inet_pton as they're not exported by default
2018a5c3 251 },
c0939cee
JC
252};
253
254############
255
256B::Concise::compile('-nobanner'); # set a silent default
5b493bdf 257getopts('vaVcr:', \my %opts) or
c0939cee
JC
258 die <<EODIE;
259
260usage: PERL_CORE=1 ./perl ext/B/t/concise-xs.t [-av] [module-list]
261 tests ability to discern XS funcs using Digest::MD5 package
262 -v : runs verbosely
263 -V : more verbosity
264 -a : runs all modules in CoreList
5b493bdf
JC
265 -c : writes test corrections as a Data::Dumper expression
266 -r <file> : reads file of tests, as written by -c
468aa647 267 <args> : additional modules are loaded and tested
d51cf0c9 268 (will report failures, since no XS funcs are known apriori)
c0939cee
JC
269
270EODIE
271 ;
272
273if (%opts) {
274 require Data::Dumper;
275 Data::Dumper->import('Dumper');
82aeefe1 276 { my $x = \*Data::Dumper::Sortkeys } # shut up 'used once' warning
c0939cee
JC
277 $Data::Dumper::Sortkeys = 1;
278}
279my @argpkgs = @ARGV;
5b493bdf
JC
280my %report;
281
282if ($opts{r}) {
283 my $refpkgs = require "$opts{r}";
284 $testpkgs->{$_} = $refpkgs->{$_} foreach keys %$refpkgs;
468aa647 285}
5b493bdf
JC
286
287unless ($opts{a}) {
288 unless (@argpkgs) {
289 foreach $pkg (sort keys %$testpkgs) {
290 test_pkg($pkg, $testpkgs->{$pkg});
291 }
292 } else {
293 foreach $pkg (@argpkgs) {
294 test_pkg($pkg, $testpkgs->{$pkg});
295 }
296 }
297} else {
298 corecheck();
c0939cee 299}
c0939cee
JC
300############
301
302sub test_pkg {
d51cf0c9
JC
303 my ($pkg, $fntypes) = @_;
304 require_ok($pkg);
c0939cee 305
d51cf0c9 306 # build %stash: keys are func-names, vals filled in below
c0939cee 307 my (%stash) = map
d51cf0c9
JC
308 ( ($_ => 0)
309 => ( grep exists &{"$pkg\::$_"} # grab CODE symbols
c0939cee 310 => grep !/__ANON__/ # but not anon subs
d51cf0c9 311 => keys %{$pkg.'::'} # from symbol table
c0939cee 312 ));
468aa647 313
d51cf0c9
JC
314 for my $type (keys %matchers) {
315 foreach my $fn (@{$fntypes->{$type}}) {
316 carp "$fn can only be one of $type, $stash{$fn}\n"
317 if $stash{$fn};
318 $stash{$fn} = $type;
319 }
320 }
321 # set default type for un-named functions
322 my $dflt = $fntypes->{dflt} || 'perl';
323 for my $k (keys %stash) {
324 $stash{$k} = $dflt unless $stash{$k};
325 }
326 $stash{$_} = 'skip' foreach @{$fntypes->{skip}};
c0939cee 327
5b493bdf 328 if ($opts{v}) {
d51cf0c9
JC
329 diag("fntypes: " => Dumper($fntypes));
330 diag("$pkg stash: " => Dumper(\%stash));
c0939cee 331 }
d51cf0c9
JC
332 foreach my $fn (reverse sort keys %stash) {
333 next if $stash{$fn} eq 'skip';
334 my $res = checkXS("${pkg}::$fn", $stash{$fn});
335 if ($res ne '1') {
336 push @{$report{$pkg}{$res}}, $fn;
5b493bdf 337 }
c0939cee
JC
338 }
339}
340
341sub checkXS {
d51cf0c9
JC
342 my ($func_name, $want) = @_;
343
344 croak "unknown type $want: $func_name\n"
345 unless defined $matchers{$want};
c0939cee
JC
346
347 my ($buf, $err) = render($func_name);
d51cf0c9
JC
348 my $res = like($buf, $matchers{$want}, "$want sub:\t $func_name");
349
350 unless ($res) {
351 # test failed. return type that would give success
352 for my $m (keys %matchers) {
353 return $m if $buf =~ $matchers{$m};
354 }
c0939cee 355 }
d51cf0c9 356 $res;
c0939cee
JC
357}
358
359sub render {
360 my ($func_name) = @_;
361
362 B::Concise::reset_sequence();
363 B::Concise::walk_output(\my $buf);
364
365 my $walker = B::Concise::compile($func_name);
366 eval { $walker->() };
367 diag("err: $@ $buf") if $@;
368 diag("verbose: $buf") if $opts{V};
369
370 return ($buf, $@);
371}
372
373sub corecheck {
374 eval { require Module::CoreList };
375 if ($@) {
376 warn "Module::CoreList not available on $]\n";
377 return;
378 }
82aeefe1 379 { my $x = \*Module::CoreList::version } # shut up 'used once' warning
5b493bdf
JC
380 my $mods = $Module::CoreList::version{'5.009002'};
381 $mods = [ sort keys %$mods ];
c0939cee
JC
382 print Dumper($mods);
383
5b493bdf 384 foreach my $pkgnm (@$mods) {
c0939cee
JC
385 test_pkg($pkgnm);
386 }
387}
388
5b493bdf
JC
389END {
390 if ($opts{c}) {
82aeefe1 391 { my $x = \*Data::Dumper::Indent } # shut up 'used once' warning
d51cf0c9
JC
392 $Data::Dumper::Indent = 1;
393 print "Corrections: ", Dumper(\%report);
5b493bdf
JC
394
395 foreach my $pkg (sort keys %report) {
d51cf0c9
JC
396 for my $type (keys %matchers) {
397 print "$pkg: $type: @{$report{$pkg}{$type}}\n"
398 if @{$report{$pkg}{$type}};
399 }
5b493bdf 400 }
5b493bdf
JC
401 }
402}
403
c0939cee 404__END__