This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Correct the version-dependant expression for the number of tests, as it
[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 or
8 perl, we test against 2 (currently) core packages which have lots of
9 XS functions: B and Digest::MD5.  They're listed in %$testpkgs, along
10 with a list of functions that are (or are not) XS.  For brevity, you
11 can specify the shorter list; if they're non-xs routines, start list
12 with a '!'.  Data::Dumper is also tested, partly to prove the non-!
13 usage.
14
15 We demand-load each package, scan its stash for function names, and
16 mark them as XS/not-XS according to the list given for each package.
17 Then we test B::Concise's report on each.
18
19 =head1 OPTIONS AND ARGUMENTS
20
21 C<-v> and C<-V> trigger 2 levels of verbosity.
22
23 C<-a> uses Module::CoreList to run all core packages through the test, which
24 gives some interesting results.
25
26 C<-c> causes the expected XS/non-XS results to be marked with
27 corrections, which are then reported at program END, in a
28 Data::Dumper statement
29
30 C<< -r <file> >> reads a file, as written by C<-c>, and adjusts the expected
31 results accordingly.  The file is 'required', so @INC settings apply.
32
33 If module-names are given as args, those packages are run through the
34 test harness; this is handy for collecting further items to test, and
35 may be useful otherwise (ie just to see).
36
37 =head1 EXAMPLES
38
39 All following examples avoid using PERL_CORE=1, since that changes @INC
40
41 =over 4
42
43 =item ./perl -Ilib -wS ext/B/t/concise-xs.t -c Storable
44
45 Tests Storable.pm for XS/non-XS routines, writes findings (along with
46 test results) to stdout.  You could edit results to produce a test
47 file, as in next example
48
49 =item ./perl -Ilib -wS ext/B/t/concise-xs.t -r ./storable
50
51 Loads file, and uses it to set expectations, and run tests
52
53 =item ./perl -Ilib -wS ext/B/t/concise-xs.t -avc > ../foo-avc 2> ../foo-avc2
54
55 Gets module list from Module::Corelist, and runs them all through the
56 test.  Since -c is used, this generates corrections, which are saved
57 in a file, which is edited down to produce ../all-xs
58
59 =item ./perl -Ilib -wS ext/B/t/concise-xs.t -cr ../all-xs > ../foo 2> ../foo2
60
61 This runs the tests specified in the file created in previous example.
62 -c is used again, and stdout verifies that all the expected results
63 given by -r ../all-xs are now seen.
64
65 Looking at ../foo2, you'll see 34 occurrences of the following error:
66
67 # err: Can't use an undefined value as a SCALAR reference at
68 # lib/B/Concise.pm line 634, <DATA> line 1.
69
70 =back
71
72 =cut
73
74 BEGIN {
75     if ($ENV{PERL_CORE}) {
76         chdir('t') if -d 't';
77         @INC = ('.', '../lib');
78     } else {
79         unshift @INC, 't';
80         push @INC, "../../t";
81     }
82     require Config;
83     if (($Config::Config{'extensions'} !~ /\bB\b/) ){
84         print "1..0 # Skip -- Perl configured without B module\n";
85         exit 0;
86     }
87 }
88
89 use Getopt::Std;
90 use Carp;
91 use Test::More tests => ( 1 * !!$Config::Config{useithreads}
92                           + 1 * ($] > 5.009)
93                           + 779 );
94
95 require_ok("B::Concise");
96
97 my $testpkgs = {
98
99     Digest::MD5 => [qw/ ! import /],
100
101     B => [qw/ ! class clearsym compile_stats debug objsym parents
102               peekop savesym timing_info walkoptree_exec
103               walkoptree_slow walksymtable /],
104
105     Data::Dumper => [qw/ bootstrap Dumpxs /],
106
107     B::Deparse => [qw/ ASSIGN CVf_ASSERTION CVf_LOCKED CVf_LVALUE
108                    CVf_METHOD LIST_CONTEXT OP_CONST OP_LIST OP_RV2SV
109                    OP_STRINGIFY OPf_KIDS OPf_MOD OPf_REF OPf_SPECIAL
110                    OPf_STACKED OPf_WANT OPf_WANT_LIST OPf_WANT_SCALAR
111                    OPf_WANT_VOID OPpCONST_ARYBASE OPpCONST_BARE
112                    OPpENTERSUB_AMPER OPpEXISTS_SUB OPpITER_REVERSED
113                    OPpLVAL_INTRO OPpOUR_INTRO OPpSLICE OPpSORT_DESCEND
114                    OPpSORT_INPLACE OPpSORT_INTEGER OPpSORT_NUMERIC
115                    OPpSORT_REVERSE OPpTARGET_MY OPpTRANS_COMPLEMENT
116                    OPpTRANS_DELETE OPpTRANS_SQUASH PMf_CONTINUE
117                    PMf_EVAL PMf_EXTENDED PMf_FOLD PMf_GLOBAL PMf_KEEP
118                    PMf_MULTILINE PMf_ONCE PMf_SINGLELINE PMf_SKIPWHITE
119                    POSTFIX SVf_FAKE SVf_IOK SVf_NOK SVf_POK SVf_ROK
120                    SVpad_OUR SVs_RMG SVs_SMG SWAP_CHILDREN main_cv
121                    main_root main_start opnumber perlstring
122                    svref_2object /],
123
124 };
125
126 ############
127
128 B::Concise::compile('-nobanner');       # set a silent default
129 getopts('vaVcr:', \my %opts) or
130     die <<EODIE;
131
132 usage: PERL_CORE=1 ./perl ext/B/t/concise-xs.t [-av] [module-list]
133     tests ability to discern XS funcs using Digest::MD5 package
134     -v  : runs verbosely
135     -V  : more verbosity
136     -a  : runs all modules in CoreList
137     -c  : writes test corrections as a Data::Dumper expression
138     -r <file>   : reads file of tests, as written by -c
139     <args>      : additional modules are loaded and tested
140         (will report failures, since no XS funcs are known aprior)
141
142 EODIE
143     ;
144
145 if (%opts) {
146     require Data::Dumper;
147     Data::Dumper->import('Dumper');
148     $Data::Dumper::Sortkeys = 1;
149 }
150 my @argpkgs = @ARGV;
151 my %report;
152
153 if ($opts{r}) {
154     my $refpkgs = require "$opts{r}";
155     $testpkgs->{$_} = $refpkgs->{$_} foreach keys %$refpkgs;
156 }
157
158 unless ($opts{a}) {
159     unless (@argpkgs) {
160         foreach $pkg (sort keys %$testpkgs) {
161             test_pkg($pkg, $testpkgs->{$pkg});
162         }
163     } else {
164         foreach $pkg (@argpkgs) {
165             test_pkg($pkg, $testpkgs->{$pkg});
166         }
167     }
168 } else {
169     corecheck();
170 }
171 ############
172
173 sub test_pkg {
174     my ($pkg_name, $xslist) = @_;
175     require_ok($pkg_name);
176
177     unless (ref $xslist eq 'ARRAY') {
178         warn "no XS/non-XS function list given, assuming empty XS list";
179         $xslist = [''];
180     }
181
182     my $assumeXS = 0;   # assume list enumerates XS funcs, not perl ones
183     $assumeXS = 1       if $xslist->[0] and $xslist->[0] eq '!';
184
185     # build %stash: keys are func-names, vals: 1 if XS, 0 if not
186     my (%stash) = map
187         ( ($_ => $assumeXS)
188           => ( grep exists &{"$pkg_name\::$_"}  # grab CODE symbols
189                => grep !/__ANON__/              # but not anon subs
190                => keys %{$pkg_name.'::'}        # from symbol table
191                ));
192
193     # now invert according to supplied list
194     $stash{$_} = int ! $assumeXS foreach @$xslist;
195
196     # and cleanup cruft (easier than preventing)
197     delete @stash{'!',''};
198
199     if ($opts{v}) {
200         diag("xslist: " => Dumper($xslist));
201         diag("$pkg_name stash: " => Dumper(\%stash));
202     }
203     my $err;
204     foreach $func_name (reverse sort keys %stash) {
205         my $res = checkXS("${pkg_name}::$func_name", $stash{$func_name});
206         if (!$res) {
207             $stash{$func_name} ^= 1;
208             print "$func_name ";
209             $err++;
210         }
211     }
212     $report{$pkg_name} = \%stash if $opts{c} and $err || $opts{v};
213 }
214
215 sub checkXS {
216     my ($func_name, $wantXS) = @_;
217
218     my ($buf, $err) = render($func_name);
219     if ($wantXS) {
220         like($buf, qr/\Q$func_name is XS code/,
221              "XS code:\t $func_name");
222     } else {
223         unlike($buf, qr/\Q$func_name is XS code/,
224                "perl code:\t $func_name");
225     }
226     #returns like or unlike, whichever was called
227 }
228
229 sub render {
230     my ($func_name) = @_;
231
232     B::Concise::reset_sequence();
233     B::Concise::walk_output(\my $buf);
234
235     my $walker = B::Concise::compile($func_name);
236     eval { $walker->() };
237     diag("err: $@ $buf") if $@;
238     diag("verbose: $buf") if $opts{V};
239
240     return ($buf, $@);
241 }
242
243 sub corecheck {
244
245     eval { require Module::CoreList };
246     if ($@) {
247         warn "Module::CoreList not available on $]\n";
248         return;
249     }
250     my $mods = $Module::CoreList::version{'5.009002'};
251     $mods = [ sort keys %$mods ];
252     print Dumper($mods);
253
254     foreach my $pkgnm (@$mods) {
255         test_pkg($pkgnm);
256     }
257 }
258
259 END {
260     if ($opts{c}) {
261         # print "Corrections: ", Dumper(\%report);
262         print "# Tested Package Subroutines, 1's are XS, 0's are perl\n";
263         print "\$VAR1 = {\n";
264
265         foreach my $pkg (sort keys %report) {
266             my (@xs, @perl);
267             my $stash = $report{$pkg};
268
269             @xs   = sort grep $stash->{$_} == 1, keys %$stash;
270             @perl = sort grep $stash->{$_} == 0, keys %$stash;
271
272             my @list = (@xs > @perl) ? ( '!', @perl) : @xs;
273             print "\t$pkg => [qw/ @list /],\n";
274         }
275         print "};\n";
276     }
277 }
278
279 __END__