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 managable, 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 doesnt 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 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 } 110 unless ($Config::Config{useperlio}) { 111 print "1..0 # Skip -- Perl configured without perlio\n"; 112 exit 0; 113 } 114} 115 116use Getopt::Std; 117use Carp; 118use Test::More 'no_plan'; 119 120require_ok("B::Concise"); 121 122my %matchers = 123 ( constant => qr{ (?-x: is a constant sub, optimized to a \w+) 124 |(?-x: exists in stash, but has no START) }x, 125 XS => qr/ is XS code/, 126 perl => qr/ (next|db)state/, 127 noSTART => qr/ exists in stash, but has no START/, 128); 129 130my $testpkgs = { 131 # packages to test, with expected types for named funcs 132 133 Digest::MD5 => { perl => [qw/ import /], 134 dflt => 'XS' }, 135 136 Data::Dumper => { XS => [qw/ bootstrap Dumpxs /], 137 dflt => 'perl' }, 138 B => { 139 dflt => 'constant', # all but 47/297 140 skip => [ 'regex_padav' ], # threaded only 141 perl => [qw( 142 walksymtable walkoptree_slow walkoptree_exec 143 timing_info savesym peekop parents objsym debug 144 compile_stats clearsym class 145 )], 146 XS => [qw( 147 warnhook walkoptree_debug walkoptree threadsv_names 148 svref_2object sv_yes sv_undef sv_no save_BEGINs 149 regex_padav ppname perlstring opnumber minus_c 150 main_start main_root main_cv init_av inc_gv hash 151 formfeed end_av dowarn diehook defstash curstash 152 cstring comppadlist check_av cchar cast_I32 bootstrap 153 begin_av amagic_generation sub_generation address 154 ), $] > 5.009 ? ('unitcheck_av') : ()], 155 }, 156 157 B::Deparse => { dflt => 'perl', # 235 functions 158 159 XS => [qw( svref_2object perlstring opnumber main_start 160 main_root main_cv )], 161 162 constant => [qw/ ASSIGN CVf_LVALUE 163 CVf_METHOD LIST_CONTEXT OP_CONST OP_LIST OP_RV2SV 164 OP_STRINGIFY OPf_KIDS OPf_MOD OPf_REF OPf_SPECIAL 165 OPf_STACKED OPf_WANT OPf_WANT_LIST OPf_WANT_SCALAR 166 OPf_WANT_VOID OPpCONST_ARYBASE OPpCONST_BARE 167 OPpENTERSUB_AMPER OPpEXISTS_SUB OPpITER_REVERSED 168 OPpLVAL_INTRO OPpOUR_INTRO OPpSLICE OPpSORT_DESCEND 169 OPpSORT_INPLACE OPpSORT_INTEGER OPpSORT_NUMERIC 170 OPpSORT_REVERSE OPpTARGET_MY OPpTRANS_COMPLEMENT 171 OPpTRANS_DELETE OPpTRANS_SQUASH PMf_CONTINUE 172 PMf_EVAL PMf_EXTENDED PMf_FOLD PMf_GLOBAL PMf_KEEP 173 PMf_MULTILINE PMf_ONCE PMf_SINGLELINE 174 POSTFIX SVf_FAKE SVf_IOK SVf_NOK SVf_POK SVf_ROK 175 SVpad_OUR SVs_RMG SVs_SMG SWAP_CHILDREN OPpPAD_STATE 176 /, $] > 5.009 ? ('RXf_SKIPWHITE') : ('PMf_SKIPWHITE'), 177 'CVf_LOCKED', # This ends up as a constant, pre or post 5.10 178 ], 179 }, 180 181 POSIX => { dflt => 'constant', # all but 252/589 182 skip => [qw/ _POSIX_JOB_CONTROL /, # platform varying 183 # Might be XS or imported from Fcntl, depending on your 184 # perl version: 185 qw / S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISREG /, 186 # Might be XS or AUTOLOADed, depending on your perl 187 # version: 188 qw /WEXITSTATUS WIFEXITED WIFSIGNALED WIFSTOPPED 189 WSTOPSIG WTERMSIG/, 190 'int_macro_int', # Removed in POSIX 1.16 191 ], 192 perl => [qw/ import croak AUTOLOAD /], 193 194 XS => [qw/ write wctomb wcstombs uname tzset tzname 195 ttyname tmpnam times tcsetpgrp tcsendbreak 196 tcgetpgrp tcflush tcflow tcdrain tanh tan 197 sysconf strxfrm strtoul strtol strtod 198 strftime strcoll sinh sigsuspend sigprocmask 199 sigpending sigaction setuid setsid setpgid 200 setlocale setgid read pipe pause pathconf 201 open nice modf mktime mkfifo mbtowc mbstowcs 202 mblen lseek log10 localeconv ldexp lchown 203 isxdigit isupper isspace ispunct isprint 204 islower isgraph isdigit iscntrl isalpha 205 isalnum getcwd frexp fpathconf 206 fmod floor dup2 dup difftime cuserid ctime 207 ctermid cosh constant close clock ceil 208 bootstrap atan asin asctime acos access abort 209 _exit 210 /], 211 }, 212 213 IO::Socket => { dflt => 'constant', # 157/190 214 215 perl => [qw/ timeout socktype sockopt sockname 216 socketpair socket sockdomain sockaddr_un 217 sockaddr_in shutdown setsockopt send 218 register_domain recv protocol peername 219 new listen import getsockopt croak 220 connected connect configure confess close 221 carp bind atmark accept 222 /, $] > 5.009 ? ('blocking') : () ], 223 224 XS => [qw/ unpack_sockaddr_un unpack_sockaddr_in 225 sockatmark sockaddr_family pack_sockaddr_un 226 pack_sockaddr_in inet_ntoa inet_aton 227 /], 228 }, 229}; 230 231############ 232 233B::Concise::compile('-nobanner'); # set a silent default 234getopts('vaVcr:', \my %opts) or 235 die <<EODIE; 236 237usage: PERL_CORE=1 ./perl ext/B/t/concise-xs.t [-av] [module-list] 238 tests ability to discern XS funcs using Digest::MD5 package 239 -v : runs verbosely 240 -V : more verbosity 241 -a : runs all modules in CoreList 242 -c : writes test corrections as a Data::Dumper expression 243 -r <file> : reads file of tests, as written by -c 244 <args> : additional modules are loaded and tested 245 (will report failures, since no XS funcs are known apriori) 246 247EODIE 248 ; 249 250if (%opts) { 251 require Data::Dumper; 252 Data::Dumper->import('Dumper'); 253 $Data::Dumper::Sortkeys = 1; 254} 255my @argpkgs = @ARGV; 256my %report; 257 258if ($opts{r}) { 259 my $refpkgs = require "$opts{r}"; 260 $testpkgs->{$_} = $refpkgs->{$_} foreach keys %$refpkgs; 261} 262 263unless ($opts{a}) { 264 unless (@argpkgs) { 265 foreach $pkg (sort keys %$testpkgs) { 266 test_pkg($pkg, $testpkgs->{$pkg}); 267 } 268 } else { 269 foreach $pkg (@argpkgs) { 270 test_pkg($pkg, $testpkgs->{$pkg}); 271 } 272 } 273} else { 274 corecheck(); 275} 276############ 277 278sub test_pkg { 279 my ($pkg, $fntypes) = @_; 280 require_ok($pkg); 281 282 # build %stash: keys are func-names, vals filled in below 283 my (%stash) = map 284 ( ($_ => 0) 285 => ( grep exists &{"$pkg\::$_"} # grab CODE symbols 286 => grep !/__ANON__/ # but not anon subs 287 => keys %{$pkg.'::'} # from symbol table 288 )); 289 290 for my $type (keys %matchers) { 291 foreach my $fn (@{$fntypes->{$type}}) { 292 carp "$fn can only be one of $type, $stash{$fn}\n" 293 if $stash{$fn}; 294 $stash{$fn} = $type; 295 } 296 } 297 # set default type for un-named functions 298 my $dflt = $fntypes->{dflt} || 'perl'; 299 for my $k (keys %stash) { 300 $stash{$k} = $dflt unless $stash{$k}; 301 } 302 $stash{$_} = 'skip' foreach @{$fntypes->{skip}}; 303 304 if ($opts{v}) { 305 diag("fntypes: " => Dumper($fntypes)); 306 diag("$pkg stash: " => Dumper(\%stash)); 307 } 308 foreach my $fn (reverse sort keys %stash) { 309 next if $stash{$fn} eq 'skip'; 310 my $res = checkXS("${pkg}::$fn", $stash{$fn}); 311 if ($res ne '1') { 312 push @{$report{$pkg}{$res}}, $fn; 313 } 314 } 315} 316 317sub checkXS { 318 my ($func_name, $want) = @_; 319 320 croak "unknown type $want: $func_name\n" 321 unless defined $matchers{$want}; 322 323 my ($buf, $err) = render($func_name); 324 my $res = like($buf, $matchers{$want}, "$want sub:\t $func_name"); 325 326 unless ($res) { 327 # test failed. return type that would give success 328 for my $m (keys %matchers) { 329 return $m if $buf =~ $matchers{$m}; 330 } 331 } 332 $res; 333} 334 335sub render { 336 my ($func_name) = @_; 337 338 B::Concise::reset_sequence(); 339 B::Concise::walk_output(\my $buf); 340 341 my $walker = B::Concise::compile($func_name); 342 eval { $walker->() }; 343 diag("err: $@ $buf") if $@; 344 diag("verbose: $buf") if $opts{V}; 345 346 return ($buf, $@); 347} 348 349sub corecheck { 350 eval { require Module::CoreList }; 351 if ($@) { 352 warn "Module::CoreList not available on $]\n"; 353 return; 354 } 355 my $mods = $Module::CoreList::version{'5.009002'}; 356 $mods = [ sort keys %$mods ]; 357 print Dumper($mods); 358 359 foreach my $pkgnm (@$mods) { 360 test_pkg($pkgnm); 361 } 362} 363 364END { 365 if ($opts{c}) { 366 $Data::Dumper::Indent = 1; 367 print "Corrections: ", Dumper(\%report); 368 369 foreach my $pkg (sort keys %report) { 370 for my $type (keys %matchers) { 371 print "$pkg: $type: @{$report{$pkg}{$type}}\n" 372 if @{$report{$pkg}{$type}}; 373 } 374 } 375 } 376} 377 378__END__ 379