This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
c131436df4a47a3cb411ed3a533b1a1a485ed5b3
[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 managable, 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 doesnt 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     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     }
110     unless ($Config::Config{useperlio}) {
111         print "1..0 # Skip -- Perl configured without perlio\n";
112         exit 0;
113     }
114 }
115
116 use Getopt::Std;
117 use Carp;
118 use Test::More tests => ( 0 * !!$Config::Config{useithreads}
119                           + 3 * ($] > 5.009)
120                           + 14 * ($] >= 5.009003)
121                           + 780 + 588 );
122
123 require_ok("B::Concise");
124
125 my %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 );
134
135 my $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                },
205 };
206
207 ############
208
209 B::Concise::compile('-nobanner');       # set a silent default
210 getopts('vaVcr:', \my %opts) or
211     die <<EODIE;
212
213 usage: 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
218     -c  : writes test corrections as a Data::Dumper expression
219     -r <file>   : reads file of tests, as written by -c
220     <args>      : additional modules are loaded and tested
221         (will report failures, since no XS funcs are known apriori)
222
223 EODIE
224     ;
225
226 if (%opts) {
227     require Data::Dumper;
228     Data::Dumper->import('Dumper');
229     $Data::Dumper::Sortkeys = 1;
230 }
231 my @argpkgs = @ARGV;
232 my %report;
233
234 if ($opts{r}) {
235     my $refpkgs = require "$opts{r}";
236     $testpkgs->{$_} = $refpkgs->{$_} foreach keys %$refpkgs;
237 }
238
239 unless ($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();
251 }
252 ############
253
254 sub test_pkg {
255     my ($pkg, $fntypes) = @_;
256     require_ok($pkg);
257
258     # build %stash: keys are func-names, vals filled in below
259     my (%stash) = map
260         ( ($_ => 0)
261           => ( grep exists &{"$pkg\::$_"}       # grab CODE symbols
262                => grep !/__ANON__/              # but not anon subs
263                => keys %{$pkg.'::'}             # from symbol table
264                ));
265
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}};
279
280     if ($opts{v}) {
281         diag("fntypes: " => Dumper($fntypes));
282         diag("$pkg stash: " => Dumper(\%stash));
283     }
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;
289         }
290     }
291 }
292
293 sub checkXS {
294     my ($func_name, $want) = @_;
295
296     croak "unknown type $want: $func_name\n"
297         unless defined $matchers{$want};
298
299     my ($buf, $err) = render($func_name);
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         }
307     }
308     $res;
309 }
310
311 sub 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
325 sub corecheck {
326     eval { require Module::CoreList };
327     if ($@) {
328         warn "Module::CoreList not available on $]\n";
329         return;
330     }
331     my $mods = $Module::CoreList::version{'5.009002'};
332     $mods = [ sort keys %$mods ];
333     print Dumper($mods);
334
335     foreach my $pkgnm (@$mods) {
336         test_pkg($pkgnm);
337     }
338 }
339
340 END {
341     if ($opts{c}) {
342         $Data::Dumper::Indent = 1;
343         print "Corrections: ", Dumper(\%report);
344
345         foreach my $pkg (sort keys %report) {
346             for my $type (keys %matchers) {
347                 print "$pkg: $type: @{$report{$pkg}{$type}}\n"
348                     if @{$report{$pkg}{$type}};
349             }
350         }
351     }
352 }
353
354 __END__