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 | } |
87 | } |
88 | |
89 | use Getopt::Std; |
90 | use Carp; |
91 | use Test::More tests => ( 1 * !!$Config::Config{useithreads} |
92 | + 2 * ($] > 5.009) |
5b493bdf |
93 | + 776); |
c0939cee |
94 | |
95 | require_ok("B::Concise"); |
96 | |
97 | my $testpkgs = { |
5b493bdf |
98 | |
c0939cee |
99 | Digest::MD5 => [qw/ ! import /], |
5b493bdf |
100 | |
c0939cee |
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 /], |
5b493bdf |
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 | |
c0939cee |
124 | }; |
125 | |
126 | ############ |
127 | |
128 | B::Concise::compile('-nobanner'); # set a silent default |
5b493bdf |
129 | getopts('vaVcr:', \my %opts) or |
c0939cee |
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 |
5b493bdf |
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 |
c0939cee |
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; |
5b493bdf |
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(); |
c0939cee |
170 | } |
c0939cee |
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 | } |
5b493bdf |
181 | |
c0939cee |
182 | my $assumeXS = 0; # assume list enumerates XS funcs, not perl ones |
5b493bdf |
183 | $assumeXS = 1 if $xslist->[0] and $xslist->[0] eq '!'; |
184 | |
c0939cee |
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 | )); |
5b493bdf |
192 | |
c0939cee |
193 | # now invert according to supplied list |
194 | $stash{$_} = int ! $assumeXS foreach @$xslist; |
5b493bdf |
195 | |
c0939cee |
196 | # and cleanup cruft (easier than preventing) |
197 | delete @stash{'!',''}; |
198 | |
5b493bdf |
199 | if ($opts{v}) { |
c0939cee |
200 | diag("xslist: " => Dumper($xslist)); |
201 | diag("$pkg_name stash: " => Dumper(\%stash)); |
202 | } |
5b493bdf |
203 | my $err; |
c0939cee |
204 | foreach $func_name (reverse sort keys %stash) { |
5b493bdf |
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 | } |
c0939cee |
211 | } |
5b493bdf |
212 | $report{$pkg_name} = \%stash if $opts{c} and $err || $opts{v}; |
c0939cee |
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 { |
5b493bdf |
244 | |
c0939cee |
245 | eval { require Module::CoreList }; |
246 | if ($@) { |
247 | warn "Module::CoreList not available on $]\n"; |
248 | return; |
249 | } |
5b493bdf |
250 | my $mods = $Module::CoreList::version{'5.009002'}; |
251 | $mods = [ sort keys %$mods ]; |
c0939cee |
252 | print Dumper($mods); |
253 | |
5b493bdf |
254 | foreach my $pkgnm (@$mods) { |
c0939cee |
255 | test_pkg($pkgnm); |
256 | } |
257 | } |
258 | |
5b493bdf |
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 | |
c0939cee |
279 | __END__ |