Commit | Line | Data |
c0939cee |
1 | #!./perl |
2 | |
3 | # 2 purpose file: 1-test 2-demonstrate (via args, -v -a options) |
4 | |
5b493bdf |
5 | =head1 SYNOPSIS |
c0939cee |
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 |
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 |
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 |
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 |
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 |
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 |
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 |
87 | unless ($Config::Config{useperlio}) { |
88 | print "1..0 # Skip -- Perl configured without perlio\n"; |
89 | exit 0; |
90 | } |
c0939cee |
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 |
99 | |
100 | require_ok("B::Concise"); |
101 | |
102 | my $testpkgs = { |
468aa647 |
103 | |
c0939cee |
104 | Digest::MD5 => [qw/ ! import /], |
468aa647 |
105 | |
c0939cee |
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 |
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 |
129 | }; |
130 | |
131 | ############ |
132 | |
133 | B::Concise::compile('-nobanner'); # set a silent default |
5b493bdf |
134 | getopts('vaVcr:', \my %opts) or |
c0939cee |
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 |
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 |
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 |
156 | my %report; |
157 | |
158 | if ($opts{r}) { |
159 | my $refpkgs = require "$opts{r}"; |
160 | $testpkgs->{$_} = $refpkgs->{$_} foreach keys %$refpkgs; |
468aa647 |
161 | } |
5b493bdf |
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 |
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 |
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 |
198 | # now invert according to supplied list |
199 | $stash{$_} = int ! $assumeXS foreach @$xslist; |
468aa647 |
200 | |
c0939cee |
201 | # and cleanup cruft (easier than preventing) |
202 | delete @stash{'!',''}; |
203 | |
5b493bdf |
204 | if ($opts{v}) { |
c0939cee |
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 |
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 |
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 |
250 | eval { require Module::CoreList }; |
251 | if ($@) { |
252 | warn "Module::CoreList not available on $]\n"; |
253 | return; |
254 | } |
5b493bdf |
255 | my $mods = $Module::CoreList::version{'5.009002'}; |
256 | $mods = [ sort keys %$mods ]; |
c0939cee |
257 | print Dumper($mods); |
258 | |
5b493bdf |
259 | foreach my $pkgnm (@$mods) { |
c0939cee |
260 | test_pkg($pkgnm); |
261 | } |
262 | } |
263 | |
5b493bdf |
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__ |