This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: [perl #36837] B::Deparse fails when it comes to ByteLoader programs
[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;
d51cf0c9 118use Test::More tests => ( 0 * !!$Config::Config{useithreads}
a49b57c6 119 + 3 * ($] > 5.009)
7b9ef140 120 + 14 * ($] >= 5.009003)
d51cf0c9 121 + 780 + 588 );
c0939cee
JC
122
123require_ok("B::Concise");
124
d51cf0c9
JC
125my %matchers =
126 ( constant => qr{ (?-x: is a constant sub, optimized to a \w+)
127 |(?-x: exists in stash, but has no START) }x,
128 XS => qr{ (?-x: is XS code)
129 |(?-x: exists in stash, but has no START) }x,
130 perl => qr{ (?-x: (next|db)state)
131 |(?-x: exists in stash, but has no START) }x,
132 noSTART => qr/exists in stash, but has no START/,
133);
5b493bdf 134
d51cf0c9
JC
135my $testpkgs = {
136 # packages to test, with expected types for named funcs
137
138 Digest::MD5 => { perl => [qw/ import /],
139 dflt => 'XS' },
140
141 Data::Dumper => { XS => [qw/ bootstrap Dumpxs /],
142 dflt => 'perl' },
143 B => {
144 dflt => 'constant', # all but 47/274
145 skip => [ 'regex_padav' ], # threaded only
146 perl => [qw(
147 walksymtable walkoptree_slow walkoptree_exec
148 timing_info savesym peekop parents objsym debug
149 compile_stats clearsym class
150 )],
151 XS => [qw(
152 warnhook walkoptree_debug walkoptree threadsv_names
153 svref_2object sv_yes sv_undef sv_no save_BEGINs
154 regex_padav ppname perlstring opnumber minus_c
155 main_start main_root main_cv init_av inc_gv hash
156 formfeed end_av dowarn diehook defstash curstash
157 cstring comppadlist check_av cchar cast_I32 bootstrap
158 begin_av amagic_generation address
159 )],
160 },
161
162 B::Deparse => { dflt => 'perl', # 235 functions
163
164 XS => [qw( svref_2object perlstring opnumber main_start
165 main_root main_cv )],
166
167 constant => [qw/ ASSIGN CVf_ASSERTION CVf_LOCKED CVf_LVALUE
168 CVf_METHOD LIST_CONTEXT OP_CONST OP_LIST OP_RV2SV
169 OP_STRINGIFY OPf_KIDS OPf_MOD OPf_REF OPf_SPECIAL
170 OPf_STACKED OPf_WANT OPf_WANT_LIST OPf_WANT_SCALAR
171 OPf_WANT_VOID OPpCONST_ARYBASE OPpCONST_BARE
172 OPpENTERSUB_AMPER OPpEXISTS_SUB OPpITER_REVERSED
173 OPpLVAL_INTRO OPpOUR_INTRO OPpSLICE OPpSORT_DESCEND
174 OPpSORT_INPLACE OPpSORT_INTEGER OPpSORT_NUMERIC
175 OPpSORT_REVERSE OPpTARGET_MY OPpTRANS_COMPLEMENT
176 OPpTRANS_DELETE OPpTRANS_SQUASH PMf_CONTINUE
177 PMf_EVAL PMf_EXTENDED PMf_FOLD PMf_GLOBAL PMf_KEEP
178 PMf_MULTILINE PMf_ONCE PMf_SINGLELINE PMf_SKIPWHITE
179 POSTFIX SVf_FAKE SVf_IOK SVf_NOK SVf_POK SVf_ROK
180 SVpad_OUR SVs_RMG SVs_SMG SWAP_CHILDREN
181 /],
182 },
183
184 POSIX => { dflt => 'constant', # all but 252/589
185 perl => [qw/ import croak AUTOLOAD /],
186
187 XS => [qw/ write wctomb wcstombs uname tzset tzname
188 ttyname tmpnam times tcsetpgrp tcsendbreak
189 tcgetpgrp tcflush tcflow tcdrain tanh tan
190 sysconf strxfrm strtoul strtol strtod
191 strftime strcoll sinh sigsuspend sigprocmask
192 sigpending sigaction setuid setsid setpgid
193 setlocale setgid read pipe pause pathconf
194 open nice modf mktime mkfifo mbtowc mbstowcs
195 mblen lseek log10 localeconv ldexp lchown
196 isxdigit isupper isspace ispunct isprint
197 islower isgraph isdigit iscntrl isalpha
198 isalnum int_macro_int getcwd frexp fpathconf
199 fmod floor dup2 dup difftime cuserid ctime
200 ctermid cosh constant close clock ceil
201 bootstrap atan asin asctime acos access abort
202 _exit _POSIX_SAVED_IDS _POSIX_JOB_CONTROL
203 /],
204 },
c0939cee
JC
205};
206
207############
208
209B::Concise::compile('-nobanner'); # set a silent default
5b493bdf 210getopts('vaVcr:', \my %opts) or
c0939cee
JC
211 die <<EODIE;
212
213usage: PERL_CORE=1 ./perl ext/B/t/concise-xs.t [-av] [module-list]
214 tests ability to discern XS funcs using Digest::MD5 package
215 -v : runs verbosely
216 -V : more verbosity
217 -a : runs all modules in CoreList
5b493bdf
JC
218 -c : writes test corrections as a Data::Dumper expression
219 -r <file> : reads file of tests, as written by -c
468aa647 220 <args> : additional modules are loaded and tested
d51cf0c9 221 (will report failures, since no XS funcs are known apriori)
c0939cee
JC
222
223EODIE
224 ;
225
226if (%opts) {
227 require Data::Dumper;
228 Data::Dumper->import('Dumper');
229 $Data::Dumper::Sortkeys = 1;
230}
231my @argpkgs = @ARGV;
5b493bdf
JC
232my %report;
233
234if ($opts{r}) {
235 my $refpkgs = require "$opts{r}";
236 $testpkgs->{$_} = $refpkgs->{$_} foreach keys %$refpkgs;
468aa647 237}
5b493bdf
JC
238
239unless ($opts{a}) {
240 unless (@argpkgs) {
241 foreach $pkg (sort keys %$testpkgs) {
242 test_pkg($pkg, $testpkgs->{$pkg});
243 }
244 } else {
245 foreach $pkg (@argpkgs) {
246 test_pkg($pkg, $testpkgs->{$pkg});
247 }
248 }
249} else {
250 corecheck();
c0939cee 251}
c0939cee
JC
252############
253
254sub test_pkg {
d51cf0c9
JC
255 my ($pkg, $fntypes) = @_;
256 require_ok($pkg);
c0939cee 257
d51cf0c9 258 # build %stash: keys are func-names, vals filled in below
c0939cee 259 my (%stash) = map
d51cf0c9
JC
260 ( ($_ => 0)
261 => ( grep exists &{"$pkg\::$_"} # grab CODE symbols
c0939cee 262 => grep !/__ANON__/ # but not anon subs
d51cf0c9 263 => keys %{$pkg.'::'} # from symbol table
c0939cee 264 ));
468aa647 265
d51cf0c9
JC
266 for my $type (keys %matchers) {
267 foreach my $fn (@{$fntypes->{$type}}) {
268 carp "$fn can only be one of $type, $stash{$fn}\n"
269 if $stash{$fn};
270 $stash{$fn} = $type;
271 }
272 }
273 # set default type for un-named functions
274 my $dflt = $fntypes->{dflt} || 'perl';
275 for my $k (keys %stash) {
276 $stash{$k} = $dflt unless $stash{$k};
277 }
278 $stash{$_} = 'skip' foreach @{$fntypes->{skip}};
c0939cee 279
5b493bdf 280 if ($opts{v}) {
d51cf0c9
JC
281 diag("fntypes: " => Dumper($fntypes));
282 diag("$pkg stash: " => Dumper(\%stash));
c0939cee 283 }
d51cf0c9
JC
284 foreach my $fn (reverse sort keys %stash) {
285 next if $stash{$fn} eq 'skip';
286 my $res = checkXS("${pkg}::$fn", $stash{$fn});
287 if ($res ne '1') {
288 push @{$report{$pkg}{$res}}, $fn;
5b493bdf 289 }
c0939cee
JC
290 }
291}
292
293sub checkXS {
d51cf0c9
JC
294 my ($func_name, $want) = @_;
295
296 croak "unknown type $want: $func_name\n"
297 unless defined $matchers{$want};
c0939cee
JC
298
299 my ($buf, $err) = render($func_name);
d51cf0c9
JC
300 my $res = like($buf, $matchers{$want}, "$want sub:\t $func_name");
301
302 unless ($res) {
303 # test failed. return type that would give success
304 for my $m (keys %matchers) {
305 return $m if $buf =~ $matchers{$m};
306 }
c0939cee 307 }
d51cf0c9 308 $res;
c0939cee
JC
309}
310
311sub render {
312 my ($func_name) = @_;
313
314 B::Concise::reset_sequence();
315 B::Concise::walk_output(\my $buf);
316
317 my $walker = B::Concise::compile($func_name);
318 eval { $walker->() };
319 diag("err: $@ $buf") if $@;
320 diag("verbose: $buf") if $opts{V};
321
322 return ($buf, $@);
323}
324
325sub corecheck {
326 eval { require Module::CoreList };
327 if ($@) {
328 warn "Module::CoreList not available on $]\n";
329 return;
330 }
5b493bdf
JC
331 my $mods = $Module::CoreList::version{'5.009002'};
332 $mods = [ sort keys %$mods ];
c0939cee
JC
333 print Dumper($mods);
334
5b493bdf 335 foreach my $pkgnm (@$mods) {
c0939cee
JC
336 test_pkg($pkgnm);
337 }
338}
339
5b493bdf
JC
340END {
341 if ($opts{c}) {
d51cf0c9
JC
342 $Data::Dumper::Indent = 1;
343 print "Corrections: ", Dumper(\%report);
5b493bdf
JC
344
345 foreach my $pkg (sort keys %report) {
d51cf0c9
JC
346 for my $type (keys %matchers) {
347 print "$pkg: $type: @{$report{$pkg}{$type}}\n"
348 if @{$report{$pkg}{$type}};
349 }
5b493bdf 350 }
5b493bdf
JC
351 }
352}
353
c0939cee 354__END__