Optimise if (%foo) to be faster than if(keys %foo)
[p5sagit/p5-mst-13.2.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     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                       dflt => 'perl' },
132     B => { 
133         dflt => 'constant',             # all but 47/297
134         skip => [ 'regex_padav' ],      # threaded only
135         perl => [qw(
136                     walksymtable walkoptree_slow walkoptree_exec
137                     timing_info savesym peekop parents objsym debug
138                     compile_stats clearsym class
139                     )],
140         XS => [qw(
141                   warnhook walkoptree_debug walkoptree threadsv_names
142                   svref_2object sv_yes sv_undef sv_no save_BEGINs
143                   regex_padav ppname perlstring opnumber minus_c
144                   main_start main_root main_cv init_av inc_gv hash
145                   formfeed end_av dowarn diehook defstash curstash
146                   cstring comppadlist check_av cchar cast_I32 bootstrap
147                   begin_av amagic_generation sub_generation address
148                   ), $] > 5.009 ? ('unitcheck_av') : ()],
149     },
150
151     B::Deparse => { dflt => 'perl',     # 236 functions
152
153         XS => [qw( svref_2object perlstring opnumber main_start
154                    main_root main_cv )],
155
156         constant => [qw/ ASSIGN CVf_LVALUE
157                      CVf_METHOD LIST_CONTEXT OP_CONST OP_LIST OP_RV2SV
158                      OP_STRINGIFY OPf_KIDS OPf_MOD OPf_REF OPf_SPECIAL
159                      OPf_STACKED OPf_WANT OPf_WANT_LIST OPf_WANT_SCALAR
160                      OPf_WANT_VOID OPpCONST_ARYBASE OPpCONST_BARE
161                      OPpENTERSUB_AMPER OPpEXISTS_SUB OPpITER_REVERSED
162                      OPpLVAL_INTRO OPpOUR_INTRO OPpSLICE OPpSORT_DESCEND
163                      OPpSORT_INPLACE OPpSORT_INTEGER OPpSORT_NUMERIC
164                      OPpSORT_REVERSE OPpTARGET_MY OPpTRANS_COMPLEMENT
165                      OPpTRANS_DELETE OPpTRANS_SQUASH PMf_CONTINUE
166                      PMf_EVAL PMf_EXTENDED PMf_FOLD PMf_GLOBAL PMf_KEEP
167                      PMf_MULTILINE PMf_ONCE PMf_SINGLELINE
168                      POSTFIX SVf_FAKE SVf_IOK SVf_NOK SVf_POK SVf_ROK
169                      SVpad_OUR SVs_RMG SVs_SMG SWAP_CHILDREN OPpPAD_STATE
170                      /, $] > 5.009 ? ('RXf_SKIPWHITE') : ('PMf_SKIPWHITE'),
171                     'CVf_LOCKED', # This ends up as a constant, pre or post 5.10
172                     ],
173                  },
174
175     POSIX => { dflt => 'constant',                      # all but 252/589
176                skip => [qw/ _POSIX_JOB_CONTROL /,       # platform varying
177                         # Might be XS or imported from Fcntl, depending on your
178                         # perl version:
179                         qw / S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISREG /,
180                         # Might be XS or AUTOLOADed, depending on your perl
181                         # version:
182                         qw /WEXITSTATUS WIFEXITED WIFSIGNALED WIFSTOPPED
183                             WSTOPSIG WTERMSIG/,
184                        'int_macro_int', # Removed in POSIX 1.16
185                        ],
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 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/190
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                              /, $] > 5.009 ? ('blocking') : () ],
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                            inet_ntop inet_pton
222                            /],
223                 },
224 };
225
226 ############
227
228 B::Concise::compile('-nobanner');       # set a silent default
229 getopts('vaVcr:', \my %opts) or
230     die <<EODIE;
231
232 usage: PERL_CORE=1 ./perl ext/B/t/concise-xs.t [-av] [module-list]
233     tests ability to discern XS funcs using Digest::MD5 package
234     -v  : runs verbosely
235     -V  : more verbosity
236     -a  : runs all modules in CoreList
237     -c  : writes test corrections as a Data::Dumper expression
238     -r <file>   : reads file of tests, as written by -c
239     <args>      : additional modules are loaded and tested
240         (will report failures, since no XS funcs are known apriori)
241
242 EODIE
243     ;
244
245 if (%opts) {
246     require Data::Dumper;
247     Data::Dumper->import('Dumper');
248     $Data::Dumper::Sortkeys = 1;
249 }
250 my @argpkgs = @ARGV;
251 my %report;
252
253 if ($opts{r}) {
254     my $refpkgs = require "$opts{r}";
255     $testpkgs->{$_} = $refpkgs->{$_} foreach keys %$refpkgs;
256 }
257
258 unless ($opts{a}) {
259     unless (@argpkgs) {
260         foreach $pkg (sort keys %$testpkgs) {
261             test_pkg($pkg, $testpkgs->{$pkg});
262         }
263     } else {
264         foreach $pkg (@argpkgs) {
265             test_pkg($pkg, $testpkgs->{$pkg});
266         }
267     }
268 } else {
269     corecheck();
270 }
271 ############
272
273 sub test_pkg {
274     my ($pkg, $fntypes) = @_;
275     require_ok($pkg);
276
277     # build %stash: keys are func-names, vals filled in below
278     my (%stash) = map
279         ( ($_ => 0)
280           => ( grep exists &{"$pkg\::$_"}       # grab CODE symbols
281                => grep !/__ANON__/              # but not anon subs
282                => keys %{$pkg.'::'}             # from symbol table
283                ));
284
285     for my $type (keys %matchers) {
286         foreach my $fn (@{$fntypes->{$type}}) {
287             carp "$fn can only be one of $type, $stash{$fn}\n"
288                 if $stash{$fn};
289             $stash{$fn} = $type;
290         }
291     }
292     # set default type for un-named functions
293     my $dflt = $fntypes->{dflt} || 'perl';
294     for my $k (keys %stash) {
295         $stash{$k} = $dflt unless $stash{$k};
296     }
297     $stash{$_} = 'skip' foreach @{$fntypes->{skip}};
298
299     if ($opts{v}) {
300         diag("fntypes: " => Dumper($fntypes));
301         diag("$pkg stash: " => Dumper(\%stash));
302     }
303     foreach my $fn (reverse sort keys %stash) {
304         next if $stash{$fn} eq 'skip';
305         my $res = checkXS("${pkg}::$fn", $stash{$fn});
306         if ($res ne '1') {
307             push @{$report{$pkg}{$res}}, $fn;
308         }
309     }
310 }
311
312 sub checkXS {
313     my ($func_name, $want) = @_;
314
315     croak "unknown type $want: $func_name\n"
316         unless defined $matchers{$want};
317
318     my ($buf, $err) = render($func_name);
319     my $res = like($buf, $matchers{$want}, "$want sub:\t $func_name");
320
321     unless ($res) {
322         # test failed. return type that would give success
323         for my $m (keys %matchers) {
324             return $m if $buf =~ $matchers{$m};
325         }
326     }
327     $res;
328 }
329
330 sub render {
331     my ($func_name) = @_;
332
333     B::Concise::reset_sequence();
334     B::Concise::walk_output(\my $buf);
335
336     my $walker = B::Concise::compile($func_name);
337     eval { $walker->() };
338     diag("err: $@ $buf") if $@;
339     diag("verbose: $buf") if $opts{V};
340
341     return ($buf, $@);
342 }
343
344 sub corecheck {
345     eval { require Module::CoreList };
346     if ($@) {
347         warn "Module::CoreList not available on $]\n";
348         return;
349     }
350     my $mods = $Module::CoreList::version{'5.009002'};
351     $mods = [ sort keys %$mods ];
352     print Dumper($mods);
353
354     foreach my $pkgnm (@$mods) {
355         test_pkg($pkgnm);
356     }
357 }
358
359 END {
360     if ($opts{c}) {
361         $Data::Dumper::Indent = 1;
362         print "Corrections: ", Dumper(\%report);
363
364         foreach my $pkg (sort keys %report) {
365             for my $type (keys %matchers) {
366                 print "$pkg: $type: @{$report{$pkg}{$type}}\n"
367                     if @{$report{$pkg}{$type}};
368             }
369         }
370     }
371 }
372
373 __END__