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