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 | 6 | |
d51cf0c9 JC |
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 | ||
b7b1e41b | 23 | To keep these HoLs smaller and more manageable, they may carry an |
d51cf0c9 JC |
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 | |
b7b1e41b | 41 | testing a function which doesn't exist on non-threaded builds. |
c0939cee | 42 | |
5b493bdf JC |
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 JC |
51 | corrections, which are then reported at program END, in a form that's |
52 | readily cut-and-pastable into this file. | |
53 | ||
5b493bdf JC |
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 JC |
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 JC |
62 | =head1 EXAMPLES |
63 | ||
5b493bdf JC |
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 JC |
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 JC |
94 | |
95 | =cut | |
96 | ||
97 | BEGIN { | |
74517a3a | 98 | unshift @INC, 't'; |
c0939cee JC |
99 | require Config; |
100 | if (($Config::Config{'extensions'} !~ /\bB\b/) ){ | |
101 | print "1..0 # Skip -- Perl configured without B module\n"; | |
102 | exit 0; | |
103 | } | |
28380c63 NC |
104 | unless ($Config::Config{useperlio}) { |
105 | print "1..0 # Skip -- Perl configured without perlio\n"; | |
106 | exit 0; | |
107 | } | |
c0939cee JC |
108 | } |
109 | ||
110 | use Getopt::Std; | |
111 | use Carp; | |
3cd6a7dc | 112 | use Test::More 'no_plan'; |
c0939cee JC |
113 | |
114 | require_ok("B::Concise"); | |
115 | ||
d51cf0c9 JC |
116 | my %matchers = |
117 | ( constant => qr{ (?-x: is a constant sub, optimized to a \w+) | |
118 | |(?-x: exists in stash, but has no START) }x, | |
2018a5c3 JC |
119 | XS => qr/ is XS code/, |
120 | perl => qr/ (next|db)state/, | |
121 | noSTART => qr/ exists in stash, but has no START/, | |
d51cf0c9 | 122 | ); |
5b493bdf | 123 | |
d51cf0c9 JC |
124 | my $testpkgs = { |
125 | # packages to test, with expected types for named funcs | |
126 | ||
127 | Digest::MD5 => { perl => [qw/ import /], | |
128 | dflt => 'XS' }, | |
129 | ||
32b17be1 DM |
130 | Data::Dumper => { XS => [qw/ bootstrap Dumpxs /, |
131 | $] >= 5.015 ? qw/_vstring / : () ], | |
132 | $] >= 5.015 | |
133 | ? (constant => ['_bad_vsmg']) : (), | |
d51cf0c9 JC |
134 | dflt => 'perl' }, |
135 | B => { | |
c737faaf | 136 | dflt => 'constant', # all but 47/297 |
d51cf0c9 JC |
137 | skip => [ 'regex_padav' ], # threaded only |
138 | perl => [qw( | |
139 | walksymtable walkoptree_slow walkoptree_exec | |
140 | timing_info savesym peekop parents objsym debug | |
141 | compile_stats clearsym class | |
142 | )], | |
143 | XS => [qw( | |
144 | warnhook walkoptree_debug walkoptree threadsv_names | |
145 | svref_2object sv_yes sv_undef sv_no save_BEGINs | |
146 | regex_padav ppname perlstring opnumber minus_c | |
147 | main_start main_root main_cv init_av inc_gv hash | |
148 | formfeed end_av dowarn diehook defstash curstash | |
149 | cstring comppadlist check_av cchar cast_I32 bootstrap | |
5ce57cc0 | 150 | begin_av amagic_generation sub_generation address |
35633035 | 151 | unitcheck_av) ], |
d51cf0c9 JC |
152 | }, |
153 | ||
867fa1e2 | 154 | B::Deparse => { dflt => 'perl', # 236 functions |
d51cf0c9 JC |
155 | |
156 | XS => [qw( svref_2object perlstring opnumber main_start | |
157 | main_root main_cv )], | |
158 | ||
e95ab0c0 | 159 | constant => [qw/ ASSIGN CVf_LVALUE |
d51cf0c9 JC |
160 | CVf_METHOD LIST_CONTEXT OP_CONST OP_LIST OP_RV2SV |
161 | OP_STRINGIFY OPf_KIDS OPf_MOD OPf_REF OPf_SPECIAL | |
162 | OPf_STACKED OPf_WANT OPf_WANT_LIST OPf_WANT_SCALAR | |
e1dccc0d | 163 | OPf_WANT_VOID OPpCONST_BARE OPpCONST_NOVER |
d51cf0c9 JC |
164 | OPpENTERSUB_AMPER OPpEXISTS_SUB OPpITER_REVERSED |
165 | OPpLVAL_INTRO OPpOUR_INTRO OPpSLICE OPpSORT_DESCEND | |
166 | OPpSORT_INPLACE OPpSORT_INTEGER OPpSORT_NUMERIC | |
689e417f VP |
167 | OPpSORT_REVERSE OPpREVERSE_INPLACE OPpTARGET_MY |
168 | OPpTRANS_COMPLEMENT OPpTRANS_DELETE OPpTRANS_SQUASH | |
169 | PMf_CONTINUE PMf_EVAL PMf_EXTENDED PMf_FOLD PMf_GLOBAL | |
32b17be1 DM |
170 | PMf_KEEP PMf_NONDESTRUCT |
171 | PMf_MULTILINE PMf_ONCE PMf_SINGLELINE | |
d51cf0c9 | 172 | POSTFIX SVf_FAKE SVf_IOK SVf_NOK SVf_POK SVf_ROK |
d449ddce | 173 | SVpad_OUR SVs_RMG SVs_SMG SWAP_CHILDREN OPpPAD_STATE |
32b17be1 DM |
174 | OPpCONST_ARYBASE RXf_SKIPWHITE/, |
175 | $] >= 5.015 ? qw( | |
176 | OP_GLOB PMf_SKIPWHITE RXf_PMf_CHARSET RXf_PMf_KEEPCOPY | |
177 | OPpEVAL_BYTES OPpSUBSTR_REPL_FIRST) : (), | |
e5856194 | 178 | $] >= 5.019 ? qw(OP_PUSHMARK OP_NULL) : (), |
aa381260 NC |
179 | 'CVf_LOCKED', # This ends up as a constant, pre or post 5.10 |
180 | ], | |
d51cf0c9 JC |
181 | }, |
182 | ||
f9f861ec | 183 | POSIX => { dflt => 'constant', # all but 252/589 |
9b68a132 | 184 | skip => [qw/ _POSIX_JOB_CONTROL /, # platform varying |
61699fd9 | 185 | # Might be XS or imported from Fcntl, depending on your |
9b68a132 | 186 | # perl version: |
e99d581a NC |
187 | qw / S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISREG /, |
188 | # Might be XS or AUTOLOADed, depending on your perl | |
189 | # version: | |
190 | qw /WEXITSTATUS WIFEXITED WIFSIGNALED WIFSTOPPED | |
191 | WSTOPSIG WTERMSIG/, | |
192 | 'int_macro_int', # Removed in POSIX 1.16 | |
7965edec JH |
193 | |
194 | 'strtold', # platform varying (C99) | |
195 | ||
a5713e21 JH |
196 | qw/fegetround fesetround/, |
197 | ||
7965edec JH |
198 | # C99 math |
199 | qw/acosh asinh atanh cbrt copysign cosh erf | |
200 | erfc exp2 expm1 fdim fma fmax fmin fpclassify | |
201 | hypot ilogb isfinite isgreater isgreaterequal | |
202 | isinf isless islessequal islessgreater isnan | |
203 | isnormal isunordered j0 j1 jn lgamma log1p | |
9e010b89 JH |
204 | log2 logb lrint lround nan nearbyint nextafter |
205 | nexttoward remainder remquo rint round scalbn | |
206 | signbit sinh tanh tgamma trunc y0 y1 yn/, | |
7965edec | 207 | |
e99d581a | 208 | ], |
32b17be1 DM |
209 | perl => [qw/ import croak AUTOLOAD /, |
210 | $] >= 5.015 | |
211 | ? qw/load_imports usage printf sprintf perror/ | |
212 | : (), | |
213 | ], | |
d51cf0c9 JC |
214 | |
215 | XS => [qw/ write wctomb wcstombs uname tzset tzname | |
216 | ttyname tmpnam times tcsetpgrp tcsendbreak | |
217 | tcgetpgrp tcflush tcflow tcdrain tanh tan | |
73e21afd | 218 | sysconf strxfrm strtoul strtol strtod |
d51cf0c9 JC |
219 | strftime strcoll sinh sigsuspend sigprocmask |
220 | sigpending sigaction setuid setsid setpgid | |
221 | setlocale setgid read pipe pause pathconf | |
222 | open nice modf mktime mkfifo mbtowc mbstowcs | |
223 | mblen lseek log10 localeconv ldexp lchown | |
224 | isxdigit isupper isspace ispunct isprint | |
225 | islower isgraph isdigit iscntrl isalpha | |
e99d581a | 226 | isalnum getcwd frexp fpathconf |
d51cf0c9 JC |
227 | fmod floor dup2 dup difftime cuserid ctime |
228 | ctermid cosh constant close clock ceil | |
229 | bootstrap atan asin asctime acos access abort | |
32b17be1 DM |
230 | _exit |
231 | /, $] >= 5.015 ? ('sleep') : () ], | |
d51cf0c9 | 232 | }, |
2018a5c3 | 233 | |
f84b4b22 | 234 | IO::Socket => { dflt => 'constant', # 157/190 |
2018a5c3 JC |
235 | |
236 | perl => [qw/ timeout socktype sockopt sockname | |
237 | socketpair socket sockdomain sockaddr_un | |
238 | sockaddr_in shutdown setsockopt send | |
239 | register_domain recv protocol peername | |
240 | new listen import getsockopt croak | |
241 | connected connect configure confess close | |
0c7e1d80 | 242 | carp bind atmark accept sockaddr_in6 |
35633035 | 243 | blocking/ ], |
2018a5c3 JC |
244 | |
245 | XS => [qw/ unpack_sockaddr_un unpack_sockaddr_in | |
246 | sockatmark sockaddr_family pack_sockaddr_un | |
247 | pack_sockaddr_in inet_ntoa inet_aton | |
0c7e1d80 | 248 | unpack_sockaddr_in6 pack_sockaddr_in6 |
2018a5c3 | 249 | /], |
d6896be3 | 250 | # skip inet_ntop and inet_pton as they're not exported by default |
2018a5c3 | 251 | }, |
c0939cee JC |
252 | }; |
253 | ||
254 | ############ | |
255 | ||
256 | B::Concise::compile('-nobanner'); # set a silent default | |
5b493bdf | 257 | getopts('vaVcr:', \my %opts) or |
c0939cee JC |
258 | die <<EODIE; |
259 | ||
260 | usage: PERL_CORE=1 ./perl ext/B/t/concise-xs.t [-av] [module-list] | |
261 | tests ability to discern XS funcs using Digest::MD5 package | |
262 | -v : runs verbosely | |
263 | -V : more verbosity | |
264 | -a : runs all modules in CoreList | |
5b493bdf JC |
265 | -c : writes test corrections as a Data::Dumper expression |
266 | -r <file> : reads file of tests, as written by -c | |
468aa647 | 267 | <args> : additional modules are loaded and tested |
d51cf0c9 | 268 | (will report failures, since no XS funcs are known apriori) |
c0939cee JC |
269 | |
270 | EODIE | |
271 | ; | |
272 | ||
273 | if (%opts) { | |
274 | require Data::Dumper; | |
275 | Data::Dumper->import('Dumper'); | |
82aeefe1 | 276 | { my $x = \*Data::Dumper::Sortkeys } # shut up 'used once' warning |
c0939cee JC |
277 | $Data::Dumper::Sortkeys = 1; |
278 | } | |
279 | my @argpkgs = @ARGV; | |
5b493bdf JC |
280 | my %report; |
281 | ||
282 | if ($opts{r}) { | |
283 | my $refpkgs = require "$opts{r}"; | |
284 | $testpkgs->{$_} = $refpkgs->{$_} foreach keys %$refpkgs; | |
468aa647 | 285 | } |
5b493bdf JC |
286 | |
287 | unless ($opts{a}) { | |
288 | unless (@argpkgs) { | |
289 | foreach $pkg (sort keys %$testpkgs) { | |
290 | test_pkg($pkg, $testpkgs->{$pkg}); | |
291 | } | |
292 | } else { | |
293 | foreach $pkg (@argpkgs) { | |
294 | test_pkg($pkg, $testpkgs->{$pkg}); | |
295 | } | |
296 | } | |
297 | } else { | |
298 | corecheck(); | |
c0939cee | 299 | } |
c0939cee JC |
300 | ############ |
301 | ||
302 | sub test_pkg { | |
d51cf0c9 JC |
303 | my ($pkg, $fntypes) = @_; |
304 | require_ok($pkg); | |
c0939cee | 305 | |
d51cf0c9 | 306 | # build %stash: keys are func-names, vals filled in below |
c0939cee | 307 | my (%stash) = map |
d51cf0c9 JC |
308 | ( ($_ => 0) |
309 | => ( grep exists &{"$pkg\::$_"} # grab CODE symbols | |
c0939cee | 310 | => grep !/__ANON__/ # but not anon subs |
d51cf0c9 | 311 | => keys %{$pkg.'::'} # from symbol table |
c0939cee | 312 | )); |
468aa647 | 313 | |
d51cf0c9 JC |
314 | for my $type (keys %matchers) { |
315 | foreach my $fn (@{$fntypes->{$type}}) { | |
316 | carp "$fn can only be one of $type, $stash{$fn}\n" | |
317 | if $stash{$fn}; | |
318 | $stash{$fn} = $type; | |
319 | } | |
320 | } | |
321 | # set default type for un-named functions | |
322 | my $dflt = $fntypes->{dflt} || 'perl'; | |
323 | for my $k (keys %stash) { | |
324 | $stash{$k} = $dflt unless $stash{$k}; | |
325 | } | |
326 | $stash{$_} = 'skip' foreach @{$fntypes->{skip}}; | |
c0939cee | 327 | |
5b493bdf | 328 | if ($opts{v}) { |
d51cf0c9 JC |
329 | diag("fntypes: " => Dumper($fntypes)); |
330 | diag("$pkg stash: " => Dumper(\%stash)); | |
c0939cee | 331 | } |
d51cf0c9 JC |
332 | foreach my $fn (reverse sort keys %stash) { |
333 | next if $stash{$fn} eq 'skip'; | |
334 | my $res = checkXS("${pkg}::$fn", $stash{$fn}); | |
335 | if ($res ne '1') { | |
336 | push @{$report{$pkg}{$res}}, $fn; | |
5b493bdf | 337 | } |
c0939cee JC |
338 | } |
339 | } | |
340 | ||
341 | sub checkXS { | |
d51cf0c9 JC |
342 | my ($func_name, $want) = @_; |
343 | ||
344 | croak "unknown type $want: $func_name\n" | |
345 | unless defined $matchers{$want}; | |
c0939cee JC |
346 | |
347 | my ($buf, $err) = render($func_name); | |
d51cf0c9 JC |
348 | my $res = like($buf, $matchers{$want}, "$want sub:\t $func_name"); |
349 | ||
350 | unless ($res) { | |
351 | # test failed. return type that would give success | |
352 | for my $m (keys %matchers) { | |
353 | return $m if $buf =~ $matchers{$m}; | |
354 | } | |
c0939cee | 355 | } |
d51cf0c9 | 356 | $res; |
c0939cee JC |
357 | } |
358 | ||
359 | sub render { | |
360 | my ($func_name) = @_; | |
361 | ||
362 | B::Concise::reset_sequence(); | |
363 | B::Concise::walk_output(\my $buf); | |
364 | ||
365 | my $walker = B::Concise::compile($func_name); | |
366 | eval { $walker->() }; | |
367 | diag("err: $@ $buf") if $@; | |
368 | diag("verbose: $buf") if $opts{V}; | |
369 | ||
370 | return ($buf, $@); | |
371 | } | |
372 | ||
373 | sub corecheck { | |
374 | eval { require Module::CoreList }; | |
375 | if ($@) { | |
376 | warn "Module::CoreList not available on $]\n"; | |
377 | return; | |
378 | } | |
82aeefe1 | 379 | { my $x = \*Module::CoreList::version } # shut up 'used once' warning |
5b493bdf JC |
380 | my $mods = $Module::CoreList::version{'5.009002'}; |
381 | $mods = [ sort keys %$mods ]; | |
c0939cee JC |
382 | print Dumper($mods); |
383 | ||
5b493bdf | 384 | foreach my $pkgnm (@$mods) { |
c0939cee JC |
385 | test_pkg($pkgnm); |
386 | } | |
387 | } | |
388 | ||
5b493bdf JC |
389 | END { |
390 | if ($opts{c}) { | |
82aeefe1 | 391 | { my $x = \*Data::Dumper::Indent } # shut up 'used once' warning |
d51cf0c9 JC |
392 | $Data::Dumper::Indent = 1; |
393 | print "Corrections: ", Dumper(\%report); | |
5b493bdf JC |
394 | |
395 | foreach my $pkg (sort keys %report) { | |
d51cf0c9 JC |
396 | for my $type (keys %matchers) { |
397 | print "$pkg: $type: @{$report{$pkg}{$type}}\n" | |
398 | if @{$report{$pkg}{$type}}; | |
399 | } | |
5b493bdf | 400 | } |
5b493bdf JC |
401 | } |
402 | } | |
403 | ||
c0939cee | 404 | __END__ |