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