3 # 2 purpose file: 1-test 2-demonstrate (via args, -v -a options)
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.
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).
17 %$testpkgs specifies what packages are tested; each package is loaded,
18 and the stash is scanned for the function-names in that package.
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.
23 To keep these HoLs smaller and more manageable, 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.
28 =head1 HOW THEY'RE TESTED
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.
34 To slay this maintenance dragon, the regexs used in like() match
35 against renderings which indicate that there is no implementation.
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 doesn't exist on non-threaded builds.
43 =head1 OPTIONS AND ARGUMENTS
45 C<-v> and C<-V> trigger 2 levels of verbosity.
47 C<-a> uses Module::CoreList to run all core packages through the test, which
48 gives some interesting results.
50 C<-c> causes the expected XS/non-XS results to be marked with
51 corrections, which are then reported at program END, in a form that's
52 readily cut-and-pastable into this file.
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.
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).
66 =item ./perl -Ilib -wS ext/B/t/concise-xs.t -c Storable
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
72 =item ./perl -Ilib -wS ext/B/t/concise-xs.t -r ./storable
74 Loads file, and uses it to set expectations, and run tests
76 =item ./perl -Ilib -wS ext/B/t/concise-xs.t -avc > ../foo-avc 2> ../foo-avc2
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
82 =item ./perl -Ilib -wS ext/B/t/concise-xs.t -cr ../all-xs > ../foo 2> ../foo2
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.
88 Looking at ../foo2, you'll see 34 occurrences of the following error:
90 # err: Can't use an undefined value as a SCALAR reference at
91 # lib/B/Concise.pm line 634, <DATA> line 1.
100 if (($Config::Config{'extensions'} !~ /\bB\b/) ){
101 print "1..0 # Skip -- Perl configured without B module\n";
104 unless ($Config::Config{useperlio}) {
105 print "1..0 # Skip -- Perl configured without perlio\n";
112 use Test::More 'no_plan';
114 require_ok("B::Concise");
117 ( constant => qr{ (?-x: is a constant sub, optimized to a \w+)
118 |(?-x: exists in stash, but has no START) }x,
119 XS => qr/ is XS code/,
120 perl => qr/ (next|db)state/,
121 noSTART => qr/ exists in stash, but has no START/,
125 # packages to test, with expected types for named funcs
127 Digest::MD5 => { perl => [qw/ import /],
130 Data::Dumper => { XS => [qw/ bootstrap Dumpxs /,
131 $] >= 5.015 ? qw/_vstring / : () ],
133 ? (constant => ['_bad_vsmg']) : (),
136 dflt => 'constant', # all but 47/297
137 skip => [ 'regex_padav' ], # threaded only
139 walksymtable walkoptree_slow walkoptree_exec
140 timing_info savesym peekop parents objsym debug
141 compile_stats clearsym class
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
150 begin_av amagic_generation sub_generation address
154 B::Deparse => { dflt => 'perl', # 236 functions
156 XS => [qw( svref_2object perlstring opnumber main_start
157 main_root main_cv )],
159 constant => [qw/ ASSIGN CVf_LVALUE
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
163 OPf_WANT_VOID OPpCONST_BARE OPpCONST_NOVER
164 OPpENTERSUB_AMPER OPpEXISTS_SUB OPpITER_REVERSED
165 OPpLVAL_INTRO OPpOUR_INTRO OPpSLICE OPpSORT_DESCEND
166 OPpSORT_INPLACE OPpSORT_INTEGER OPpSORT_NUMERIC
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
170 PMf_KEEP PMf_NONDESTRUCT
171 PMf_MULTILINE PMf_ONCE PMf_SINGLELINE
172 POSTFIX SVf_FAKE SVf_IOK SVf_NOK SVf_POK SVf_ROK
173 SVpad_OUR SVs_RMG SVs_SMG SWAP_CHILDREN OPpPAD_STATE
174 OPpCONST_ARYBASE RXf_SKIPWHITE/,
176 OP_GLOB PMf_SKIPWHITE RXf_PMf_CHARSET RXf_PMf_KEEPCOPY
177 OPpEVAL_BYTES OPpSUBSTR_REPL_FIRST) : (),
178 $] >= 5.019 ? qw(OP_PUSHMARK OP_NULL) : (),
179 'CVf_LOCKED', # This ends up as a constant, pre or post 5.10
183 POSIX => { dflt => 'constant', # all but 252/589
184 skip => [qw/ _POSIX_JOB_CONTROL /, # platform varying
185 # Might be XS or imported from Fcntl, depending on your
187 qw / S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISREG /,
188 # Might be XS or AUTOLOADed, depending on your perl
190 qw /WEXITSTATUS WIFEXITED WIFSIGNALED WIFSTOPPED
192 'int_macro_int', # Removed in POSIX 1.16
194 perl => [qw/ import croak AUTOLOAD /,
196 ? qw/load_imports usage printf sprintf perror/
200 XS => [qw/ write wctomb wcstombs uname tzset tzname
201 ttyname tmpnam times tcsetpgrp tcsendbreak
202 tcgetpgrp tcflush tcflow tcdrain tanh tan
203 sysconf strxfrm strtoul strtol strtod
204 strftime strcoll sinh sigsuspend sigprocmask
205 sigpending sigaction setuid setsid setpgid
206 setlocale setgid read pipe pause pathconf
207 open nice modf mktime mkfifo mbtowc mbstowcs
208 mblen lseek log10 localeconv ldexp lchown
209 isxdigit isupper isspace ispunct isprint
210 islower isgraph isdigit iscntrl isalpha
211 isalnum getcwd frexp fpathconf
212 fmod floor dup2 dup difftime cuserid ctime
213 ctermid cosh constant close clock ceil
214 bootstrap atan asin asctime acos access abort
216 /, $] >= 5.015 ? ('sleep') : () ],
219 IO::Socket => { dflt => 'constant', # 157/190
221 perl => [qw/ timeout socktype sockopt sockname
222 socketpair socket sockdomain sockaddr_un
223 sockaddr_in shutdown setsockopt send
224 register_domain recv protocol peername
225 new listen import getsockopt croak
226 connected connect configure confess close
227 carp bind atmark accept sockaddr_in6
230 XS => [qw/ unpack_sockaddr_un unpack_sockaddr_in
231 sockatmark sockaddr_family pack_sockaddr_un
232 pack_sockaddr_in inet_ntoa inet_aton
233 unpack_sockaddr_in6 pack_sockaddr_in6
235 # skip inet_ntop and inet_pton as they're not exported by default
241 B::Concise::compile('-nobanner'); # set a silent default
242 getopts('vaVcr:', \my %opts) or
245 usage: PERL_CORE=1 ./perl ext/B/t/concise-xs.t [-av] [module-list]
246 tests ability to discern XS funcs using Digest::MD5 package
249 -a : runs all modules in CoreList
250 -c : writes test corrections as a Data::Dumper expression
251 -r <file> : reads file of tests, as written by -c
252 <args> : additional modules are loaded and tested
253 (will report failures, since no XS funcs are known apriori)
259 require Data::Dumper;
260 Data::Dumper->import('Dumper');
261 { my $x = \*Data::Dumper::Sortkeys } # shut up 'used once' warning
262 $Data::Dumper::Sortkeys = 1;
268 my $refpkgs = require "$opts{r}";
269 $testpkgs->{$_} = $refpkgs->{$_} foreach keys %$refpkgs;
274 foreach $pkg (sort keys %$testpkgs) {
275 test_pkg($pkg, $testpkgs->{$pkg});
278 foreach $pkg (@argpkgs) {
279 test_pkg($pkg, $testpkgs->{$pkg});
288 my ($pkg, $fntypes) = @_;
291 # build %stash: keys are func-names, vals filled in below
294 => ( grep exists &{"$pkg\::$_"} # grab CODE symbols
295 => grep !/__ANON__/ # but not anon subs
296 => keys %{$pkg.'::'} # from symbol table
299 for my $type (keys %matchers) {
300 foreach my $fn (@{$fntypes->{$type}}) {
301 carp "$fn can only be one of $type, $stash{$fn}\n"
306 # set default type for un-named functions
307 my $dflt = $fntypes->{dflt} || 'perl';
308 for my $k (keys %stash) {
309 $stash{$k} = $dflt unless $stash{$k};
311 $stash{$_} = 'skip' foreach @{$fntypes->{skip}};
314 diag("fntypes: " => Dumper($fntypes));
315 diag("$pkg stash: " => Dumper(\%stash));
317 foreach my $fn (reverse sort keys %stash) {
318 next if $stash{$fn} eq 'skip';
319 my $res = checkXS("${pkg}::$fn", $stash{$fn});
321 push @{$report{$pkg}{$res}}, $fn;
327 my ($func_name, $want) = @_;
329 croak "unknown type $want: $func_name\n"
330 unless defined $matchers{$want};
332 my ($buf, $err) = render($func_name);
333 my $res = like($buf, $matchers{$want}, "$want sub:\t $func_name");
336 # test failed. return type that would give success
337 for my $m (keys %matchers) {
338 return $m if $buf =~ $matchers{$m};
345 my ($func_name) = @_;
347 B::Concise::reset_sequence();
348 B::Concise::walk_output(\my $buf);
350 my $walker = B::Concise::compile($func_name);
351 eval { $walker->() };
352 diag("err: $@ $buf") if $@;
353 diag("verbose: $buf") if $opts{V};
359 eval { require Module::CoreList };
361 warn "Module::CoreList not available on $]\n";
364 { my $x = \*Module::CoreList::version } # shut up 'used once' warning
365 my $mods = $Module::CoreList::version{'5.009002'};
366 $mods = [ sort keys %$mods ];
369 foreach my $pkgnm (@$mods) {
376 { my $x = \*Data::Dumper::Indent } # shut up 'used once' warning
377 $Data::Dumper::Indent = 1;
378 print "Corrections: ", Dumper(\%report);
380 foreach my $pkg (sort keys %report) {
381 for my $type (keys %matchers) {
382 print "$pkg: $type: @{$report{$pkg}{$type}}\n"
383 if @{$report{$pkg}{$type}};