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