ext/B/t/concise-xs.t

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