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