This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
update B::Concise test for B::Deparse change
[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
130 Data::Dumper => { XS => [qw/ bootstrap Dumpxs /],
131 dflt => 'perl' },
132 B => {
c737faaf 133 dflt => 'constant', # all but 47/297
d51cf0c9
JC
134 skip => [ 'regex_padav' ], # threaded only
135 perl => [qw(
136 walksymtable walkoptree_slow walkoptree_exec
137 timing_info savesym peekop parents objsym debug
138 compile_stats clearsym class
139 )],
140 XS => [qw(
141 warnhook walkoptree_debug walkoptree threadsv_names
142 svref_2object sv_yes sv_undef sv_no save_BEGINs
143 regex_padav ppname perlstring opnumber minus_c
144 main_start main_root main_cv init_av inc_gv hash
145 formfeed end_av dowarn diehook defstash curstash
146 cstring comppadlist check_av cchar cast_I32 bootstrap
5ce57cc0 147 begin_av amagic_generation sub_generation address
e412117e 148 ), $] > 5.009 ? ('unitcheck_av') : ()],
d51cf0c9
JC
149 },
150
867fa1e2 151 B::Deparse => { dflt => 'perl', # 236 functions
d51cf0c9
JC
152
153 XS => [qw( svref_2object perlstring opnumber main_start
154 main_root main_cv )],
155
e95ab0c0 156 constant => [qw/ ASSIGN CVf_LVALUE
d51cf0c9 157 CVf_METHOD LIST_CONTEXT OP_CONST OP_LIST OP_RV2SV
f4002a4b 158 OP_GLOB
d51cf0c9
JC
159 OP_STRINGIFY OPf_KIDS OPf_MOD OPf_REF OPf_SPECIAL
160 OPf_STACKED OPf_WANT OPf_WANT_LIST OPf_WANT_SCALAR
e1dccc0d 161 OPf_WANT_VOID OPpCONST_BARE OPpCONST_NOVER
d51cf0c9
JC
162 OPpENTERSUB_AMPER OPpEXISTS_SUB OPpITER_REVERSED
163 OPpLVAL_INTRO OPpOUR_INTRO OPpSLICE OPpSORT_DESCEND
164 OPpSORT_INPLACE OPpSORT_INTEGER OPpSORT_NUMERIC
689e417f
VP
165 OPpSORT_REVERSE OPpREVERSE_INPLACE OPpTARGET_MY
166 OPpTRANS_COMPLEMENT OPpTRANS_DELETE OPpTRANS_SQUASH
167 PMf_CONTINUE PMf_EVAL PMf_EXTENDED PMf_FOLD PMf_GLOBAL
4f4d7508
DC
168 PMf_KEEP PMf_NONDESTRUCT
169 PMf_MULTILINE PMf_ONCE PMf_SINGLELINE
d51cf0c9 170 POSTFIX SVf_FAKE SVf_IOK SVf_NOK SVf_POK SVf_ROK
d449ddce 171 SVpad_OUR SVs_RMG SVs_SMG SWAP_CHILDREN OPpPAD_STATE
ed40ada7 172 OPpCONST_ARYBASE
aa381260
NC
173 /, $] > 5.009 ? ('RXf_SKIPWHITE') : ('PMf_SKIPWHITE'),
174 'CVf_LOCKED', # This ends up as a constant, pre or post 5.10
175 ],
d51cf0c9
JC
176 },
177
f9f861ec 178 POSIX => { dflt => 'constant', # all but 252/589
9b68a132 179 skip => [qw/ _POSIX_JOB_CONTROL /, # platform varying
61699fd9 180 # Might be XS or imported from Fcntl, depending on your
9b68a132 181 # perl version:
e99d581a
NC
182 qw / S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISREG /,
183 # Might be XS or AUTOLOADed, depending on your perl
184 # version:
185 qw /WEXITSTATUS WIFEXITED WIFSIGNALED WIFSTOPPED
186 WSTOPSIG WTERMSIG/,
187 'int_macro_int', # Removed in POSIX 1.16
188 ],
122efcc9
AP
189 perl => [qw/ import load_imports croak usage printf sprintf
190 perror AUTOLOAD /],
d51cf0c9
JC
191
192 XS => [qw/ write wctomb wcstombs uname tzset tzname
193 ttyname tmpnam times tcsetpgrp tcsendbreak
194 tcgetpgrp tcflush tcflow tcdrain tanh tan
195 sysconf strxfrm strtoul strtol strtod
196 strftime strcoll sinh sigsuspend sigprocmask
197 sigpending sigaction setuid setsid setpgid
198 setlocale setgid read pipe pause pathconf
199 open nice modf mktime mkfifo mbtowc mbstowcs
200 mblen lseek log10 localeconv ldexp lchown
201 isxdigit isupper isspace ispunct isprint
202 islower isgraph isdigit iscntrl isalpha
e99d581a 203 isalnum getcwd frexp fpathconf
d51cf0c9
JC
204 fmod floor dup2 dup difftime cuserid ctime
205 ctermid cosh constant close clock ceil
206 bootstrap atan asin asctime acos access abort
2018a5c3 207 _exit
d51cf0c9
JC
208 /],
209 },
2018a5c3 210
f84b4b22 211 IO::Socket => { dflt => 'constant', # 157/190
2018a5c3
JC
212
213 perl => [qw/ timeout socktype sockopt sockname
214 socketpair socket sockdomain sockaddr_un
215 sockaddr_in shutdown setsockopt send
216 register_domain recv protocol peername
217 new listen import getsockopt croak
218 connected connect configure confess close
0c7e1d80 219 carp bind atmark accept sockaddr_in6
e412117e 220 /, $] > 5.009 ? ('blocking') : () ],
2018a5c3
JC
221
222 XS => [qw/ unpack_sockaddr_un unpack_sockaddr_in
223 sockatmark sockaddr_family pack_sockaddr_un
224 pack_sockaddr_in inet_ntoa inet_aton
0c7e1d80 225 unpack_sockaddr_in6 pack_sockaddr_in6
2018a5c3 226 /],
d6896be3 227 # skip inet_ntop and inet_pton as they're not exported by default
2018a5c3 228 },
c0939cee
JC
229};
230
231############
232
233B::Concise::compile('-nobanner'); # set a silent default
5b493bdf 234getopts('vaVcr:', \my %opts) or
c0939cee
JC
235 die <<EODIE;
236
237usage: PERL_CORE=1 ./perl ext/B/t/concise-xs.t [-av] [module-list]
238 tests ability to discern XS funcs using Digest::MD5 package
239 -v : runs verbosely
240 -V : more verbosity
241 -a : runs all modules in CoreList
5b493bdf
JC
242 -c : writes test corrections as a Data::Dumper expression
243 -r <file> : reads file of tests, as written by -c
468aa647 244 <args> : additional modules are loaded and tested
d51cf0c9 245 (will report failures, since no XS funcs are known apriori)
c0939cee
JC
246
247EODIE
248 ;
249
250if (%opts) {
251 require Data::Dumper;
252 Data::Dumper->import('Dumper');
253 $Data::Dumper::Sortkeys = 1;
254}
255my @argpkgs = @ARGV;
5b493bdf
JC
256my %report;
257
258if ($opts{r}) {
259 my $refpkgs = require "$opts{r}";
260 $testpkgs->{$_} = $refpkgs->{$_} foreach keys %$refpkgs;
468aa647 261}
5b493bdf
JC
262
263unless ($opts{a}) {
264 unless (@argpkgs) {
265 foreach $pkg (sort keys %$testpkgs) {
266 test_pkg($pkg, $testpkgs->{$pkg});
267 }
268 } else {
269 foreach $pkg (@argpkgs) {
270 test_pkg($pkg, $testpkgs->{$pkg});
271 }
272 }
273} else {
274 corecheck();
c0939cee 275}
c0939cee
JC
276############
277
278sub test_pkg {
d51cf0c9
JC
279 my ($pkg, $fntypes) = @_;
280 require_ok($pkg);
c0939cee 281
d51cf0c9 282 # build %stash: keys are func-names, vals filled in below
c0939cee 283 my (%stash) = map
d51cf0c9
JC
284 ( ($_ => 0)
285 => ( grep exists &{"$pkg\::$_"} # grab CODE symbols
c0939cee 286 => grep !/__ANON__/ # but not anon subs
d51cf0c9 287 => keys %{$pkg.'::'} # from symbol table
c0939cee 288 ));
468aa647 289
d51cf0c9
JC
290 for my $type (keys %matchers) {
291 foreach my $fn (@{$fntypes->{$type}}) {
292 carp "$fn can only be one of $type, $stash{$fn}\n"
293 if $stash{$fn};
294 $stash{$fn} = $type;
295 }
296 }
297 # set default type for un-named functions
298 my $dflt = $fntypes->{dflt} || 'perl';
299 for my $k (keys %stash) {
300 $stash{$k} = $dflt unless $stash{$k};
301 }
302 $stash{$_} = 'skip' foreach @{$fntypes->{skip}};
c0939cee 303
5b493bdf 304 if ($opts{v}) {
d51cf0c9
JC
305 diag("fntypes: " => Dumper($fntypes));
306 diag("$pkg stash: " => Dumper(\%stash));
c0939cee 307 }
d51cf0c9
JC
308 foreach my $fn (reverse sort keys %stash) {
309 next if $stash{$fn} eq 'skip';
310 my $res = checkXS("${pkg}::$fn", $stash{$fn});
311 if ($res ne '1') {
312 push @{$report{$pkg}{$res}}, $fn;
5b493bdf 313 }
c0939cee
JC
314 }
315}
316
317sub checkXS {
d51cf0c9
JC
318 my ($func_name, $want) = @_;
319
320 croak "unknown type $want: $func_name\n"
321 unless defined $matchers{$want};
c0939cee
JC
322
323 my ($buf, $err) = render($func_name);
d51cf0c9
JC
324 my $res = like($buf, $matchers{$want}, "$want sub:\t $func_name");
325
326 unless ($res) {
327 # test failed. return type that would give success
328 for my $m (keys %matchers) {
329 return $m if $buf =~ $matchers{$m};
330 }
c0939cee 331 }
d51cf0c9 332 $res;
c0939cee
JC
333}
334
335sub render {
336 my ($func_name) = @_;
337
338 B::Concise::reset_sequence();
339 B::Concise::walk_output(\my $buf);
340
341 my $walker = B::Concise::compile($func_name);
342 eval { $walker->() };
343 diag("err: $@ $buf") if $@;
344 diag("verbose: $buf") if $opts{V};
345
346 return ($buf, $@);
347}
348
349sub corecheck {
350 eval { require Module::CoreList };
351 if ($@) {
352 warn "Module::CoreList not available on $]\n";
353 return;
354 }
5b493bdf
JC
355 my $mods = $Module::CoreList::version{'5.009002'};
356 $mods = [ sort keys %$mods ];
c0939cee
JC
357 print Dumper($mods);
358
5b493bdf 359 foreach my $pkgnm (@$mods) {
c0939cee
JC
360 test_pkg($pkgnm);
361 }
362}
363
5b493bdf
JC
364END {
365 if ($opts{c}) {
d51cf0c9
JC
366 $Data::Dumper::Indent = 1;
367 print "Corrections: ", Dumper(\%report);
5b493bdf
JC
368
369 foreach my $pkg (sort keys %report) {
d51cf0c9
JC
370 for my $type (keys %matchers) {
371 print "$pkg: $type: @{$report{$pkg}{$type}}\n"
372 if @{$report{$pkg}{$type}};
373 }
5b493bdf 374 }
5b493bdf
JC
375 }
376}
377
c0939cee 378__END__