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 |
c737faaf |
120 | + 517 + 262 # B::Deparse, B |
fba16c4d |
121 | + 595 + 190 # POSIX, IO::Socket |
117af99a |
122 | + 323 * ($] > 5.009) |
e412117e |
123 | + 17 * ($] >= 5.009003) |
13d771f0 |
124 | - 344); # 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 => { |
c737faaf |
145 | dflt => 'constant', # all but 47/297 |
d51cf0c9 |
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 |
e412117e |
160 | ), $] > 5.009 ? ('unitcheck_av') : ()], |
d51cf0c9 |
161 | }, |
162 | |
163 | B::Deparse => { dflt => 'perl', # 235 functions |
164 | |
165 | XS => [qw( svref_2object perlstring opnumber main_start |
166 | main_root main_cv )], |
167 | |
168 | constant => [qw/ ASSIGN CVf_ASSERTION CVf_LOCKED CVf_LVALUE |
169 | CVf_METHOD LIST_CONTEXT OP_CONST OP_LIST OP_RV2SV |
170 | OP_STRINGIFY OPf_KIDS OPf_MOD OPf_REF OPf_SPECIAL |
171 | OPf_STACKED OPf_WANT OPf_WANT_LIST OPf_WANT_SCALAR |
172 | OPf_WANT_VOID OPpCONST_ARYBASE OPpCONST_BARE |
173 | OPpENTERSUB_AMPER OPpEXISTS_SUB OPpITER_REVERSED |
174 | OPpLVAL_INTRO OPpOUR_INTRO OPpSLICE OPpSORT_DESCEND |
175 | OPpSORT_INPLACE OPpSORT_INTEGER OPpSORT_NUMERIC |
176 | OPpSORT_REVERSE OPpTARGET_MY OPpTRANS_COMPLEMENT |
177 | OPpTRANS_DELETE OPpTRANS_SQUASH PMf_CONTINUE |
178 | PMf_EVAL PMf_EXTENDED PMf_FOLD PMf_GLOBAL PMf_KEEP |
c737faaf |
179 | PMf_MULTILINE PMf_ONCE PMf_SINGLELINE RXf_SKIPWHITE |
d51cf0c9 |
180 | POSTFIX SVf_FAKE SVf_IOK SVf_NOK SVf_POK SVf_ROK |
d449ddce |
181 | SVpad_OUR SVs_RMG SVs_SMG SWAP_CHILDREN OPpPAD_STATE |
d51cf0c9 |
182 | /], |
183 | }, |
184 | |
f9f861ec |
185 | POSIX => { dflt => 'constant', # all but 252/589 |
186 | skip => [qw/ _POSIX_JOB_CONTROL /], # platform varying |
d51cf0c9 |
187 | perl => [qw/ import croak AUTOLOAD /], |
188 | |
189 | XS => [qw/ write wctomb wcstombs uname tzset tzname |
190 | ttyname tmpnam times tcsetpgrp tcsendbreak |
191 | tcgetpgrp tcflush tcflow tcdrain tanh tan |
192 | sysconf strxfrm strtoul strtol strtod |
193 | strftime strcoll sinh sigsuspend sigprocmask |
194 | sigpending sigaction setuid setsid setpgid |
195 | setlocale setgid read pipe pause pathconf |
196 | open nice modf mktime mkfifo mbtowc mbstowcs |
197 | mblen lseek log10 localeconv ldexp lchown |
198 | isxdigit isupper isspace ispunct isprint |
199 | islower isgraph isdigit iscntrl isalpha |
200 | isalnum int_macro_int getcwd frexp fpathconf |
201 | fmod floor dup2 dup difftime cuserid ctime |
202 | ctermid cosh constant close clock ceil |
203 | bootstrap atan asin asctime acos access abort |
2018a5c3 |
204 | _exit |
d51cf0c9 |
205 | /], |
206 | }, |
2018a5c3 |
207 | |
f84b4b22 |
208 | IO::Socket => { dflt => 'constant', # 157/190 |
2018a5c3 |
209 | |
210 | perl => [qw/ timeout socktype sockopt sockname |
211 | socketpair socket sockdomain sockaddr_un |
212 | sockaddr_in shutdown setsockopt send |
213 | register_domain recv protocol peername |
214 | new listen import getsockopt croak |
215 | connected connect configure confess close |
e412117e |
216 | carp bind atmark accept |
217 | /, $] > 5.009 ? ('blocking') : () ], |
2018a5c3 |
218 | |
219 | XS => [qw/ unpack_sockaddr_un unpack_sockaddr_in |
220 | sockatmark sockaddr_family pack_sockaddr_un |
221 | pack_sockaddr_in inet_ntoa inet_aton |
222 | /], |
223 | }, |
c0939cee |
224 | }; |
225 | |
226 | ############ |
227 | |
228 | B::Concise::compile('-nobanner'); # set a silent default |
5b493bdf |
229 | getopts('vaVcr:', \my %opts) or |
c0939cee |
230 | die <<EODIE; |
231 | |
232 | usage: PERL_CORE=1 ./perl ext/B/t/concise-xs.t [-av] [module-list] |
233 | tests ability to discern XS funcs using Digest::MD5 package |
234 | -v : runs verbosely |
235 | -V : more verbosity |
236 | -a : runs all modules in CoreList |
5b493bdf |
237 | -c : writes test corrections as a Data::Dumper expression |
238 | -r <file> : reads file of tests, as written by -c |
468aa647 |
239 | <args> : additional modules are loaded and tested |
d51cf0c9 |
240 | (will report failures, since no XS funcs are known apriori) |
c0939cee |
241 | |
242 | EODIE |
243 | ; |
244 | |
245 | if (%opts) { |
246 | require Data::Dumper; |
247 | Data::Dumper->import('Dumper'); |
248 | $Data::Dumper::Sortkeys = 1; |
249 | } |
250 | my @argpkgs = @ARGV; |
5b493bdf |
251 | my %report; |
252 | |
253 | if ($opts{r}) { |
254 | my $refpkgs = require "$opts{r}"; |
255 | $testpkgs->{$_} = $refpkgs->{$_} foreach keys %$refpkgs; |
468aa647 |
256 | } |
5b493bdf |
257 | |
258 | unless ($opts{a}) { |
259 | unless (@argpkgs) { |
260 | foreach $pkg (sort keys %$testpkgs) { |
261 | test_pkg($pkg, $testpkgs->{$pkg}); |
262 | } |
263 | } else { |
264 | foreach $pkg (@argpkgs) { |
265 | test_pkg($pkg, $testpkgs->{$pkg}); |
266 | } |
267 | } |
268 | } else { |
269 | corecheck(); |
c0939cee |
270 | } |
c0939cee |
271 | ############ |
272 | |
273 | sub test_pkg { |
d51cf0c9 |
274 | my ($pkg, $fntypes) = @_; |
275 | require_ok($pkg); |
c0939cee |
276 | |
d51cf0c9 |
277 | # build %stash: keys are func-names, vals filled in below |
c0939cee |
278 | my (%stash) = map |
d51cf0c9 |
279 | ( ($_ => 0) |
280 | => ( grep exists &{"$pkg\::$_"} # grab CODE symbols |
c0939cee |
281 | => grep !/__ANON__/ # but not anon subs |
d51cf0c9 |
282 | => keys %{$pkg.'::'} # from symbol table |
c0939cee |
283 | )); |
468aa647 |
284 | |
d51cf0c9 |
285 | for my $type (keys %matchers) { |
286 | foreach my $fn (@{$fntypes->{$type}}) { |
287 | carp "$fn can only be one of $type, $stash{$fn}\n" |
288 | if $stash{$fn}; |
289 | $stash{$fn} = $type; |
290 | } |
291 | } |
292 | # set default type for un-named functions |
293 | my $dflt = $fntypes->{dflt} || 'perl'; |
294 | for my $k (keys %stash) { |
295 | $stash{$k} = $dflt unless $stash{$k}; |
296 | } |
297 | $stash{$_} = 'skip' foreach @{$fntypes->{skip}}; |
c0939cee |
298 | |
5b493bdf |
299 | if ($opts{v}) { |
d51cf0c9 |
300 | diag("fntypes: " => Dumper($fntypes)); |
301 | diag("$pkg stash: " => Dumper(\%stash)); |
c0939cee |
302 | } |
d51cf0c9 |
303 | foreach my $fn (reverse sort keys %stash) { |
304 | next if $stash{$fn} eq 'skip'; |
305 | my $res = checkXS("${pkg}::$fn", $stash{$fn}); |
306 | if ($res ne '1') { |
307 | push @{$report{$pkg}{$res}}, $fn; |
5b493bdf |
308 | } |
c0939cee |
309 | } |
310 | } |
311 | |
312 | sub checkXS { |
d51cf0c9 |
313 | my ($func_name, $want) = @_; |
314 | |
315 | croak "unknown type $want: $func_name\n" |
316 | unless defined $matchers{$want}; |
c0939cee |
317 | |
318 | my ($buf, $err) = render($func_name); |
d51cf0c9 |
319 | my $res = like($buf, $matchers{$want}, "$want sub:\t $func_name"); |
320 | |
321 | unless ($res) { |
322 | # test failed. return type that would give success |
323 | for my $m (keys %matchers) { |
324 | return $m if $buf =~ $matchers{$m}; |
325 | } |
c0939cee |
326 | } |
d51cf0c9 |
327 | $res; |
c0939cee |
328 | } |
329 | |
330 | sub render { |
331 | my ($func_name) = @_; |
332 | |
333 | B::Concise::reset_sequence(); |
334 | B::Concise::walk_output(\my $buf); |
335 | |
336 | my $walker = B::Concise::compile($func_name); |
337 | eval { $walker->() }; |
338 | diag("err: $@ $buf") if $@; |
339 | diag("verbose: $buf") if $opts{V}; |
340 | |
341 | return ($buf, $@); |
342 | } |
343 | |
344 | sub corecheck { |
345 | eval { require Module::CoreList }; |
346 | if ($@) { |
347 | warn "Module::CoreList not available on $]\n"; |
348 | return; |
349 | } |
5b493bdf |
350 | my $mods = $Module::CoreList::version{'5.009002'}; |
351 | $mods = [ sort keys %$mods ]; |
c0939cee |
352 | print Dumper($mods); |
353 | |
5b493bdf |
354 | foreach my $pkgnm (@$mods) { |
c0939cee |
355 | test_pkg($pkgnm); |
356 | } |
357 | } |
358 | |
5b493bdf |
359 | END { |
360 | if ($opts{c}) { |
d51cf0c9 |
361 | $Data::Dumper::Indent = 1; |
362 | print "Corrections: ", Dumper(\%report); |
5b493bdf |
363 | |
364 | foreach my $pkg (sort keys %report) { |
d51cf0c9 |
365 | for my $type (keys %matchers) { |
366 | print "$pkg: $type: @{$report{$pkg}{$type}}\n" |
367 | if @{$report{$pkg}{$type}}; |
368 | } |
5b493bdf |
369 | } |
5b493bdf |
370 | } |
371 | } |
372 | |
c0939cee |
373 | __END__ |