1#!./perl 2 3# 2 purpose file: 1-test 2-demonstrate (via args, -v -a options) 4 5=head1 SYNOPSIS 6 7To verify that B::Concise properly reports whether functions are XS, 8perl, or optimized constant subs, we test against a few core packages 9which have a stable API, and which have functions of all 3 types. 10 11=head1 WHAT IS TESTED 12 135 core packages are tested; Digest::MD5, B, B::Deparse, Data::Dumper, 14and POSIX. These have a mix of the 3 expected implementation types; 15perl, XS, and constant (optimized constant subs). 16 17%$testpkgs specifies what packages are tested; each package is loaded, 18and the stash is scanned for the function-names in that package. 19 20Each value in %$testpkgs is a hash-of-lists (HoL) whose keys are 21implementation-types and values are lists of function-names of that type. 22 23To keep these HoLs smaller and more manageable, they may carry an 24additional 'dflt' => $impl_Type, which means that unnamed functions 25are expected to be of that default implementation type. Those unnamed 26functions are known from the scan of the package stash. 27 28=head1 HOW THEY'RE TESTED 29 30Each function is 'rendered' by B::Concise, and result is matched 31against regexs for each possible implementation-type. For some 32packages, some functions may be unimplemented on some platforms. 33 34To slay this maintenance dragon, the regexs used in like() match 35against renderings which indicate that there is no implementation. 36 37If a function is implemented differently on different platforms, the 38test for that function will fail on one of those platforms. These 39specific functions can be skipped by a 'skip' => [ @list ] to the HoL 40mentioned previously. See usage for skip in B's HoL, which avoids 41testing a function which doesn't exist on non-threaded builds. 42 43=head1 OPTIONS AND ARGUMENTS 44 45C<-v> and C<-V> trigger 2 levels of verbosity. 46 47C<-a> uses Module::CoreList to run all core packages through the test, which 48gives some interesting results. 49 50C<-c> causes the expected XS/non-XS results to be marked with 51corrections, which are then reported at program END, in a form that's 52readily cut-and-pastable into this file. 53 54 55C<< -r <file> >> reads a file, as written by C<-c>, and adjusts the expected 56results accordingly. The file is 'required', so @INC settings apply. 57 58If module-names are given as args, those packages are run through the 59test harness; this is handy for collecting further items to test, and 60may be useful otherwise (ie just to see). 61 62=head1 EXAMPLES 63 64=over 4 65 66=item ./perl -Ilib -wS ext/B/t/concise-xs.t -c Storable 67 68Tests Storable.pm for XS/non-XS routines, writes findings (along with 69test results) to stdout. You could edit results to produce a test 70file, as in next example 71 72=item ./perl -Ilib -wS ext/B/t/concise-xs.t -r ./storable 73 74Loads 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 78Gets module list from Module::Corelist, and runs them all through the 79test. Since -c is used, this generates corrections, which are saved 80in 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 84This runs the tests specified in the file created in previous example. 85-c is used again, and stdout verifies that all the expected results 86given by -r ../all-xs are now seen. 87 88Looking 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 94 95=cut 96 97BEGIN { 98 unshift @INC, 't'; 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 } 104 unless ($Config::Config{useperlio}) { 105 print "1..0 # Skip -- Perl configured without perlio\n"; 106 exit 0; 107 } 108} 109 110use Getopt::Std; 111use Carp; 112use Test::More 'no_plan'; 113 114require_ok("B::Concise"); 115 116my %matchers = 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/, 122); 123 124my $testpkgs = { 125 # packages to test, with expected types for named funcs 126 127 Digest::MD5 => { perl => [qw/ import /], 128 dflt => 'XS' }, 129 130 Data::Dumper => { XS => [qw/ bootstrap Dumpxs /, 131 $] >= 5.015 ? qw/_vstring / : () ], 132 $] >= 5.015 133 ? (constant => ['_bad_vsmg']) : (), 134 dflt => 'perl' }, 135 B => { 136 dflt => 'constant', # all but 47/297 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 150 begin_av amagic_generation sub_generation address 151 unitcheck_av) ], 152 }, 153 154 B::Deparse => { dflt => 'perl', # 236 functions 155 156 XS => [qw( svref_2object perlstring opnumber main_start 157 main_root main_cv )], 158 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/, 175 $] >= 5.015 ? qw( 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 180 ], 181 }, 182 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 186 # perl version: 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 193 ], 194 perl => [qw/ import croak AUTOLOAD /, 195 $] >= 5.015 196 ? qw/load_imports usage printf sprintf perror/ 197 : (), 198 ], 199 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 215 _exit 216 /, $] >= 5.015 ? ('sleep') : () ], 217 }, 218 219 IO::Socket => { dflt => 'constant', # 157/190 220 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 228 blocking/ ], 229 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 234 /], 235 # skip inet_ntop and inet_pton as they're not exported by default 236 }, 237}; 238 239############ 240 241B::Concise::compile('-nobanner'); # set a silent default 242getopts('vaVcr:', \my %opts) or 243 die <<EODIE; 244 245usage: PERL_CORE=1 ./perl ext/B/t/concise-xs.t [-av] [module-list] 246 tests ability to discern XS funcs using Digest::MD5 package 247 -v : runs verbosely 248 -V : more verbosity 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) 254 255EODIE 256 ; 257 258if (%opts) { 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; 263} 264my @argpkgs = @ARGV; 265my %report; 266 267if ($opts{r}) { 268 my $refpkgs = require "$opts{r}"; 269 $testpkgs->{$_} = $refpkgs->{$_} foreach keys %$refpkgs; 270} 271 272unless ($opts{a}) { 273 unless (@argpkgs) { 274 foreach $pkg (sort keys %$testpkgs) { 275 test_pkg($pkg, $testpkgs->{$pkg}); 276 } 277 } else { 278 foreach $pkg (@argpkgs) { 279 test_pkg($pkg, $testpkgs->{$pkg}); 280 } 281 } 282} else { 283 corecheck(); 284} 285############ 286 287sub test_pkg { 288 my ($pkg, $fntypes) = @_; 289 require_ok($pkg); 290 291 # build %stash: keys are func-names, vals filled in below 292 my (%stash) = map 293 ( ($_ => 0) 294 => ( grep exists &{"$pkg\::$_"} # grab CODE symbols 295 => grep !/__ANON__/ # but not anon subs 296 => keys %{$pkg.'::'} # from symbol table 297 )); 298 299 for my $type (keys %matchers) { 300 foreach my $fn (@{$fntypes->{$type}}) { 301 carp "$fn can only be one of $type, $stash{$fn}\n" 302 if $stash{$fn}; 303 $stash{$fn} = $type; 304 } 305 } 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}; 310 } 311 $stash{$_} = 'skip' foreach @{$fntypes->{skip}}; 312 313 if ($opts{v}) { 314 diag("fntypes: " => Dumper($fntypes)); 315 diag("$pkg stash: " => Dumper(\%stash)); 316 } 317 foreach my $fn (reverse sort keys %stash) { 318 next if $stash{$fn} eq 'skip'; 319 my $res = checkXS("${pkg}::$fn", $stash{$fn}); 320 if ($res ne '1') { 321 push @{$report{$pkg}{$res}}, $fn; 322 } 323 } 324} 325 326sub checkXS { 327 my ($func_name, $want) = @_; 328 329 croak "unknown type $want: $func_name\n" 330 unless defined $matchers{$want}; 331 332 my ($buf, $err) = render($func_name); 333 my $res = like($buf, $matchers{$want}, "$want sub:\t $func_name"); 334 335 unless ($res) { 336 # test failed. return type that would give success 337 for my $m (keys %matchers) { 338 return $m if $buf =~ $matchers{$m}; 339 } 340 } 341 $res; 342} 343 344sub render { 345 my ($func_name) = @_; 346 347 B::Concise::reset_sequence(); 348 B::Concise::walk_output(\my $buf); 349 350 my $walker = B::Concise::compile($func_name); 351 eval { $walker->() }; 352 diag("err: $@ $buf") if $@; 353 diag("verbose: $buf") if $opts{V}; 354 355 return ($buf, $@); 356} 357 358sub corecheck { 359 eval { require Module::CoreList }; 360 if ($@) { 361 warn "Module::CoreList not available on $]\n"; 362 return; 363 } 364 { my $x = \*Module::CoreList::version } # shut up 'used once' warning 365 my $mods = $Module::CoreList::version{'5.009002'}; 366 $mods = [ sort keys %$mods ]; 367 print Dumper($mods); 368 369 foreach my $pkgnm (@$mods) { 370 test_pkg($pkgnm); 371 } 372} 373 374END { 375 if ($opts{c}) { 376 { my $x = \*Data::Dumper::Indent } # shut up 'used once' warning 377 $Data::Dumper::Indent = 1; 378 print "Corrections: ", Dumper(\%report); 379 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}}; 384 } 385 } 386 } 387} 388 389__END__ 390