Commit | Line | Data |
---|---|---|
c0939cee JC |
1 | #!./perl |
2 | ||
3 | # 2 purpose file: 1-test 2-demonstrate (via args, -v -a options) | |
4 | ||
5b493bdf | 5 | =head1 SYNOPSIS |
c0939cee JC |
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 | |
5b493bdf | 9 | XS functions: B and Digest::MD5. They're listed in %$testpkgs, along |
c0939cee JC |
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 | ||
5b493bdf JC |
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 | ||
c0939cee JC |
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 | ||
5b493bdf JC |
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 | |
c0939cee | 50 | |
5b493bdf JC |
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 | |
c0939cee JC |
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 | } | |
28380c63 NC |
87 | unless ($Config::Config{useperlio}) { |
88 | print "1..0 # Skip -- Perl configured without perlio\n"; | |
89 | exit 0; | |
90 | } | |
c0939cee JC |
91 | } |
92 | ||
93 | use Getopt::Std; | |
94 | use Carp; | |
95 | use Test::More tests => ( 1 * !!$Config::Config{useithreads} | |
a49b57c6 | 96 | + 3 * ($] > 5.009) |
0d863452 | 97 | + 12 * ($] >= 5.009003) |
a49b57c6 | 98 | + 777 ); |
c0939cee JC |
99 | |
100 | require_ok("B::Concise"); | |
101 | ||
102 | my $testpkgs = { | |
468aa647 | 103 | |
c0939cee | 104 | Digest::MD5 => [qw/ ! import /], |
468aa647 | 105 | |
c0939cee JC |
106 | B => [qw/ ! class clearsym compile_stats debug objsym parents |
107 | peekop savesym timing_info walkoptree_exec | |
108 | walkoptree_slow walksymtable /], | |
109 | ||
110 | Data::Dumper => [qw/ bootstrap Dumpxs /], | |
5b493bdf JC |
111 | |
112 | B::Deparse => [qw/ ASSIGN CVf_ASSERTION CVf_LOCKED CVf_LVALUE | |
113 | CVf_METHOD LIST_CONTEXT OP_CONST OP_LIST OP_RV2SV | |
114 | OP_STRINGIFY OPf_KIDS OPf_MOD OPf_REF OPf_SPECIAL | |
115 | OPf_STACKED OPf_WANT OPf_WANT_LIST OPf_WANT_SCALAR | |
116 | OPf_WANT_VOID OPpCONST_ARYBASE OPpCONST_BARE | |
117 | OPpENTERSUB_AMPER OPpEXISTS_SUB OPpITER_REVERSED | |
118 | OPpLVAL_INTRO OPpOUR_INTRO OPpSLICE OPpSORT_DESCEND | |
119 | OPpSORT_INPLACE OPpSORT_INTEGER OPpSORT_NUMERIC | |
120 | OPpSORT_REVERSE OPpTARGET_MY OPpTRANS_COMPLEMENT | |
121 | OPpTRANS_DELETE OPpTRANS_SQUASH PMf_CONTINUE | |
122 | PMf_EVAL PMf_EXTENDED PMf_FOLD PMf_GLOBAL PMf_KEEP | |
123 | PMf_MULTILINE PMf_ONCE PMf_SINGLELINE PMf_SKIPWHITE | |
124 | POSTFIX SVf_FAKE SVf_IOK SVf_NOK SVf_POK SVf_ROK | |
125 | SVpad_OUR SVs_RMG SVs_SMG SWAP_CHILDREN main_cv | |
126 | main_root main_start opnumber perlstring | |
127 | svref_2object /], | |
128 | ||
c0939cee JC |
129 | }; |
130 | ||
131 | ############ | |
132 | ||
133 | B::Concise::compile('-nobanner'); # set a silent default | |
5b493bdf | 134 | getopts('vaVcr:', \my %opts) or |
c0939cee JC |
135 | die <<EODIE; |
136 | ||
137 | usage: PERL_CORE=1 ./perl ext/B/t/concise-xs.t [-av] [module-list] | |
138 | tests ability to discern XS funcs using Digest::MD5 package | |
139 | -v : runs verbosely | |
140 | -V : more verbosity | |
141 | -a : runs all modules in CoreList | |
5b493bdf JC |
142 | -c : writes test corrections as a Data::Dumper expression |
143 | -r <file> : reads file of tests, as written by -c | |
468aa647 | 144 | <args> : additional modules are loaded and tested |
c0939cee JC |
145 | (will report failures, since no XS funcs are known aprior) |
146 | ||
147 | EODIE | |
148 | ; | |
149 | ||
150 | if (%opts) { | |
151 | require Data::Dumper; | |
152 | Data::Dumper->import('Dumper'); | |
153 | $Data::Dumper::Sortkeys = 1; | |
154 | } | |
155 | my @argpkgs = @ARGV; | |
5b493bdf JC |
156 | my %report; |
157 | ||
158 | if ($opts{r}) { | |
159 | my $refpkgs = require "$opts{r}"; | |
160 | $testpkgs->{$_} = $refpkgs->{$_} foreach keys %$refpkgs; | |
468aa647 | 161 | } |
5b493bdf JC |
162 | |
163 | unless ($opts{a}) { | |
164 | unless (@argpkgs) { | |
165 | foreach $pkg (sort keys %$testpkgs) { | |
166 | test_pkg($pkg, $testpkgs->{$pkg}); | |
167 | } | |
168 | } else { | |
169 | foreach $pkg (@argpkgs) { | |
170 | test_pkg($pkg, $testpkgs->{$pkg}); | |
171 | } | |
172 | } | |
173 | } else { | |
174 | corecheck(); | |
c0939cee | 175 | } |
c0939cee JC |
176 | ############ |
177 | ||
178 | sub test_pkg { | |
179 | my ($pkg_name, $xslist) = @_; | |
180 | require_ok($pkg_name); | |
181 | ||
182 | unless (ref $xslist eq 'ARRAY') { | |
183 | warn "no XS/non-XS function list given, assuming empty XS list"; | |
184 | $xslist = ['']; | |
185 | } | |
468aa647 | 186 | |
c0939cee | 187 | my $assumeXS = 0; # assume list enumerates XS funcs, not perl ones |
5b493bdf | 188 | $assumeXS = 1 if $xslist->[0] and $xslist->[0] eq '!'; |
468aa647 | 189 | |
c0939cee JC |
190 | # build %stash: keys are func-names, vals: 1 if XS, 0 if not |
191 | my (%stash) = map | |
192 | ( ($_ => $assumeXS) | |
193 | => ( grep exists &{"$pkg_name\::$_"} # grab CODE symbols | |
194 | => grep !/__ANON__/ # but not anon subs | |
195 | => keys %{$pkg_name.'::'} # from symbol table | |
196 | )); | |
468aa647 | 197 | |
c0939cee JC |
198 | # now invert according to supplied list |
199 | $stash{$_} = int ! $assumeXS foreach @$xslist; | |
468aa647 | 200 | |
c0939cee JC |
201 | # and cleanup cruft (easier than preventing) |
202 | delete @stash{'!',''}; | |
203 | ||
5b493bdf | 204 | if ($opts{v}) { |
c0939cee JC |
205 | diag("xslist: " => Dumper($xslist)); |
206 | diag("$pkg_name stash: " => Dumper(\%stash)); | |
207 | } | |
5b493bdf | 208 | my $err; |
c0939cee | 209 | foreach $func_name (reverse sort keys %stash) { |
5b493bdf JC |
210 | my $res = checkXS("${pkg_name}::$func_name", $stash{$func_name}); |
211 | if (!$res) { | |
212 | $stash{$func_name} ^= 1; | |
213 | print "$func_name "; | |
214 | $err++; | |
215 | } | |
c0939cee | 216 | } |
5b493bdf | 217 | $report{$pkg_name} = \%stash if $opts{c} and $err || $opts{v}; |
c0939cee JC |
218 | } |
219 | ||
220 | sub checkXS { | |
221 | my ($func_name, $wantXS) = @_; | |
222 | ||
223 | my ($buf, $err) = render($func_name); | |
224 | if ($wantXS) { | |
225 | like($buf, qr/\Q$func_name is XS code/, | |
226 | "XS code:\t $func_name"); | |
227 | } else { | |
228 | unlike($buf, qr/\Q$func_name is XS code/, | |
229 | "perl code:\t $func_name"); | |
230 | } | |
231 | #returns like or unlike, whichever was called | |
232 | } | |
233 | ||
234 | sub render { | |
235 | my ($func_name) = @_; | |
236 | ||
237 | B::Concise::reset_sequence(); | |
238 | B::Concise::walk_output(\my $buf); | |
239 | ||
240 | my $walker = B::Concise::compile($func_name); | |
241 | eval { $walker->() }; | |
242 | diag("err: $@ $buf") if $@; | |
243 | diag("verbose: $buf") if $opts{V}; | |
244 | ||
245 | return ($buf, $@); | |
246 | } | |
247 | ||
248 | sub corecheck { | |
5b493bdf | 249 | |
c0939cee JC |
250 | eval { require Module::CoreList }; |
251 | if ($@) { | |
252 | warn "Module::CoreList not available on $]\n"; | |
253 | return; | |
254 | } | |
5b493bdf JC |
255 | my $mods = $Module::CoreList::version{'5.009002'}; |
256 | $mods = [ sort keys %$mods ]; | |
c0939cee JC |
257 | print Dumper($mods); |
258 | ||
5b493bdf | 259 | foreach my $pkgnm (@$mods) { |
c0939cee JC |
260 | test_pkg($pkgnm); |
261 | } | |
262 | } | |
263 | ||
5b493bdf JC |
264 | END { |
265 | if ($opts{c}) { | |
266 | # print "Corrections: ", Dumper(\%report); | |
267 | print "# Tested Package Subroutines, 1's are XS, 0's are perl\n"; | |
268 | print "\$VAR1 = {\n"; | |
269 | ||
270 | foreach my $pkg (sort keys %report) { | |
271 | my (@xs, @perl); | |
272 | my $stash = $report{$pkg}; | |
273 | ||
274 | @xs = sort grep $stash->{$_} == 1, keys %$stash; | |
275 | @perl = sort grep $stash->{$_} == 0, keys %$stash; | |
276 | ||
277 | my @list = (@xs > @perl) ? ( '!', @perl) : @xs; | |
278 | print "\t$pkg => [qw/ @list /],\n"; | |
279 | } | |
280 | print "};\n"; | |
281 | } | |
282 | } | |
283 | ||
c0939cee | 284 | __END__ |