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
1 #!./perl
2
3 # 2 purpose file: 1-test 2-demonstrate (via args, -v -a options)
4
5 =head1 SYNOPSIS
6
7 To verify that B::Concise properly reports whether functions are XS,
8 perl, or optimized constant subs, we test against a few core packages
9 which have a stable API, and which have functions of all 3 types.
10
11 =head1 WHAT IS TESTED
12
13 5 core packages are tested; Digest::MD5, B, B::Deparse, Data::Dumper,
14 and POSIX.  These have a mix of the 3 expected implementation types;
15 perl, XS, and constant (optimized constant subs).
16
17 %$testpkgs specifies what packages are tested; each package is loaded,
18 and the stash is scanned for the function-names in that package.
19
20 Each value in %$testpkgs is a hash-of-lists (HoL) whose keys are
21 implementation-types and values are lists of function-names of that type.
22
23 To keep these HoLs smaller and more manageable, they may carry an
24 additional 'dflt' => $impl_Type, which means that unnamed functions
25 are expected to be of that default implementation type.  Those unnamed
26 functions are known from the scan of the package stash.
27
28 =head1 HOW THEY'RE TESTED
29
30 Each function is 'rendered' by B::Concise, and result is matched
31 against regexs for each possible implementation-type.  For some
32 packages, some functions may be unimplemented on some platforms.
33
34 To slay this maintenance dragon, the regexs used in like() match
35 against renderings which indicate that there is no implementation.
36
37 If a function is implemented differently on different platforms, the
38 test for that function will fail on one of those platforms.  These
39 specific functions can be skipped by a 'skip' => [ @list ] to the HoL
40 mentioned previously.  See usage for skip in B's HoL, which avoids
41 testing a function which doesn't exist on non-threaded builds.
42
43 =head1 OPTIONS AND ARGUMENTS
44
45 C<-v> and C<-V> trigger 2 levels of verbosity.
46
47 C<-a> uses Module::CoreList to run all core packages through the test, which
48 gives some interesting results.
49
50 C<-c> causes the expected XS/non-XS results to be marked with
51 corrections, which are then reported at program END, in a form that's
52 readily cut-and-pastable into this file.
53
54
55 C<< -r <file> >> reads a file, as written by C<-c>, and adjusts the expected
56 results accordingly.  The file is 'required', so @INC settings apply.
57
58 If module-names are given as args, those packages are run through the
59 test harness; this is handy for collecting further items to test, and
60 may be useful otherwise (ie just to see).
61
62 =head1 EXAMPLES
63
64 =over 4
65
66 =item ./perl -Ilib -wS ext/B/t/concise-xs.t -c Storable
67
68 Tests Storable.pm for XS/non-XS routines, writes findings (along with
69 test results) to stdout.  You could edit results to produce a test
70 file, as in next example
71
72 =item ./perl -Ilib -wS ext/B/t/concise-xs.t -r ./storable
73
74 Loads 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
78 Gets module list from Module::Corelist, and runs them all through the
79 test.  Since -c is used, this generates corrections, which are saved
80 in 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
84 This runs the tests specified in the file created in previous example.
85 -c is used again, and stdout verifies that all the expected results
86 given by -r ../all-xs are now seen.
87
88 Looking 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
94
95 =cut
96
97 BEGIN {
98     unshift @INC, 't';
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     }
104     unless ($Config::Config{useperlio}) {
105         print "1..0 # Skip -- Perl configured without perlio\n";
106         exit 0;
107     }
108 }
109
110 use Getopt::Std;
111 use Carp;
112 use Test::More 'no_plan';
113
114 require_ok("B::Concise");
115
116 my %matchers = 
117     ( constant  => qr{ (?-x: is a constant sub, optimized to a \w+)
118                       |(?-x: exists in stash, but has no START) }x,
119       XS        => qr/ is XS code/,
120       perl      => qr/ (next|db)state/,
121       noSTART   => qr/ exists in stash, but has no START/,
122 );
123
124 my $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                         $] >= 5.015 ? qw/_vstring / : () ],
132                     $] >= 5.015
133                         ?  (constant => ['_bad_vsmg']) : (),
134                       dflt => 'perl' },
135     B => { 
136         dflt => 'constant',             # all but 47/297
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
150                   begin_av amagic_generation sub_generation address
151                   unitcheck_av) ],
152     },
153
154     B::Deparse => { dflt => 'perl',     # 236 functions
155
156         XS => [qw( svref_2object perlstring opnumber main_start
157                    main_root main_cv )],
158
159         constant => [qw/ ASSIGN CVf_LVALUE
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
163                      OPf_WANT_VOID OPpCONST_BARE OPpCONST_NOVER
164                      OPpENTERSUB_AMPER OPpEXISTS_SUB OPpITER_REVERSED
165                      OPpLVAL_INTRO OPpOUR_INTRO OPpSLICE OPpSORT_DESCEND
166                      OPpSORT_INPLACE OPpSORT_INTEGER OPpSORT_NUMERIC
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
170                      PMf_KEEP PMf_NONDESTRUCT
171                      PMf_MULTILINE PMf_ONCE PMf_SINGLELINE
172                      POSTFIX SVf_FAKE SVf_IOK SVf_NOK SVf_POK SVf_ROK
173                      SVpad_OUR SVs_RMG SVs_SMG SWAP_CHILDREN OPpPAD_STATE
174                      OPpCONST_ARYBASE RXf_SKIPWHITE SVpad_TYPED/,
175                      $] >= 5.015 ? qw(
176                      OP_GLOB PMf_SKIPWHITE RXf_PMf_CHARSET RXf_PMf_KEEPCOPY
177                      OPpEVAL_BYTES OPpSUBSTR_REPL_FIRST) : (),
178                      $] >= 5.019 ? qw(OP_PUSHMARK OP_NULL) : (),
179                     'CVf_LOCKED', # This ends up as a constant, pre or post 5.10
180                     ],
181                  },
182
183     POSIX => { dflt => 'constant',                      # all but 252/589
184                skip => [qw/ _POSIX_JOB_CONTROL /,       # platform varying
185                         # Might be XS or imported from Fcntl, depending on your
186                         # perl version:
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
193
194                        'strtold', # platform varying (C99)
195
196                         qw/fegetround fesetround/,
197
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
204                         log2 logb lrint lround nan nearbyint nextafter
205                         nexttoward remainder remquo rint round scalbn
206                         signbit sinh tanh tgamma trunc y0 y1 yn/,
207
208                        ],
209                perl => [qw/ import croak AUTOLOAD /,
210                         $] >= 5.015
211                             ? qw/load_imports usage printf sprintf perror/
212                             : (),
213                         ],
214
215                XS => [qw/ write wctomb wcstombs uname tzset tzname
216                       ttyname tmpnam times tcsetpgrp tcsendbreak
217                       tcgetpgrp tcflush tcflow tcdrain tanh tan
218                       sysconf strxfrm strtoul strtol strtod
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
226                       isalnum getcwd frexp fpathconf
227                       fmod floor dup2 dup difftime cuserid ctime
228                       ctermid cosh constant close clock ceil
229                       bootstrap atan asin asctime acos access abort
230                       _exit
231                       /, $] >= 5.015 ? ('sleep') : () ],
232                },
233
234     IO::Socket => { dflt => 'constant',         # 157/190
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
242                              carp bind atmark accept sockaddr_in6
243                              blocking/ ],
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
248                            unpack_sockaddr_in6 pack_sockaddr_in6
249                            /],
250             # skip inet_ntop and inet_pton as they're not exported by default
251                 },
252 };
253
254 ############
255
256 B::Concise::compile('-nobanner');       # set a silent default
257 getopts('vaVcr:', \my %opts) or
258     die <<EODIE;
259
260 usage: 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
265     -c  : writes test corrections as a Data::Dumper expression
266     -r <file>   : reads file of tests, as written by -c
267     <args>      : additional modules are loaded and tested
268         (will report failures, since no XS funcs are known apriori)
269
270 EODIE
271     ;
272
273 if (%opts) {
274     require Data::Dumper;
275     Data::Dumper->import('Dumper');
276     { my $x = \*Data::Dumper::Sortkeys } # shut up 'used once' warning
277     $Data::Dumper::Sortkeys = 1;
278 }
279 my @argpkgs = @ARGV;
280 my %report;
281
282 if ($opts{r}) {
283     my $refpkgs = require "$opts{r}";
284     $testpkgs->{$_} = $refpkgs->{$_} foreach keys %$refpkgs;
285 }
286
287 unless ($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();
299 }
300 ############
301
302 sub test_pkg {
303     my ($pkg, $fntypes) = @_;
304     require_ok($pkg);
305
306     # build %stash: keys are func-names, vals filled in below
307     my (%stash) = map
308         ( ($_ => 0)
309           => ( grep exists &{"$pkg\::$_"}       # grab CODE symbols
310                => grep !/__ANON__/              # but not anon subs
311                => keys %{$pkg.'::'}             # from symbol table
312                ));
313
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}};
327
328     if ($opts{v}) {
329         diag("fntypes: " => Dumper($fntypes));
330         diag("$pkg stash: " => Dumper(\%stash));
331     }
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;
337         }
338     }
339 }
340
341 sub checkXS {
342     my ($func_name, $want) = @_;
343
344     croak "unknown type $want: $func_name\n"
345         unless defined $matchers{$want};
346
347     my ($buf, $err) = render($func_name);
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         }
355     }
356     $res;
357 }
358
359 sub 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
373 sub corecheck {
374     eval { require Module::CoreList };
375     if ($@) {
376         warn "Module::CoreList not available on $]\n";
377         return;
378     }
379     { my $x = \*Module::CoreList::version } # shut up 'used once' warning
380     my $mods = $Module::CoreList::version{'5.009002'};
381     $mods = [ sort keys %$mods ];
382     print Dumper($mods);
383
384     foreach my $pkgnm (@$mods) {
385         test_pkg($pkgnm);
386     }
387 }
388
389 END {
390     if ($opts{c}) {
391         { my $x = \*Data::Dumper::Indent } # shut up 'used once' warning
392         $Data::Dumper::Indent = 1;
393         print "Corrections: ", Dumper(\%report);
394
395         foreach my $pkg (sort keys %report) {
396             for my $type (keys %matchers) {
397                 print "$pkg: $type: @{$report{$pkg}{$type}}\n"
398                     if @{$report{$pkg}{$type}};
399             }
400         }
401     }
402 }
403
404 __END__