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 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.
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 doesnt 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 /],
133 dflt => 'constant', # all but 47/297
134 skip => [ 'regex_padav' ], # threaded only
136 walksymtable walkoptree_slow walkoptree_exec
137 timing_info savesym peekop parents objsym debug
138 compile_stats clearsym class
141 warnhook walkoptree_debug walkoptree threadsv_names
142 svref_2object sv_yes sv_undef sv_no save_BEGINs
143 regex_padav ppname perlstring opnumber minus_c
144 main_start main_root main_cv init_av inc_gv hash
145 formfeed end_av dowarn diehook defstash curstash
146 cstring comppadlist check_av cchar cast_I32 bootstrap
147 begin_av amagic_generation sub_generation address
148 ), $] > 5.009 ? ('unitcheck_av') : ()],
151 B::Deparse => { dflt => 'perl', # 236 functions
153 XS => [qw( svref_2object perlstring opnumber main_start
154 main_root main_cv )],
156 constant => [qw/ ASSIGN CVf_LVALUE
157 CVf_METHOD LIST_CONTEXT OP_CONST OP_LIST OP_RV2SV
158 OP_STRINGIFY OPf_KIDS OPf_MOD OPf_REF OPf_SPECIAL
159 OPf_STACKED OPf_WANT OPf_WANT_LIST OPf_WANT_SCALAR
160 OPf_WANT_VOID OPpCONST_ARYBASE OPpCONST_BARE
161 OPpENTERSUB_AMPER OPpEXISTS_SUB OPpITER_REVERSED
162 OPpLVAL_INTRO OPpOUR_INTRO OPpSLICE OPpSORT_DESCEND
163 OPpSORT_INPLACE OPpSORT_INTEGER OPpSORT_NUMERIC
164 OPpSORT_REVERSE OPpREVERSE_INPLACE OPpTARGET_MY
165 OPpTRANS_COMPLEMENT OPpTRANS_DELETE OPpTRANS_SQUASH
166 PMf_CONTINUE PMf_EVAL PMf_EXTENDED PMf_FOLD PMf_GLOBAL
167 PMf_KEEP PMf_MULTILINE PMf_ONCE PMf_SINGLELINE
168 POSTFIX SVf_FAKE SVf_IOK SVf_NOK SVf_POK SVf_ROK
169 SVpad_OUR SVs_RMG SVs_SMG SWAP_CHILDREN OPpPAD_STATE
170 /, $] > 5.009 ? ('RXf_SKIPWHITE') : ('PMf_SKIPWHITE'),
171 'CVf_LOCKED', # This ends up as a constant, pre or post 5.10
175 POSIX => { dflt => 'constant', # all but 252/589
176 skip => [qw/ _POSIX_JOB_CONTROL /, # platform varying
177 # Might be XS or imported from Fcntl, depending on your
179 qw / S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISREG /,
180 # Might be XS or AUTOLOADed, depending on your perl
182 qw /WEXITSTATUS WIFEXITED WIFSIGNALED WIFSTOPPED
184 'int_macro_int', # Removed in POSIX 1.16
186 perl => [qw/ import croak AUTOLOAD /],
188 XS => [qw/ write wctomb wcstombs uname tzset tzname
189 ttyname tmpnam times tcsetpgrp tcsendbreak
190 tcgetpgrp tcflush tcflow tcdrain tanh tan
191 sysconf strxfrm strtoul strtol strtod
192 strftime strcoll sinh sigsuspend sigprocmask
193 sigpending sigaction setuid setsid setpgid
194 setlocale setgid read pipe pause pathconf
195 open nice modf mktime mkfifo mbtowc mbstowcs
196 mblen lseek log10 localeconv ldexp lchown
197 isxdigit isupper isspace ispunct isprint
198 islower isgraph isdigit iscntrl isalpha
199 isalnum getcwd frexp fpathconf
200 fmod floor dup2 dup difftime cuserid ctime
201 ctermid cosh constant close clock ceil
202 bootstrap atan asin asctime acos access abort
207 IO::Socket => { dflt => 'constant', # 157/190
209 perl => [qw/ timeout socktype sockopt sockname
210 socketpair socket sockdomain sockaddr_un
211 sockaddr_in shutdown setsockopt send
212 register_domain recv protocol peername
213 new listen import getsockopt croak
214 connected connect configure confess close
215 carp bind atmark accept
216 /, $] > 5.009 ? ('blocking') : () ],
218 XS => [qw/ unpack_sockaddr_un unpack_sockaddr_in
219 sockatmark sockaddr_family pack_sockaddr_un
220 pack_sockaddr_in inet_ntoa inet_aton
222 # skip inet_ntop and inet_pton as they're not exported by default
228 B::Concise::compile('-nobanner'); # set a silent default
229 getopts('vaVcr:', \my %opts) or
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
236 -a : runs all modules in CoreList
237 -c : writes test corrections as a Data::Dumper expression
238 -r <file> : reads file of tests, as written by -c
239 <args> : additional modules are loaded and tested
240 (will report failures, since no XS funcs are known apriori)
246 require Data::Dumper;
247 Data::Dumper->import('Dumper');
248 $Data::Dumper::Sortkeys = 1;
254 my $refpkgs = require "$opts{r}";
255 $testpkgs->{$_} = $refpkgs->{$_} foreach keys %$refpkgs;
260 foreach $pkg (sort keys %$testpkgs) {
261 test_pkg($pkg, $testpkgs->{$pkg});
264 foreach $pkg (@argpkgs) {
265 test_pkg($pkg, $testpkgs->{$pkg});
274 my ($pkg, $fntypes) = @_;
277 # build %stash: keys are func-names, vals filled in below
280 => ( grep exists &{"$pkg\::$_"} # grab CODE symbols
281 => grep !/__ANON__/ # but not anon subs
282 => keys %{$pkg.'::'} # from symbol table
285 for my $type (keys %matchers) {
286 foreach my $fn (@{$fntypes->{$type}}) {
287 carp "$fn can only be one of $type, $stash{$fn}\n"
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};
297 $stash{$_} = 'skip' foreach @{$fntypes->{skip}};
300 diag("fntypes: " => Dumper($fntypes));
301 diag("$pkg stash: " => Dumper(\%stash));
303 foreach my $fn (reverse sort keys %stash) {
304 next if $stash{$fn} eq 'skip';
305 my $res = checkXS("${pkg}::$fn", $stash{$fn});
307 push @{$report{$pkg}{$res}}, $fn;
313 my ($func_name, $want) = @_;
315 croak "unknown type $want: $func_name\n"
316 unless defined $matchers{$want};
318 my ($buf, $err) = render($func_name);
319 my $res = like($buf, $matchers{$want}, "$want sub:\t $func_name");
322 # test failed. return type that would give success
323 for my $m (keys %matchers) {
324 return $m if $buf =~ $matchers{$m};
331 my ($func_name) = @_;
333 B::Concise::reset_sequence();
334 B::Concise::walk_output(\my $buf);
336 my $walker = B::Concise::compile($func_name);
337 eval { $walker->() };
338 diag("err: $@ $buf") if $@;
339 diag("verbose: $buf") if $opts{V};
345 eval { require Module::CoreList };
347 warn "Module::CoreList not available on $]\n";
350 my $mods = $Module::CoreList::version{'5.009002'};
351 $mods = [ sort keys %$mods ];
354 foreach my $pkgnm (@$mods) {
361 $Data::Dumper::Indent = 1;
362 print "Corrections: ", Dumper(\%report);
364 foreach my $pkg (sort keys %report) {
365 for my $type (keys %matchers) {
366 print "$pkg: $type: @{$report{$pkg}{$type}}\n"
367 if @{$report{$pkg}{$type}};